/[svn]/typing/typer.ml
ViewVC logotype

Diff of /typing/typer.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 505 by abate, Tue Jul 10 17:40:03 2007 UTC revision 508 by abate, Tue Jul 10 17:40:17 2007 UTC
# Line 35  Line 35 
35    (* Schema datastructures *)    (* Schema datastructures *)
36    
37  module StringSet = Set.Make (String)  module StringSet = Set.Make (String)
38  let schemas = State.ref "Typer.schemas" StringSet.empty (* just to remember imported schemas *)  
39      (* just to remember imported schemas *)
40    let schemas = State.ref "Typer.schemas" StringSet.empty
41    
42  let schema_types = State.ref "Typer.schema_types" (Hashtbl.create 51)  let schema_types = State.ref "Typer.schema_types" (Hashtbl.create 51)
43  let schema_elements = State.ref "Typer.schema_elements" (Hashtbl.create 51)  let schema_elements = State.ref "Typer.schema_elements" (Hashtbl.create 51)
44  let schema_attributes : (string * string, Types.descr) Hashtbl.t ref =  let schema_attributes = State.ref "Typer.schema_attributes" (Hashtbl.create 51)
   State.ref "Typer.schema_attributes" (Hashtbl.create 51)  
   
45    
46  (* Eliminate Recursion, propagate Sequence Capture Variables *)  (* Eliminate Recursion, propagate Sequence Capture Variables *)
47    
# Line 1006  Line 1006 
1006    
1007    (* Schema stuff from now on ... *)    (* Schema stuff from now on ... *)
1008    
1009  let debug = true ;;  let debug = true
1010    
1011    (** convertion from XML Schema types (including global elements and    (** convertion from XML Schema types (including global elements and
1012    attributes) to CDuce Types.descr *)    attributes) to CDuce Types.descr *)
1013  module Schema_converter =  module Schema_converter =
1014    struct    struct
1015    
1016      open Printf ;;      open Printf
1017      open Schema_types ;;      open Schema_types
1018    
1019      (* auxiliary functions *)      (* auxiliary functions *)
1020    
# Line 1026  Line 1026 
1026      let cd_type_of_simple_type = function      let cd_type_of_simple_type = function
1027        | SBuilt_in name -> PType (Schema_builtin.cd_type_of_builtin name)        | SBuilt_in name -> PType (Schema_builtin.cd_type_of_builtin name)
1028        | SUser_defined (_, _, _, _) -> assert false (* TODO *)        | SUser_defined (_, _, _, _) -> assert false (* TODO *)
     ;;  
1029    
1030      let complex_memo = Hashtbl.create 213      let complex_memo = Hashtbl.create 213
1031    
# Line 1091  Line 1090 
1090              PAlias slot              PAlias slot
1091    
1092    
1093    (* TODO if constraint is Fixed we can give a more precise CDuce type *)
1094    
1095        (** @return a closed record *)        (** @return a closed record *)
1096      and cd_type_of_attr_uses attr_uses =      and cd_type_of_attr_uses attr_uses =
1097        let fields =        let fields =
1098          List.map          List.map
1099            (fun (required, (name, st, _), _) ->            (fun (required, (name, st, _), _) ->
1100               let r = cd_type_of_simple_type !st in               let r = cd_type_of_simple_type st in
1101               let r = if required then r else POptional r in               let r = if required then r else POptional r in
1102               (LabelPool.mk (U.mk name), r)               (LabelPool.mk (U.mk name), r)
1103            ) attr_uses in            ) attr_uses in
1104        PRecord (false, LabelMap.from_list_disj fields)        PRecord (false, LabelMap.from_list_disj fields)
1105    
1106        and cd_type_of_att_decl (name, st, _) =
1107          let r = cd_type_of_simple_type st in
1108          PRecord (false, LabelMap.from_list_disj [(LabelPool.mk (U.mk name), r)])
1109    
1110      and cd_type_of_elt_decl (name, typ, _) =      and cd_type_of_elt_decl (name, typ, _) =
1111        let atom_type = PType (Types.atom (Atoms.atom (Atoms.mk (U.mk name)))) in        let atom_type = PType (Types.atom (Atoms.atom (Atoms.mk (U.mk name)))) in
1112        let content = match !typ with        let content = match !typ with
1113          | S st -> PTimes (PType Types.empty_closed_record, cd_type_of_simple_type st)          | S st ->
1114                PTimes (PType Types.empty_closed_record, cd_type_of_simple_type st)
1115          | C ct -> cd_type_of_complex_type' ct          | C ct -> cd_type_of_complex_type' ct
1116        in        in
1117        PXml (atom_type, content)        PXml (atom_type, content)
# Line 1119  Line 1125 
1125      let cd_type_of_type_def = function      let cd_type_of_type_def = function
1126        | S st -> typ (cd_type_of_simple_type st)        | S st -> typ (cd_type_of_simple_type st)
1127        | C ct -> cd_type_of_complex_type ct        | C ct -> cd_type_of_complex_type ct
     ;;  
1128    
1129      let cd_type_of_elt_decl x =      let cd_type_of_elt_decl x = typ (cd_type_of_elt_decl x)
1130        typ (cd_type_of_elt_decl x)      let cd_type_of_att_decl x = typ (cd_type_of_att_decl x)
1131    
1132    end    end
 ;;  
1133    
1134  let get_schema_validator (schema_name, elt_name) =  let get_schema_validator (schema_name, elt_name) =
1135    snd (Hashtbl.find !schema_elements (schema_name, elt_name))    snd (Hashtbl.find !schema_elements (schema_name, elt_name))
 ;;  
1136    
1137  let register_schema schema_name schema =  let register_schema schema_name schema =
1138    if StringSet.mem schema_name !schemas then    if StringSet.mem schema_name !schemas then
# Line 1143  Line 1146 
1146            (schema_name, Schema_types.name_of_type_def type_def)            (schema_name, Schema_types.name_of_type_def type_def)
1147            cd_type)            cd_type)
1148        schema.Schema_types.type_defs;        schema.Schema_types.type_defs;
1149                (* Schema attributes -> CDuce types TODO *)      List.iter (* Schema attributes -> CDuce types *)
1150          (fun (att_name, _, _) as att_decl ->
1151            let cd_type = Schema_converter.cd_type_of_att_decl att_decl in
1152            Hashtbl.add !schema_attributes (schema_name, att_name) cd_type)
1153          schema.Schema_types.att_decls;
1154      List.iter (* Schema elements -> CDuce types * validators *)      List.iter (* Schema elements -> CDuce types * validators *)
1155        (fun elt_decl ->        (fun elt_decl ->
1156          let cd_type = Schema_converter.cd_type_of_elt_decl elt_decl in          let cd_type = Schema_converter.cd_type_of_elt_decl elt_decl in
# Line 1157  Line 1164 
1164            (cd_type, validator))            (cd_type, validator))
1165        schema.Schema_types.elt_decls        schema.Schema_types.elt_decls
1166    end    end
 ;;  
1167    
1168  (* DEBUGGING ONLY *)  (* DEBUGGING ONLY *)
1169    
1170  let get_schema_type x = fst (Hashtbl.find !schema_elements x) ;;  let get_schema_type x = fst (Hashtbl.find !schema_elements x)
Legend:
Removed from v.505  
changed lines
  Added in v.508
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5