[r2003-11-21 12:51:57 by szach] qualify record fields and tagnames with targetNamespace namespace

Original author: szach
Date: 2003-11-21 12:51:57+00:00

typing/typer.ml

@@ -1361,7 +1361,7 @@ module Schema_converter =
 
     (* conversion functions *)
 
-    let rec cd_type_of_simple_type = function
+    let rec cd_type_of_simple_type ~schema = function
       | Primitive name | Derived (Some name, _, _, _)
         when Schema_builtin.is_builtin name ->
           PType (Schema_builtin.cd_type_of_builtin name)
@@ -1386,9 +1386,10 @@ module Schema_converter =
           PType (Schema_builtin.cd_type_of_builtin name)
       | Derived (_, Atomic _, facets, _) -> assert false
       | Derived (_, List item, facets, _) ->
-          mk_seq_derecurs ~base:(PElem (cd_type_of_simple_type item)) facets
+          mk_seq_derecurs
+            ~base:(PElem (cd_type_of_simple_type ~schema item)) facets
       | Derived (_, Union items, facets, _) ->
-          (match List.map cd_type_of_simple_type items with
+          (match List.map (cd_type_of_simple_type ~schema) items with
           | [] -> assert false  (* vacuum union *)
           | [t] -> t            (* useless union *)
           | hd::tl -> List.fold_left (fun acc x -> POr (x, acc)) hd tl)
@@ -1396,69 +1397,72 @@ module Schema_converter =
     let complex_memo = Hashtbl.create 213
     let element_memo = Hashtbl.create 213
 
-    let rec regexp_of_term = function
-      | Model group -> regexp_of_model_group group
-      | Elt decl -> PElem (cd_type_of_elt_decl !decl)
+    let rec regexp_of_term ~schema = function
+      | Model group -> regexp_of_model_group ~schema group
+      | Elt decl -> PElem (cd_type_of_elt_decl ~schema !decl)
 
-    and regexp_of_model_group = function
+    and regexp_of_model_group ~schema = function
       | All [] | Choice [] | Sequence [] -> PEpsilon
       | Choice (hd :: tl) ->
           List.fold_left
-            (fun acc particle -> PAlt (acc, regexp_of_particle particle))
-            (regexp_of_particle hd) tl
+            (fun acc particle ->
+              PAlt (acc, regexp_of_particle ~schema particle))
+            (regexp_of_particle ~schema hd) tl
       | All (hd :: tl) | Sequence (hd :: tl) ->
           List.fold_left
-            (fun acc particle -> PSeq (acc, regexp_of_particle particle))
-            (regexp_of_particle hd) tl
+            (fun acc particle ->
+              PSeq (acc, regexp_of_particle ~schema particle))
+            (regexp_of_particle ~schema hd) tl
 
-    and regexp_of_content_type = function
+    and regexp_of_content_type ~schema = function
       | CT_empty -> PEpsilon
-      | CT_simple st -> PElem (cd_type_of_simple_type st)
+      | CT_simple st -> PElem (cd_type_of_simple_type ~schema st)
       | CT_model (particle, mixed) ->
           assert (not mixed); (* TODO mixed support *)
-          regexp_of_particle particle
+          regexp_of_particle ~schema particle
 
-    and regexp_of_particle (min, max, term) =
-      mk_len_regexp ?min:(Some min) ?max (regexp_of_term term)
+    and regexp_of_particle ~schema (min, max, term) =
+      mk_len_regexp ?min:(Some min) ?max (regexp_of_term ~schema term)
 
       (** @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' (id, name, _, _, attr_uses, content) =
+    and cd_type_of_complex_type' ~schema (id, name, _, _, attr_uses, content) =
       try
         PAlias (Hashtbl.find complex_memo id)
       with Not_found -> 
         let slot = mk_derecurs_slot noloc in
         Hashtbl.add complex_memo id slot;
-        let content_re = regexp_of_content_type content in
+        let content_re = regexp_of_content_type ~schema content in
         let content_ast_node = PRegexp (content_re, PType Sequence.nil_type) in
         slot.pdescr <-
-          PTimes (cd_type_of_attr_uses attr_uses, content_ast_node);
+          PTimes (cd_type_of_attr_uses ~schema attr_uses, content_ast_node);
         PAlias slot
 	    
       (** @return a closed record *)
-    and cd_type_of_attr_uses attr_uses =
+    and cd_type_of_attr_uses ~schema attr_uses =
       let fields = 
 	List.map 
           (fun (required, (name, st, _), constr) ->
             let r =
               match constr with
               | Some (`Fixed v) -> PType (Types.constant (Value.inv_const v))
-              | _ -> cd_type_of_simple_type st
+              | _ -> cd_type_of_simple_type ~schema st
             in
             let r = if required then r else POptional r in
-            (LabelPool.mk (Ns.empty, U.mk name), r))  (* TODO: NS *)
+            (LabelPool.mk (schema.targetNamespace, U.mk name), r))
           attr_uses in
       PRecord (false, LabelMap.from_list_disj fields)
 
-    and cd_type_of_att_decl (name, st, _) =
-      let r = cd_type_of_simple_type st in
+    and cd_type_of_att_decl ~schema (name, st, _) =
+      let r = cd_type_of_simple_type ~schema st in
       PRecord (false,
-        LabelMap.from_list_disj [(LabelPool.mk (Ns.empty, U.mk name), r)])
-	(* TODO: NS *)
+        LabelMap.from_list_disj
+          [(LabelPool.mk (schema.targetNamespace, U.mk name), r)])
 
-    and cd_type_of_elt_decl (_, name, typ, constr) =
+    and cd_type_of_elt_decl ~schema (_, name, typ, constr) =
       let atom_type =
-        PType (Types.atom (Atoms.atom (Atoms.V.mk Ns.empty (U.mk name))))
+        PType (Types.atom (Atoms.atom (Atoms.V.mk schema.targetNamespace
+          (U.mk name))))
       in
       let content =
         match constr with
@@ -1468,29 +1472,32 @@ module Schema_converter =
           | AnyType -> PType (Schema_builtin.cd_type_of_builtin "xsd:anyType")
           | Simple st ->
               PTimes
-                (PType Types.empty_closed_record, cd_type_of_simple_type st)
-          | Complex ct -> cd_type_of_complex_type' ct)
+                (PType Types.empty_closed_record,
+                 cd_type_of_simple_type ~schema st)
+          | Complex ct -> cd_type_of_complex_type' ~schema ct)
       in
       PXml (atom_type, content)
 
-    let cd_type_of_complex_type ct =
-      PXml (PType Types.any, cd_type_of_complex_type' ct)
+    let cd_type_of_complex_type ~schema ct =
+      PXml (PType Types.any, cd_type_of_complex_type' ~schema ct)
 
-    let cd_type_of_model_group g = PRegexp (regexp_of_model_group g, nil_type)
+    let cd_type_of_model_group ~schema g =
+      PRegexp (regexp_of_model_group ~schema g, nil_type)
 
     let typ r = Types.descr (do_typ noloc r)
 
       (* Schema_converter interface implementation.
        * Shadows previous definitions.
        *)
-    let cd_type_of_type_def = function
+    let cd_type_of_type_def ~schema = function
       | AnyType -> Schema_builtin.cd_type_of_builtin "xsd:anyType"
-      | Simple st -> typ (cd_type_of_simple_type st)
-      | Complex ct -> typ (cd_type_of_complex_type ct)
-    let cd_type_of_elt_decl x = typ (cd_type_of_elt_decl x)
-    let cd_type_of_att_decl x = typ (cd_type_of_att_decl x)
-    let cd_type_of_attr_uses x = typ (cd_type_of_attr_uses x)
-    let cd_type_of_model_group x = typ (cd_type_of_model_group x)
+      | Simple st -> typ (cd_type_of_simple_type ~schema st)
+      | Complex ct -> typ (cd_type_of_complex_type ~schema ct)
+    let cd_type_of_elt_decl ~schema x = typ (cd_type_of_elt_decl ~schema x)
+    let cd_type_of_att_decl ~schema x = typ (cd_type_of_att_decl ~schema x)
+    let cd_type_of_attr_uses ~schema x = typ (cd_type_of_attr_uses ~schema x)
+    let cd_type_of_model_group ~schema x =
+      typ (cd_type_of_model_group ~schema x)
 
   end
 
@@ -1517,33 +1524,33 @@ let register_schema schema_name schema =
     Hashtbl.add !schemas schema_name schema;
     List.iter (* Schema types -> CDuce types *)
       (fun type_def ->
-        let cd_type = Schema_converter.cd_type_of_type_def type_def in
+        let cd_type = Schema_converter.cd_type_of_type_def ~schema type_def in
         let name = Schema_common.name_of_type_definition type_def in
         log_schema_component "type" schema_name name cd_type;
         Hashtbl.add !schema_types (schema_name, name) cd_type)
       schema.Schema_types.types;
     List.iter (* Schema attributes -> CDuce types *)
       (fun (name, _, _) as att_decl ->
-        let cd_type = Schema_converter.cd_type_of_att_decl att_decl in
+        let cd_type = Schema_converter.cd_type_of_att_decl ~schema att_decl in
         log_schema_component "attribute" schema_name name cd_type;
         Hashtbl.add !schema_attributes (schema_name, name) cd_type)
       schema.Schema_types.attributes;
     List.iter (* Schema elements -> CDuce types *)
       (fun elt_decl ->
-        let cd_type = Schema_converter.cd_type_of_elt_decl elt_decl in
+        let cd_type = Schema_converter.cd_type_of_elt_decl ~schema elt_decl in
         let name = Schema_common.name_of_element_declaration elt_decl in
         log_schema_component "element" schema_name name cd_type;
         Hashtbl.add !schema_elements (schema_name, name) cd_type)
       schema.Schema_types.elements;
     List.iter (* Schema attribute groups -> CDuce types *)
       (fun (name, uses) ->
-        let cd_type = Schema_converter.cd_type_of_attr_uses uses in
+        let cd_type = Schema_converter.cd_type_of_attr_uses ~schema uses in
         log_schema_component "attribute group" schema_name name cd_type;
         Hashtbl.add !schema_attribute_groups (schema_name, name) cd_type)
       schema.Schema_types.attribute_groups;
     List.iter (* Schema model groups -> CDuce types *)
       (fun (name, group) ->
-        let cd_type = Schema_converter.cd_type_of_model_group group in
+        let cd_type = Schema_converter.cd_type_of_model_group ~schema group in
         log_schema_component "model group" schema_name name cd_type;
         Hashtbl.add !schema_model_groups (schema_name, name) cd_type)
       schema.Schema_types.model_groups;