schema_common.ml 6.53 KB
Newer Older
1
2
open Printf

3
open Encodings
4
open Schema_pcre
5
6
open Schema_types

7
8
let xsd = Schema_xml.xsd

9
10
11
12
13
14
15
16
17
18
19
20
let no_facets = {
  length = None;
  minLength = None;
  maxLength = None;
  enumeration = None;
  whiteSpace = `Collapse, true;
  maxInclusive = None;
  maxExclusive = None;
  minInclusive = None;
  minExclusive = None;
}

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
(** 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;
  }

60
let name_of_simple_type_definition = function
61
  | { st_name = Some name } -> name
62
63
  | _ -> raise (Invalid_argument "anonymous simple type definition")
let name_of_complex_type_definition = function
64
  | { ct_name = Some name } -> name
65
66
  | _ -> raise (Invalid_argument "anonymous complex type definition")
let name_of_type_definition = function
67
  | AnyType -> (xsd, Utf8.mk "anyType")
68
69
  | Simple st -> name_of_simple_type_definition st
  | Complex ct -> name_of_complex_type_definition ct
70

71
72
73
74
75
76
77
78
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
79
  | Complex { ct_content = ct } -> ct
80
  | Simple st -> CT_simple st
81
82

exception XSD_validation_error of string
83
exception XSI_validation_error of string
84
85

let rec normalize_white_space =
86
87
88
  let ws_RE = pcre_regexp "[\t\r\n]" in
  let spaces_RE = pcre_regexp "[ ]+" in
  let margins_RE = pcre_regexp "^ (.*) $" in
89
90
91
  fun handling s ->
  match handling with
  | `Preserve -> s
92
  | `Replace -> pcre_replace ~rex:ws_RE ~templ:(Utf8.mk " ") s
93
94
  | `Collapse ->
      let s' =
95
        pcre_replace ~rex:spaces_RE ~templ:(Utf8.mk " ")
96
97
          (normalize_white_space `Replace s)
      in
98
      pcre_replace ~rex:margins_RE ~templ:(Utf8.mk "$1") s'
99

100

101
102
103
104
105
106
let first_of_wildcard_constraint = function
  | WAny -> Atoms.any
  | WNot ns -> Atoms.diff Atoms.any (Atoms.any_in_ns ns)
  | WOne l -> 
      List.fold_left (fun acc ns -> Atoms.cup acc (Atoms.any_in_ns ns))
	Atoms.empty l
107
108
let first_of_model_group = function
  | All particles | Choice particles ->
109
      List.fold_left (fun acc p -> Atoms.cup acc p.part_first)
110
	Atoms.empty particles
111
112
  | Sequence particles ->
      let rec aux = function
113
114
        | hd::tl when hd.part_nullable -> Atoms.cup hd.part_first (aux tl)
        | hd::tl -> hd.part_first
115
        | [] -> Atoms.empty
116
117
      in
      aux particles
118
119

let nullable_of_model_group = function
120
121
122
  | All particles | Sequence particles -> 
      List.for_all (fun p -> p.part_nullable) particles
  | Choice particles -> List.exists (fun p -> p.part_nullable) particles
123
124
125
126
127
128
129
130
131
132

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
133
            what has still to be visited *)
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
    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
165
166
    | _ -> 
	failwith "Non XML element"
167
168
169
170
171
172
173
174
175
176
  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

177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195

let simple_restrict name base new_facets =
  { st_name = name;
    st_variety = base.st_variety;
    st_facets = merge_facets base.st_facets new_facets;
    st_base = Some base }

let simple_list name item =
  { st_name = name;
    st_variety = List item;
    st_facets = no_facets;
    st_base = None }

let simple_union name members =
  { st_name = name;
    st_variety = Union members;
    st_facets = no_facets;
    st_base = None }

196
197
198
199
200

let xsi_nil_qname = (Schema_xml.xsi,Utf8.mk "nil")
let xsi_nil_atom = Atoms.V.of_qname xsi_nil_qname
let xsi_nil_type = Types.atom (Atoms.atom xsi_nil_atom)
let xsi_nil_label = Ident.LabelPool.mk xsi_nil_qname
201
202
203

let merge_attribute_uses l =
  List.fold_left (fun (l,a) (l',a') -> (l @ l', a || a')) ([],false) l