schema_common.ml 12.9 KB
Newer Older
1
2
3

open Printf

4
5
open Encodings
open Encodings.Utf8.Pcre
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
open Schema_types

let no_facets = {
  length = None;
  minLength = None;
  maxLength = None;
(*   pattern = []; *)
  enumeration = None;
  whiteSpace = `Collapse, true;
  maxInclusive = None;
  maxExclusive = None;
  minInclusive = None;
  minExclusive = None;
(*
  totalDigits = None;
  fractionDigits = None;
*)
}

let name_of_element_declaration (_, name, _, _) = name
let name_of_simple_type_definition = function
  | Primitive name -> name
  | Derived (Some name, _, _, _) -> name
  | _ -> raise (Invalid_argument "anonymous simple type definition")
let name_of_complex_type_definition = function
  | _, Some name, _, _, _, _ -> name
  | _ -> raise (Invalid_argument "anonymous complex type definition")
let name_of_type_definition = function
34
  | AnyType -> Encodings.Utf8.mk "xsd:anyType"
35
36
37
38
  | Simple st -> name_of_simple_type_definition st
  | Complex ct -> name_of_complex_type_definition ct
let name_of_attribute_declaration (name, _, _) = name
let name_of_attribute_use (_, (name, _, _), _) = name
39
40
41
let name_of_attribute_group_definition = fst
let name_of_model_group_definition = fst
let name_of_particle = function
42
  | (_, _, Elt elt_decl_ref, _) -> name_of_element_declaration !elt_decl_ref
43
  | _ -> assert false
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
let variety_of_simple_type_definition = function
  | (Primitive name) as st -> Atomic st
  | Derived (_, variety, _, _) -> variety
let simple_type_of_type = function
  | Simple s -> s
  | _ -> raise (Invalid_argument "simple_type_of_type")
let complex_type_of_type = function
  | Complex c -> c
  | _ -> raise (Invalid_argument "complex_type_of_type")
let content_type_of_type = function
  | AnyType -> assert false
  | Complex (_, _, _, _, _, ct) -> ct
  | Simple st -> CT_simple st
let facets_of_simple_type_definition = function
  | Primitive _ -> no_facets
  | Derived (_, _, facets, _) -> facets

let iter_types schema f = List.iter f schema.types
let iter_attributes schema f = List.iter f schema.attributes
let iter_elements schema f = List.iter f schema.elements
let iter_attribute_groups schema f = List.iter f schema.attribute_groups
let iter_model_groups schema f = List.iter f schema.model_groups

exception XSD_validation_error of string
68
exception XSI_validation_error of string
69
70

let rec normalize_white_space =
71
72
73
  let ws_RE = pcre_regexp "[\t\r\n]" in
  let spaces_RE = pcre_regexp "[ ]+" in
  let margins_RE = pcre_regexp "^ (.*) $" in
74
75
76
  fun handling s ->
  match handling with
  | `Preserve -> s
77
  | `Replace -> pcre_replace ~rex:ws_RE ~templ:(Utf8.mk " ") s
78
79
  | `Collapse ->
      let s' =
80
        pcre_replace ~rex:spaces_RE ~templ:(Utf8.mk " ")
81
82
          (normalize_white_space `Replace s)
      in
83
      pcre_replace ~rex:margins_RE ~templ:(Utf8.mk "$1") s'
84

85
let anySimpleType = Primitive (Encodings.Utf8.mk "xsd:anySimpleType")
86
87
let anyType = AnyType

88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
let first_of_particle (_, _, _, first) = first
let nullable p = List.mem None (first_of_particle p)
let first_of_model_group = function
  | All particles | Choice particles ->
      List.concat (List.map first_of_particle particles)
  | Sequence particles ->
      let rec aux = function
        | hd :: tl when nullable hd -> (first_of_particle hd) @ (aux tl)
        | hd :: tl -> first_of_particle hd
        | [] -> []
      in
      aux particles
let rec is_in_first tag = function
  | [] -> false
  | Some tag' :: rest when Utf8.equal tag' tag -> true
  | _ :: rest -> is_in_first tag rest

105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
let get_interval facets =
  (* ASSUMPTION:
   *  not (facets.minInclusive = Some _ && facets.minExclusive = Some _)
   *  not (facets.maxInclusive = Some _ && facets.maxExclusive = Some _)
   *  Value.t is an integer! (no other intervals are actually supported
   *  by the CDuce type system)
  *)
  let min =
    match facets.minInclusive, facets.minExclusive with
    | Some (Value.Integer i, _), None -> Some i
    | None, Some (Value.Integer i, _) -> Some (Intervals.V.succ i)
    | None, None -> None
    | _ -> assert false
  in
  let max =
    match facets.maxInclusive, facets.maxExclusive with
    | Some (Value.Integer i, _), None -> Some i
    | None, Some (Value.Integer i, _) -> Some (Intervals.V.pred i)
    | None, None -> None
    | _ -> assert false
  in
  match min, max with
  | Some min, Some max -> Intervals.bounded min max
  | Some min, None -> Intervals.right min
  | None, Some max -> Intervals.left max
  | None, None -> Intervals.any

let print_simple_type fmt = function
133
134
135
  | Primitive name -> Format.fprintf fmt "%a" Encodings.Utf8.dump name
  | Derived (Some name, _, _, _) ->
      Format.fprintf fmt "%a'" Encodings.Utf8.dump name
136
137
  | Derived (None, _, _, _) -> Format.fprintf fmt "unnamed'"
let print_complex_type fmt = function
138
139
  | (id, Some name, _, _, _, _) ->
      Format.fprintf fmt "%d:%a" id Encodings.Utf8.dump name
140
141
142
143
144
145
  | (id, None, _, _, _, _) -> Format.fprintf fmt "%d:unnamed'" id
let print_type fmt = function
  | AnyType -> Format.fprintf fmt "xsd:anyType"
  | Simple t -> Format.fprintf fmt "S:%a" print_simple_type t
  | Complex t -> Format.fprintf fmt "C:%a" print_complex_type t
let print_attribute fmt (name, t, _) =
146
147
148
  Format.fprintf fmt "@@%a:%a" Utf8.dump name print_simple_type t
let print_element fmt (id, name, _, _) =
  Format.fprintf fmt "E:%d:<%a>" id Utf8.dump name
149
let print_attributes fmt = List.iter (Format.fprintf fmt "%a" print_attribute)
150
151
152
153
let print_attribute_group fmt (name, _) =
  Format.fprintf fmt "{agroup:%a}" Utf8.dump name
let print_model_group fmt (name, _) =
  Format.fprintf fmt "{mgroup:%a}" Utf8.dump name
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
let print_schema fmt schema =
  let defined_types = (* filter out built-in types *)
    List.filter
      (fun def -> not (Schema_xml.has_xsd_prefix (name_of_type_definition def)))
      schema.types
  in
  if defined_types <> [] then begin
    Format.fprintf fmt "Types: ";
    List.iter (fun c -> print_type fmt c; Format.fprintf fmt " ")
      defined_types;
    Format.fprintf fmt "\n"
  end;
  if schema.attributes <> [] then begin
    Format.fprintf fmt "Attributes: ";
    List.iter (fun c -> print_attribute fmt c; Format.fprintf fmt " ")
      schema.attributes;
    Format.fprintf fmt "\n"
  end;
  if schema.elements <> [] then begin
    Format.fprintf fmt "Elements: ";
    List.iter (fun c -> print_element fmt c; Format.fprintf fmt " ")
      schema.elements;
    Format.fprintf fmt "\n"
  end;
  if schema.attribute_groups <> [] then begin
    Format.fprintf fmt "Attribute groups: ";
    List.iter (fun c -> print_attribute_group fmt c; Format.fprintf fmt " ")
      schema.attribute_groups;
    Format.fprintf fmt "\n"
  end;
  if schema.model_groups <> [] then begin
    Format.fprintf fmt "Model groups: ";
    List.iter (fun c -> print_model_group fmt c; Format.fprintf fmt " ")
      schema.model_groups;
    Format.fprintf fmt "\n"
  end

(** naive implementation: doesn't follow XML Schema constraints on facets
 * merging. Here all new facets override old ones *)
let merge_facets old_facets new_facets =
  let maxInclusive, maxExclusive =
    match new_facets.maxInclusive, new_facets.maxExclusive with
    | None, None -> old_facets.maxInclusive, old_facets.maxExclusive
    | Some _, Some _ -> assert false
    | v -> v
  in
  let minInclusive, minExclusive =
    match new_facets.minInclusive, new_facets.minExclusive with
    | None, None -> old_facets.minInclusive, old_facets.minExclusive
    | Some _, Some _ -> assert false
    | v -> v
  in
  { old_facets with
      length =
        (match new_facets.length with
        | None -> old_facets.length
        | v -> v);
      minLength =
        (match new_facets.minLength with
        | None -> old_facets.minLength
        | v -> v);
      maxLength =
        (match new_facets.maxLength with
        | None -> old_facets.maxLength
        | v -> v);
      enumeration =
        (match new_facets.enumeration with
        | None -> old_facets.enumeration
        | v -> v);
      whiteSpace = new_facets.whiteSpace;
      maxInclusive = maxInclusive;
      maxExclusive = maxExclusive;
      minInclusive = minInclusive;
      minExclusive = minExclusive;
  }

let restrict base new_facets new_name =
  let variety = variety_of_simple_type_definition base in
  let facets =
    merge_facets (facets_of_simple_type_definition base) new_facets
  in
  Derived (new_name, variety, facets, base)

237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
let get_type name schema =
  List.find
    (fun x ->
      try
        name_of_type_definition x = name
      with Invalid_argument _ -> false)
    schema.types
let get_attribute name schema =
  List.find
    (fun x ->
      try
        name_of_attribute_declaration x = name
      with Invalid_argument _ -> false)
    schema.attributes
let get_element name schema =
  List.find
    (fun x ->
      try
        name_of_element_declaration x = name
      with Invalid_argument _ -> false)
    schema.elements
let get_attribute_group name schema =
  List.find
    (fun x ->
      try
        name_of_attribute_group_definition x = name
      with Invalid_argument _ -> false)
    schema.attribute_groups
let get_model_group name schema =
  List.find
    (fun x ->
      try
        name_of_model_group_definition x = name
      with Invalid_argument _ -> false)
    schema.model_groups

  (* policy for unqualified schema component resolution. The order should
   * be consistent with Typer.find_schema_descr *)
let get_component kind name schema =
  let rec tries = function
    | [] -> raise Not_found
    | hd :: tl -> (try hd () with Not_found -> tries tl)
  in
  let elt () = Element (get_element name schema) in
  let typ () = Type (get_type name schema) in
  let att () = Attribute (get_attribute name schema) in
  let att_group () = Attribute_group (get_attribute_group name schema) in
  let mod_group () = Model_group (get_model_group name schema) in
  match kind with
  | Some `Element -> elt ()
  | Some `Type -> typ ()
  | Some `Attribute -> att ()
  | Some `Attribute_group -> att_group ()
  | Some `Model_group -> mod_group ()
  | None -> tries [ elt; typ; att; att_group; mod_group ]

let string_of_component_kind (kind: component_kind) =
  match kind with
  | Some `Type -> "type"
  | Some `Element -> "element"
  | Some `Attribute -> "attribute"
  | Some `Attribute_group -> "attribute group"
  | Some `Model_group -> "model group"
  | None -> "component"

302
303
304
305
306
307
308
309
310
311
312
(** Events *)

type to_be_visited =
  | Fully of Value.t  (* xml values still to be visited *)
  | Half of Value.t   (* xml values half visited (i.e. E_start_tag generated) *)
  | Other of Encodings.Utf8.t (* other values *)
  | Backlog of event  (* old events not yet delivered *)

let stream_of_value v =
  let stack = ref [Fully v] in
  let f _ = (* lazy visit of a tree of CDuce XML values, stack keeps track of
313
            what has still to be visited *)
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
    match !stack with
    | (Fully ((Value.Xml (Value.Atom atom, attrs, _)) as v)) :: tl ->
        stack := (Half v) :: tl;
        let children = ref [] in  (* TODO inefficient *)
        let push v s = (s := v :: !s) in
        Value.iter_xml
          (fun pcdata -> push (Other pcdata) children)
          (fun v ->
            match v with
            | (Value.Xml (_, _, _)) as v -> push (Fully v) children
            | v -> raise (Invalid_argument "Schema_events.stream_of_value"))
          v;
        stack := (List.rev !children) @ !stack;
        List.iter (* push attributes as events on the stack *)
          (fun (qname, v) ->
            push (Backlog (E_attribute (qname, fst (Value.get_string_utf8 v))))
              stack)
          (Value.get_fields attrs);
        Some (E_start_tag (Atoms.V.value atom))
    | (Half (Value.Xml (Value.Atom atom, _, _))) :: tl ->
        stack := tl;
        Some (E_end_tag (Atoms.V.value atom))
    | (Fully (Value.Xml (_, _, _)))::_ | (Half (Value.Xml (_, _, _)))::_ ->
        failwith "Schema_xml.pxp_stream_of_value: non-atom-tag xml value"
    | (Backlog ev) :: tl -> (* consume backlog *)
        stack := tl;
        Some ev
    | (Other v) :: tl ->
        stack := tl;
        Some (E_char_data v)
    | [] -> None
    | _ -> assert false
  in
  Stream.from f

let string_of_event = function
  | E_start_tag qname -> sprintf "<%s>" (Ns.QName.to_string qname)
  | E_end_tag qname -> sprintf "</%s>" (Ns.QName.to_string qname)
  | E_attribute (qname, value) ->
      sprintf "@%s=%s" (Ns.QName.to_string qname) (Utf8.to_string value)
  | E_char_data value -> Utf8.to_string value

(*
let test v =
  let s = stream_of_value v in
  let rec aux () =
    (match Stream.peek s with
    | None -> ()
    | Some (E_start_tag qname) ->
        Ns.QName.print Format.std_formatter qname
    | Some (E_end_tag qname) ->
        Format.fprintf Format.std_formatter "/";
        Ns.QName.print Format.std_formatter qname
    | Some (E_attribute (qname, value)) ->
        Format.fprintf Format.std_formatter "@@";
        Ns.QName.print Format.std_formatter qname;
        Format.fprintf Format.std_formatter " ";
        Encodings.Utf8.print Format.std_formatter value
    | Some (E_char_data value) ->
        Encodings.Utf8.print Format.std_formatter value);
    Format.fprintf Format.std_formatter "\n";
    (match Stream.peek s with
    | None -> ()
    | _ ->
      Stream.junk s;
      aux ())
  in
  aux ()
*)
383