schema_common.ml 9.29 KB
Newer Older
1
2
3
4
5
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
34
35
36

open Printf

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
  | AnyType -> "xsd:anyType"
  | 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
37
38
39
40
41
let name_of_attribute_group_definition = fst
let name_of_model_group_definition = fst
let name_of_particle = function
  | (_, _, Elt elt_decl_ref) -> name_of_element_declaration !elt_decl_ref
  | _ -> assert false
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
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
66
exception XSI_validation_error of validation_context * string
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
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
133
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
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

let regexp' s = Pcre.regexp ~flags:[`UTF8] s

let rec normalize_white_space =
  let ws_RE = regexp' "[\t\r\n]" in
  let spaces_RE = regexp' "[ ]+" in
  let margins_RE = regexp' "^ (.*) $" in
  fun handling s ->
  match handling with
  | `Preserve -> s
  | `Replace -> Pcre.replace ~rex:ws_RE ~templ:" " s
  | `Collapse ->
      let s' =
        Pcre.replace ~rex:spaces_RE ~templ:" "
          (normalize_white_space `Replace s)
      in
      Pcre.replace ~rex:margins_RE ~templ:"$1" s'

let anySimpleType = Primitive "xsd:anySimpleType"
let anyType = AnyType

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
  | Primitive name -> Format.fprintf fmt "%s" name
  | Derived (Some name, _, _, _) -> Format.fprintf fmt "%s'" name
  | Derived (None, _, _, _) -> Format.fprintf fmt "unnamed'"
let print_complex_type fmt = function
  | (id, Some name, _, _, _, _) -> Format.fprintf fmt "%d:%s" id name
  | (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, _) =
  Format.fprintf fmt "@@%s:%a" name print_simple_type t
let print_element fmt (id, name, _, _) = Format.fprintf fmt "E:%d:<%s>" id name
let print_attributes fmt = List.iter (Format.fprintf fmt "%a" print_attribute)
let print_attribute_group fmt (name, _) = Format.fprintf fmt "{agroup:%s}" name
let print_model_group fmt (name, _) = Format.fprintf fmt "{mgroup:%s}" name
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)

215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
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
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"