[r2003-06-13 10:03:21 by cvscast] zack: synced with new schema_types

Original author: cvscast
Date: 2003-06-13 10:03:21+00:00

typing/typer.ml

@@ -35,13 +35,13 @@ let error loc msg = raise_loc loc (Error msg)
   (* Schema datastructures *)
 
 module StringSet = Set.Make (String)
-let schemas = State.ref "Typer.schemas" StringSet.empty (* just to remember imported schemas *)
+
+  (* just to remember imported schemas *)
+let schemas = State.ref "Typer.schemas" StringSet.empty
 
 let schema_types = State.ref "Typer.schema_types" (Hashtbl.create 51)
 let schema_elements = State.ref "Typer.schema_elements" (Hashtbl.create 51)
-let schema_attributes : (string * string, Types.descr) Hashtbl.t ref =
-  State.ref "Typer.schema_attributes" (Hashtbl.create 51)
-
+let schema_attributes = State.ref "Typer.schema_attributes" (Hashtbl.create 51)
 
 (* Eliminate Recursion, propagate Sequence Capture Variables *)
 
@@ -1006,15 +1006,15 @@ let report_unused_branches () =
 
   (* Schema stuff from now on ... *)
 
-let debug = true ;;
+let debug = true
 
   (** convertion from XML Schema types (including global elements and
   attributes) to CDuce Types.descr *)
 module Schema_converter =
   struct
 
-    open Printf ;;
-    open Schema_types ;;
+    open Printf
+    open Schema_types
 
     (* auxiliary functions *)
 
@@ -1026,7 +1026,6 @@ module Schema_converter =
     let cd_type_of_simple_type = function
       | SBuilt_in name -> PType (Schema_builtin.cd_type_of_builtin name)
       | SUser_defined (_, _, _, _) -> assert false (* TODO *)
-    ;;
 
     let complex_memo = Hashtbl.create 213
 
@@ -1091,21 +1090,28 @@ module Schema_converter =
 	    PAlias slot
 	    
 
+(* TODO if constraint is Fixed we can give a more precise CDuce type *)
+
       (** @return a closed record *)
     and cd_type_of_attr_uses attr_uses =
       let fields = 
 	List.map 
 	  (fun (required, (name, st, _), _) ->
-	     let r = cd_type_of_simple_type !st in
+	     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_att_decl (name, st, _) =
+      let r = cd_type_of_simple_type st in
+      PRecord (false, LabelMap.from_list_disj [(LabelPool.mk (U.mk name), r)])
+
     and cd_type_of_elt_decl (name, typ, _) =
       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)
+	| 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)
@@ -1119,17 +1125,14 @@ module Schema_converter =
     let cd_type_of_type_def = function
       | 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)
+    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)
 
   end
-;;
 
 let get_schema_validator (schema_name, elt_name) =
   snd (Hashtbl.find !schema_elements (schema_name, elt_name))
-;;
 
 let register_schema schema_name schema =
   if StringSet.mem schema_name !schemas then
@@ -1143,7 +1146,11 @@ let register_schema schema_name schema =
           (schema_name, Schema_types.name_of_type_def type_def)
           cd_type)
       schema.Schema_types.type_defs;
-              (* Schema attributes -> CDuce types TODO *)
+    List.iter (* Schema attributes -> CDuce types *)
+      (fun (att_name, _, _) as att_decl ->
+        let cd_type = Schema_converter.cd_type_of_att_decl att_decl in
+        Hashtbl.add !schema_attributes (schema_name, att_name) cd_type)
+      schema.Schema_types.att_decls;
     List.iter (* Schema elements -> CDuce types * validators *)
       (fun elt_decl ->
         let cd_type = Schema_converter.cd_type_of_elt_decl elt_decl in
@@ -1157,8 +1164,7 @@ let register_schema schema_name schema =
           (cd_type, validator))
       schema.Schema_types.elt_decls
   end
-;;
 
 (* DEBUGGING ONLY *)
 
-let get_schema_type x = fst (Hashtbl.find !schema_elements x) ;;
+let get_schema_type x = fst (Hashtbl.find !schema_elements x)