[r2003-06-12 15:09:46 by cvscast] Starting recursive types in Schema

Original author: cvscast
Date: 2003-06-12 15:09:46+00:00

schema/schema_parser.ml

@@ -36,7 +36,7 @@ let get_maxOccurs n =
 let content_type_of_def = function
   | S def -> CT_simple def
   | C (CBuilt_in _) -> assert false
-  | C (CUser_defined (_, _, _, _, ct)) -> ct
+  | C (CUser_defined (_, _, _, _, _, ct)) -> ct
 ;;
 
 let parse_facet resolver base_type_def n =
@@ -211,7 +211,7 @@ let attribute_uses_of_restriction ~resolver ~n ~base =
   in
   let from_base =
     match base with
-    | C (CUser_defined (_, _, _, attribute_uses, _)) ->
+    | C (CUser_defined (_, _, _, _, attribute_uses, _)) ->
         List.filter (* filters out attribute uses redefined and
                     prohibited in this type *)
           (fun use ->
@@ -231,12 +231,19 @@ let attribute_uses_of_extension ~resolver ~n ~base =
   in
   let from_base =
     match base with
-    | C (CUser_defined (_, _, _, attribute_uses, _)) -> attribute_uses
+    | C (CUser_defined (_, _, _, _, attribute_uses, _)) -> attribute_uses
     | _ -> []
   in
   filter_out_none embedded @ from_base
 ;;
 
+let counter = ref 0
+
+let cuser_defined name base derivation attribute_uses ct =
+  incr counter;
+  CUser_defined (!counter, name, base, derivation, attribute_uses, ct)
+    
+
 let rec parse_complex_type resolver n =
   let name = try Some n#extension#name with Not_found -> None in
   if n#extension#has_element "xsd:simpleContent" then begin
@@ -250,7 +257,7 @@ let rec parse_complex_type resolver n =
       in
       let content_type =
         (match !base with
-        | C (CUser_defined (_, _, _, _, (CT_simple base))) ->
+        | C (CUser_defined (_, _, _, _, _, (CT_simple base))) ->
             let base =
               try
                 parse_simple_type resolver
@@ -260,7 +267,7 @@ let rec parse_complex_type resolver n =
             CT_simple (restrict_simple_type base (get_facet_nodes  n))
         | _ -> assert false)
       in
-      CUser_defined (name, base, Restriction, attribute_uses, content_type)
+      cuser_defined name base Restriction attribute_uses content_type
     end else if content#extension#has_element "xsd:extension" then begin
       (* simpleContent, extension *)
       let extension = find_element "xsd:extension" content in
@@ -270,11 +277,11 @@ let rec parse_complex_type resolver n =
       in
       let content_type =
         (match !base with
-        | C (CUser_defined (_, _, _, _, (CT_simple base))) -> CT_simple base
+        | C (CUser_defined (_, _, _, _, _, (CT_simple base))) -> CT_simple base
         | S simple_type_def -> CT_simple simple_type_def
         | _ -> assert false)
       in
-      CUser_defined (name, base, Extension, attribute_uses, content_type)
+      cuser_defined name base Extension attribute_uses content_type
     end else
       (* simpleContent, neither extension nor restriction *)
       raise (XSD_validation_error "Neither <extension> nor <restriction> \
@@ -300,7 +307,7 @@ let rec parse_complex_type resolver n =
             (parse_particle resolver restriction#extension#find_term, mixed)
         end
       in
-      CUser_defined (name, base, Restriction, attribute_uses, content_type)
+      cuser_defined name base Restriction attribute_uses content_type
     end else if content#extension#has_element "xsd:extension" then begin
       (* complexContent, extension *)
       let extension = find_element "xsd:extension" content in
@@ -328,7 +335,7 @@ let rec parse_complex_type resolver n =
                 mixed)
           | _ -> assert false
       in
-      CUser_defined (name, base, Extension, attribute_uses, content_type)
+      cuser_defined name base Extension attribute_uses content_type
     end else
       (* complexContent, neither extension nor restriction *)
       raise (XSD_validation_error "Neither <extension> nor <restriction> \
@@ -348,7 +355,7 @@ let rec parse_complex_type resolver n =
         CT_model (parse_particle resolver n#extension#find_term, mixed)
       end
     in
-    CUser_defined (name, base, Restriction, attribute_uses, content_type)
+    cuser_defined name base Restriction attribute_uses content_type
   end
 
 and parse_elt_decl resolver n =
@@ -382,7 +389,7 @@ and parse_particle resolver n =
             !(resolver#resolve_typ n#extension#typ)))
       in
       minOccurs, maxOccurs, Elt (ref (name, ref type_def, None))
-  | T_element "xsd:element" when n#extension#has_attribute "ref" ->
+  | T_element "xsd:element" (* when n#extension#has_attribute "ref" *)->
       let elt_decl = resolver#resolve_elt n#extension#ref in
       minOccurs, maxOccurs, (Elt elt_decl)
   | T_element "xsd:all" ->

schema/schema_types.ml

@@ -63,6 +63,7 @@ and elt_decl = string * type_def ref * value_constraint option
 and complex_type_def =
   | CBuilt_in of string
   | CUser_defined of
+      int *
       string option * type_def ref * derivation *
       attribute_use list * content_type
 and type_def = S of simple_type_def | C of complex_type_def
@@ -80,8 +81,8 @@ let name_of_type_def = function
   | C (CBuilt_in name) -> name
   | S (SUser_defined (Some name, _, _, _)) -> name
   | S (SUser_defined (None, _, _, _)) -> "| UNNAMED |"
-  | C (CUser_defined (Some name, _, _, _, _)) -> name
-  | C (CUser_defined (None, _, _, _, _)) -> "| UNNAMED |"
+  | C (CUser_defined (_, Some name, _, _, _, _)) -> name
+  | C (CUser_defined (_, None, _, _, _, _)) -> "| UNNAMED |"
 ;;
 let name_of_attribute_use (_, (n, _, _), _) = n ;;
 
@@ -111,7 +112,7 @@ and print_type ppf = function
   | C c -> fprintf ppf "@[%a@]" print_complex_type c
 and print_complex_type ppf = function
   | CBuilt_in n -> fprintf ppf "@[%s@]" n
-  | CUser_defined (_, _, _, _, ct) -> fprintf ppf "@[%a@]" print_ct ct
+  | CUser_defined (_,_, _, _, _, ct) -> fprintf ppf "@[%a@]" print_ct ct
 and print_ct ppf = function
   | CT_empty -> fprintf ppf "@[EMPTY@]"
   | CT_simple s -> print_simple_type ppf s

schema/schema_types.mli

@@ -88,6 +88,7 @@ and elt_decl =
 and complex_type_def =
   | CBuilt_in of string
   | CUser_defined of
+      int * (* Unique ID *)
       string option * (* name *)
       type_def ref *  (* base *)
       derivation *

schema/schema_validator.ml

@@ -287,7 +287,7 @@ and validator_of_complex_type = function
       ((fun _ -> assert false),
        (pcdata_wrapper (Schema_builtin.__validate_fun_of_builtin s),
         First.empty))
-  | CUser_defined (_, _, _, attr_uses, ct) ->
+  | CUser_defined (_, _, _, _, attr_uses, ct) ->
       let validate_attrs = validate_attrs_of_uses attr_uses in
       let content_validator =
         match ct with

typing/typer.ml

@@ -563,14 +563,16 @@ let register_global_types b =
 
 let dump_global_types ppf =
   TypeEnv.iter (fun v _ -> Format.fprintf ppf " %s" v) !glb
-    
-    
-let typ p =
-  let s = compile_slot (derecurs !glb p) in
+
+let do_typ loc r = 
+  let s = compile_slot r in
   flush_defs ();
   flush_fv ();
   if IdSet.is_empty (fv_slot s) then typ_node s
-  else raise_loc_generic p.loc "Capture variables are not allowed in types"
+  else raise_loc_generic loc "Capture variables are not allowed in types"
+   
+let typ p =
+  do_typ p.loc (derecurs !glb p)
     
 let pat p = 
   let s = compile_slot (derecurs !glb p) in
@@ -1017,31 +1019,33 @@ module Schema_converter =
     (* auxiliary functions *)
 
       (* build a regexp Elem from a Types.descr *)
-    let mk_re_elt descr = Ast.Elem (Location.mknoloc (Ast.Internal descr)) ;;
+    let mk_re_elt descr = PElem descr
 
     (* conversion functions *)
 
     let cd_type_of_simple_type = function
-      | SBuilt_in name -> Schema_builtin.cd_type_of_builtin name
+      | SBuilt_in name -> PType (Schema_builtin.cd_type_of_builtin name)
       | SUser_defined (_, _, _, _) -> assert false (* TODO *)
     ;;
 
+    let complex_memo = Hashtbl.create 213
+
     let rec regexp_of_term = function
       | All _ -> assert false
-      | Choice [] -> Ast.Epsilon
+      | Choice [] -> PEpsilon
       | Choice (hd :: tl) ->
           List.fold_left
-            (fun acc particle -> Ast.Alt (acc, regexp_of_particle particle))
+            (fun acc particle -> PAlt (acc, regexp_of_particle particle))
             (regexp_of_particle hd) tl
-      | Sequence [] -> Ast.Epsilon
+      | Sequence [] -> PEpsilon
       | Sequence (hd :: tl) ->
           List.fold_left
-            (fun acc particle -> Ast.Seq (acc, regexp_of_particle particle))
+            (fun acc particle -> PSeq (acc, regexp_of_particle particle))
             (regexp_of_particle hd) tl
       | Elt decl -> mk_re_elt (cd_type_of_elt_decl !decl)
 
     and regexp_of_content_type = function
-      | CT_empty -> Ast.Epsilon
+      | CT_empty -> PEpsilon
       | CT_simple st -> mk_re_elt (cd_type_of_simple_type st)
       | CT_model (particle, mixed) ->
           assert (not mixed); (* TODO mixed support *)
@@ -1051,8 +1055,8 @@ module Schema_converter =
         (* given a regexp re and a (non negative) integer n create a regexp
         matching exactly n times re *)
       let rec repeat_regexp re = function
-        | 0 -> Ast.Epsilon
-        | n when n > 0 -> Ast.Seq (re, repeat_regexp re (n - 1))
+        | 0 -> PEpsilon
+        | n when n > 0 -> PSeq (re, repeat_regexp re (n - 1))
         | _ -> assert false
       in
       fun (min, max, term) ->
@@ -1065,55 +1069,61 @@ module Schema_converter =
               | 0 -> acc
               | n ->
                   aux
-                    (Ast.Alt (Ast.Epsilon, (Ast.Seq (term_regexp, acc))))
+                    (PAlt (PEpsilon, (PSeq (term_regexp, acc))))
                     (n - 1)
             in
-            Ast.Seq (min_regexp, aux Ast.Epsilon (max - min))
-        | None -> Ast.Seq (min_regexp, Ast.Star term_regexp)
+            PSeq (min_regexp, aux PEpsilon (max - min))
+        | None -> PSeq (min_regexp, PStar term_regexp)
 
       (** @return a pair composed by a type for the attributes (a record) and a
       type for the content model (a sequence) *)
     and cd_type_of_complex_type' = function
       | CBuilt_in name -> assert false
-      | CUser_defined (name, _, _, attr_uses, content) ->
-          let content_re = regexp_of_content_type content in
-          let content_ast_node =
-            Location.mknoloc (Ast.Regexp
-              (content_re, Location.mknoloc (Ast.Internal Sequence.nil_type)))
-          in
-          (cd_type_of_attr_uses attr_uses, (Types.descr (typ content_ast_node)))
+      | CUser_defined (id, name, _, _, attr_uses, content) ->
+	  try PAlias (Hashtbl.find complex_memo id)
+	  with Not_found -> 
+	    let slot = mk_slot noloc in
+	    Hashtbl.add complex_memo id slot;
+            let content_re = regexp_of_content_type content in
+            let content_ast_node = PRegexp (content_re, PType Sequence.nil_type) in
+	    slot.pdescr <- Some 
+	      (PTimes (cd_type_of_attr_uses attr_uses, content_ast_node));
+	    PAlias slot
+	    
 
       (** @return a closed record *)
     and cd_type_of_attr_uses attr_uses =
-      Types.rec_of_list' ~opened:false
-        (List.fold_left
-          (fun fields (required, (name, st, _), _) ->
-            (not required, name, cd_type_of_simple_type !st) :: fields)
-          [] attr_uses)
+      let fields = 
+	List.map 
+	  (fun (required, (name, st, _), _) ->
+	     let r = cd_type_of_simple_type !st in
+	     let r = if required then r else POptional r in
+	     (LabelPool.mk (U.mk name), r)
+	  ) attr_uses in
+      PRecord (false, LabelMap.from_list_disj fields)
 
     and cd_type_of_elt_decl (name, typ, _) =
-      let atom_type = Types.atom (Atoms.atom (Atoms.mk_ascii name)) in
-      (match !typ with
-      | S st ->
-          Types.xml' atom_type Types.empty_closed_record
-            (cd_type_of_simple_type st)
-      | C ct ->
-          let (attr_type, cont_type) = cd_type_of_complex_type' ct in
-          Types.xml' atom_type attr_type cont_type)
-    ;;
+      let atom_type = PType (Types.atom (Atoms.atom (Atoms.mk (U.mk name)))) in
+      let content = match !typ with
+	| S st -> PTimes (PType Types.empty_closed_record, cd_type_of_simple_type st)
+	| C ct -> cd_type_of_complex_type' ct
+      in
+      PXml (atom_type, content)
+
+    let typ r = Types.descr (do_typ noloc r)
 
     let cd_type_of_complex_type = function
       | CBuilt_in name -> Schema_builtin.cd_type_of_builtin name
-      | ct ->
-          let (attr_type, cont_type) = cd_type_of_complex_type' ct in
-          Types.xml' Types.any attr_type cont_type
-    ;;
+      | ct -> typ (PXml (PType Types.any, cd_type_of_complex_type' ct))
 
     let cd_type_of_type_def = function
-      | S st -> cd_type_of_simple_type st
+      | S st -> typ (cd_type_of_simple_type st)
       | C ct -> cd_type_of_complex_type ct
     ;;
 
+    let cd_type_of_elt_decl x =
+      typ (cd_type_of_elt_decl x)
+
   end
 ;;