schema_common.ml 6.33 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
(** 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
36
  {   length =
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
        (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;
  }

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

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

exception XSD_validation_error of string
82
exception XSI_validation_error of string
83
84

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

99

100
101
102
103
104
105
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
106
107
let first_of_model_group = function
  | All particles | Choice particles ->
108
      List.fold_left (fun acc p -> Atoms.cup acc p.part_first)
109
	Atoms.empty particles
110
111
  | Sequence particles ->
      let rec aux = function
112
113
        | hd::tl when hd.part_nullable -> Atoms.cup hd.part_first (aux tl)
        | hd::tl -> hd.part_first
114
        | [] -> Atoms.empty
115
116
      in
      aux particles
117
118

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

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
132
            what has still to be visited *)
133
    match !stack with
134
135
    | (Fully ((Value.Xml (Value.Atom atom, attrs, _))
       |(Value.XmlNs (Value.Atom atom, attrs, _, _)) as v)) :: tl ->
136
137
138
139
140
141
142
        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
143
            | (Value.Xml _ | Value.XmlNs _) as v -> push (Fully v) children
144
145
146
147
148
149
150
151
            | 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);
152
        Some (E_start_tag atom)
153
    | Half _ :: tl ->
154
        stack := tl;
155
        Some E_end_tag
156
157
158
159
160
161
162
    | (Backlog ev) :: tl -> (* consume backlog *)
        stack := tl;
        Some ev
    | (Other v) :: tl ->
        stack := tl;
        Some (E_char_data v)
    | [] -> None
163
    | _ -> Value.failwith'  "Validate: non XML element"
164
165
166
167
  in
  Stream.from f

let string_of_event = function
168
  | E_start_tag t -> sprintf "<%s>" (Atoms.V.to_string t)
169
  | E_end_tag -> sprintf "</>"
170
  | E_attribute (qname, value) ->
171
      sprintf "@%s=%s" (Ns.Label.string_of_attr qname) (Utf8.to_string value)
172
173
  | E_char_data value -> Utf8.to_string value

174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192

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 }

193

194
let xsi_nil_atom = Atoms.V.mk (Schema_xml.xsi, Utf8.mk "nil")
195
let xsi_nil_type = Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.atom xsi_nil_atom)))
196
197
let xsi_nil_label = Ns.Label.mk (Schema_xml.xsi, Utf8.mk "nil")

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