schema_converter.ml 6.06 KB
Newer Older
1
2
3
4
5
open Ident
open Schema_types
open Schema_common
open Schema_validator
open Encodings
6
open Typepat
7
8
9

let xsd = Schema_xml.xsd
let is_xsd (ns,l) local =
10
  (Ns.Uri.equal ns xsd) && (String.compare (Utf8.get_str l) local = 0)
11
12
13
14
15
16

let complex_memo = Hashtbl.create 213
  
(* TODO: better approx *)
let xsd_any_type = Types.any
  
17
let nil_type = mk_type Sequence.nil_type
18
  
19
let mk_len_regexp min max base =
20
  let rec repeat_regexp re = function
21
22
    | 0 -> mk_epsilon
    | n -> mk_seq re (repeat_regexp re (pred n))
23
24
25
26
27
28
  in
  let min_regexp = repeat_regexp base min in
  match max with
    | Some max ->
	let rec aux acc = function
          | 0 -> acc
29
          | n -> aux (mk_alt mk_epsilon (mk_seq base acc)) (pred n)
30
        in
31
32
        mk_seq min_regexp (aux mk_epsilon (max-min))
    | None -> mk_seq min_regexp  (mk_star base)
33
34
35
36
37
38
39
40
41
42
	
let mk_seq_derecurs base facets =
  let min,max = match facets with
    | { length = Some (v, _) } -> v, Some v
    | { minLength = Some (v, _); maxLength = None } -> v, None
    | { minLength = None; maxLength = Some (v, _) } -> 1, Some v
    | { minLength = Some (a,_); maxLength = Some (b, _) } -> a, Some b
    | _ -> 1, Some 1 in
  Sequence.repet min max base
    
43
44
45
let xsi_nil_type =
  let m = LabelMap.singleton xsi_nil_label (Types.cons Builtin_defs.true_type)
  in
46
  Types.record_fields (false,m)
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
    
    
    
let rec simple_type = function
  | { st_name = Some name } 
      when Schema_builtin.is name ->
      Schema_builtin.cd_type (Schema_builtin.get name)
  | { st_variety = Atomic st } ->
      (* TODO: apply facets *)
      Schema_builtin.cd_type (Schema_builtin.of_st st)
  | { st_variety = List item; st_facets = facets } ->
      mk_seq_derecurs (simple_type item) facets
  | { st_variety = Union members; st_facets = facets } ->
      let members = List.map simple_type members in
      List.fold_left (fun acc x -> Types.cup x acc) Types.empty members
	
63
64
65
66
67
68
69
70
71
72
73
74
75
let attr_uses (attrs,other) =
  let fields = 
    List.map 
      (fun at ->
         let r =
           match at.attr_use_cstr with
             | Some (`Fixed (_,v)) -> Types.constant (Value.inv_const v)
             | _ -> simple_type at.attr_decl.attr_typdef
         in
	 (not at.attr_required,  at.attr_decl.attr_name, r))
      attrs in
  Types.rec_of_list false fields
    
76
77
let rec regexp_of_term = function
  | Model group -> regexp_of_model_group group
78
79
  | Elt decl -> mk_elem (elt_decl decl)
  | Wildcard w -> mk_elem (wildcard w)
80
81
      
and wildcard w = 
82
  mk_type (Builtin_defs.any_xml_with_tag w.wild_first)
83
84
85
86
    
and regexp_of_model_group = function
  | Choice l ->
      List.fold_left
87
88
	(fun acc particle -> mk_alt acc (regexp_of_particle particle))
        mk_empty l
89
90
  | All l | Sequence l ->
      List.fold_left
91
92
        (fun acc particle -> mk_seq acc (regexp_of_particle particle))
	mk_epsilon l
93
94
	
and regexp_of_particle p =
95
  mk_len_regexp p.part_min p.part_max (regexp_of_term p.part_term)
96
97
98
99
    
and get_complex ct =
  try Hashtbl.find complex_memo ct.ct_uid
  with Not_found -> 
100
    let slot = mk_delayed () in
101
    let attrs = attr_uses ct.ct_attrs in
102
    let r = mk_prod (mk_type attrs) slot in
103
104
105
106
107
108
109
    Hashtbl.add complex_memo ct.ct_uid r;
    link slot (content ct.ct_content);
    r
      
and complex nil ct =
  let c = get_complex ct in
  if nil then 
110
111
    let (attrs,content) = get_ct c in
    let attrs = Types.Record.merge attrs xsi_nil_type in
112
    mk_or c (mk_type (Types.times (Types.cons attrs) Sequence.nil_node))
113
114
115
  else c
    
and content = function
116
117
  | CT_empty -> mk_type Sequence.nil_type
  | CT_simple st -> mk_type (simple_type st)
118
119
  | CT_model (particle, mixed) ->
      let regexp = regexp_of_particle particle in
120
      rexp_simplify ~mix:mixed regexp
121
122
123
	
    
and elt_decl elt =
124
  let atom_type = mk_type (Types.atom (Atoms.atom elt.elt_name)) in
125
  let content=complex_type_def elt.elt_nillable (Lazy.force elt.elt_typdef) in
126
  let content =
127
128
    match elt.elt_cstr with
      | Some (`Fixed (_,v)) ->
129
130
	  mk_and content (
	    mk_type (Types.times 
131
132
133
		     (Types.cons Types.any)
		     (Types.cons (Types.constant (Value.inv_const v)))))
      | _ -> content in
134
  mk_xml atom_type content
135

136
137
and complex_type_def nil = function
  | AnyType -> 
138
      mk_type (Types.times 
139
140
141
142
143
144
145
146
147
148
149
150
	       (Types.cons Types.empty_open_record)
	       (Types.cons xsd_any_type))
  | Simple st ->
      let nonnil =
	Types.times 
	  (Types.cons Types.empty_closed_record) 
	  (Types.cons (simple_type st))
      in
      let t =
	if nil then
	  Types.cup nonnil
	    (Types.times
151
	       (Types.cons xsi_nil_type)
152
153
	       (Types.cons Sequence.nil_type))
	else nonnil in
154
      mk_type t
155
156
  | Complex ct -> complex nil ct
      
157
let model_group g = rexp_simplify ~mix:false (regexp_of_model_group g)
158
  
159
160
let get_type d = internalize d; typ d

161
162
163
let type_def = function
  | AnyType -> xsd_any_type
  | Simple st -> simple_type st
164
  | Complex ct -> get_type (mk_xml (mk_type Types.any) (complex false ct))
165
166
167
168
169
170
let elt_decl x = get_type (elt_decl x)
let model_group x = get_type (model_group x.mg_def)
let attr_group ag = attr_uses ag.ag_def


let load_schema schema_name uri =
171
  let schema_name = schema_name ^ "." in
172
173
  let log_schema_component kind name cd_type =
    if not (Schema_builtin.is name) then begin
174
      Types.Print.register_global schema_name name cd_type;
175
      
176
177
178
(*      Format.fprintf Format.std_formatter "Registering schema %s: %a@." kind 
	Ns.QName.print name; *)
      
179
180
181
182
183
184
185
186
187
188
189
190
191
192
    end 
  in
  let env = ref Env.empty in
  let defs kind name cd_type v lst =
    List.iter
      (fun def ->
	 let name = name def in
	 let cd_type = cd_type def in
	 log_schema_component kind name cd_type;
	 env := Env.add (Ident.ident name) (cd_type, v def) !env
      ) lst
  in
  let schema = Schema_parser.schema_of_uri uri in
  defs "attribute group" (fun ag -> ag.ag_name) attr_group 
193
    (fun x -> VAttrGp x) schema.attribute_groups;
194
  defs "model group" (fun mg -> mg.mg_name) model_group 
195
196
197
198
199
    (fun x -> VModelGp x) schema.model_groups;
  defs "type" name_of_type_definition type_def 
    (fun x -> VType x) schema.types;
  defs "element" (fun e -> Atoms.V.value e.elt_name) elt_decl 
    (fun x -> VElem x) schema.elements;
200
  schema.targetNamespace, !env
201
202


203
204
let () = 
  Typer.load_schema := load_schema;