viewcvs.cgi/schema/schema_common.ml


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
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
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
exception XSI_validation_error of validation_context * string

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)

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"


1	abate	759
2			open Printf
3
4			open Schema_types
5
6			let no_facets = {
7			length = None;
8			minLength = None;
9			maxLength = None;
10			(* pattern = []; *)
11			enumeration = None;
12			whiteSpace = `Collapse, true;
13			maxInclusive = None;
14			maxExclusive = None;
15			minInclusive = None;
16			minExclusive = None;
17			(*
18			totalDigits = None;
19			fractionDigits = None;
20			*)
21			}
22
23			let name_of_element_declaration (_, name, _, _) = name
24			let name_of_simple_type_definition = function
25			\| Primitive name -> name
26			\| Derived (Some name, _, _, _) -> name
27			\| _ -> raise (Invalid_argument "anonymous simple type definition")
28			let name_of_complex_type_definition = function
29			\| _, Some name, _, _, _, _ -> name
30			\| _ -> raise (Invalid_argument "anonymous complex type definition")
31			let name_of_type_definition = function
32			\| AnyType -> "xsd:anyType"
33			\| Simple st -> name_of_simple_type_definition st
34			\| Complex ct -> name_of_complex_type_definition ct
35			let name_of_attribute_declaration (name, _, _) = name
36			let name_of_attribute_use (_, (name, _, _), _) = name
37	abate	784	let name_of_attribute_group_definition = fst
38			let name_of_model_group_definition = fst
39			let name_of_particle = function
40			\| (_, _, Elt elt_decl_ref) -> name_of_element_declaration !elt_decl_ref
41			\| _ -> assert false
42	abate	759	let variety_of_simple_type_definition = function
43			\| (Primitive name) as st -> Atomic st
44			\| Derived (_, variety, _, _) -> variety
45			let simple_type_of_type = function
46			\| Simple s -> s
47			\| _ -> raise (Invalid_argument "simple_type_of_type")
48			let complex_type_of_type = function
49			\| Complex c -> c
50			\| _ -> raise (Invalid_argument "complex_type_of_type")
51			let content_type_of_type = function
52			\| AnyType -> assert false
53			\| Complex (_, _, _, _, _, ct) -> ct
54			\| Simple st -> CT_simple st
55			let facets_of_simple_type_definition = function
56			\| Primitive _ -> no_facets
57			\| Derived (_, _, facets, _) -> facets
58
59			let iter_types schema f = List.iter f schema.types
60			let iter_attributes schema f = List.iter f schema.attributes
61			let iter_elements schema f = List.iter f schema.elements
62			let iter_attribute_groups schema f = List.iter f schema.attribute_groups
63			let iter_model_groups schema f = List.iter f schema.model_groups
64
65			exception XSD_validation_error of string
66	abate	784	exception XSI_validation_error of validation_context * string
67	abate	759
68			let regexp' s = Pcre.regexp ~flags:[`UTF8] s
69
70			let rec normalize_white_space =
71			let ws_RE = regexp' "[\t\r\n]" in
72			let spaces_RE = regexp' "[ ]+" in
73			let margins_RE = regexp' "^ (.*) $" in
74			fun handling s ->
75			match handling with
76			\| `Preserve -> s
77			\| `Replace -> Pcre.replace ~rex:ws_RE ~templ:" " s
78			\| `Collapse ->
79			let s' =
80			Pcre.replace ~rex:spaces_RE ~templ:" "
81			(normalize_white_space `Replace s)
82			in
83			Pcre.replace ~rex:margins_RE ~templ:"$1" s'
84
85			let anySimpleType = Primitive "xsd:anySimpleType"
86			let anyType = AnyType
87
88			let get_interval facets =
89			(* ASSUMPTION:
90			* not (facets.minInclusive = Some _ && facets.minExclusive = Some _)
91			* not (facets.maxInclusive = Some _ && facets.maxExclusive = Some _)
92			* Value.t is an integer! (no other intervals are actually supported
93			* by the CDuce type system)
94			*)
95			let min =
96			match facets.minInclusive, facets.minExclusive with
97			\| Some (Value.Integer i, _), None -> Some i
98			\| None, Some (Value.Integer i, _) -> Some (Intervals.V.succ i)
99			\| None, None -> None
100			\| _ -> assert false
101			in
102			let max =
103			match facets.maxInclusive, facets.maxExclusive with
104			\| Some (Value.Integer i, _), None -> Some i
105			\| None, Some (Value.Integer i, _) -> Some (Intervals.V.pred i)
106			\| None, None -> None
107			\| _ -> assert false
108			in
109			match min, max with
110			\| Some min, Some max -> Intervals.bounded min max
111			\| Some min, None -> Intervals.right min
112			\| None, Some max -> Intervals.left max
113			\| None, None -> Intervals.any
114
115			let print_simple_type fmt = function
116			\| Primitive name -> Format.fprintf fmt "%s" name
117			\| Derived (Some name, _, _, _) -> Format.fprintf fmt "%s'" name
118			\| Derived (None, _, _, _) -> Format.fprintf fmt "unnamed'"
119			let print_complex_type fmt = function
120			\| (id, Some name, _, _, _, _) -> Format.fprintf fmt "%d:%s" id name
121			\| (id, None, _, _, _, _) -> Format.fprintf fmt "%d:unnamed'" id
122			let print_type fmt = function
123			\| AnyType -> Format.fprintf fmt "xsd:anyType"
124			\| Simple t -> Format.fprintf fmt "S:%a" print_simple_type t
125			\| Complex t -> Format.fprintf fmt "C:%a" print_complex_type t
126			let print_attribute fmt (name, t, _) =
127			Format.fprintf fmt "@@%s:%a" name print_simple_type t
128			let print_element fmt (id, name, _, _) = Format.fprintf fmt "E:%d:<%s>" id name
129			let print_attributes fmt = List.iter (Format.fprintf fmt "%a" print_attribute)
130			let print_attribute_group fmt (name, _) = Format.fprintf fmt "{agroup:%s}" name
131			let print_model_group fmt (name, _) = Format.fprintf fmt "{mgroup:%s}" name
132			let print_schema fmt schema =
133			let defined_types = (* filter out built-in types *)
134			List.filter
135			(fun def -> not (Schema_xml.has_xsd_prefix (name_of_type_definition def)))
136			schema.types
137			in
138			if defined_types <> [] then begin
139			Format.fprintf fmt "Types: ";
140			List.iter (fun c -> print_type fmt c; Format.fprintf fmt " ")
141			defined_types;
142			Format.fprintf fmt "\n"
143			end;
144			if schema.attributes <> [] then begin
145			Format.fprintf fmt "Attributes: ";
146			List.iter (fun c -> print_attribute fmt c; Format.fprintf fmt " ")
147			schema.attributes;
148			Format.fprintf fmt "\n"
149			end;
150			if schema.elements <> [] then begin
151			Format.fprintf fmt "Elements: ";
152			List.iter (fun c -> print_element fmt c; Format.fprintf fmt " ")
153			schema.elements;
154			Format.fprintf fmt "\n"
155			end;
156			if schema.attribute_groups <> [] then begin
157			Format.fprintf fmt "Attribute groups: ";
158			List.iter (fun c -> print_attribute_group fmt c; Format.fprintf fmt " ")
159			schema.attribute_groups;
160			Format.fprintf fmt "\n"
161			end;
162			if schema.model_groups <> [] then begin
163			Format.fprintf fmt "Model groups: ";
164			List.iter (fun c -> print_model_group fmt c; Format.fprintf fmt " ")
165			schema.model_groups;
166			Format.fprintf fmt "\n"
167			end
168
169			(** naive implementation: doesn't follow XML Schema constraints on facets
170			* merging. Here all new facets override old ones *)
171			let merge_facets old_facets new_facets =
172			let maxInclusive, maxExclusive =
173			match new_facets.maxInclusive, new_facets.maxExclusive with
174			\| None, None -> old_facets.maxInclusive, old_facets.maxExclusive
175			\| Some _, Some _ -> assert false
176			\| v -> v
177			in
178			let minInclusive, minExclusive =
179			match new_facets.minInclusive, new_facets.minExclusive with
180			\| None, None -> old_facets.minInclusive, old_facets.minExclusive
181			\| Some _, Some _ -> assert false
182			\| v -> v
183			in
184			{ old_facets with
185			length =
186			(match new_facets.length with
187			\| None -> old_facets.length
188			\| v -> v);
189			minLength =
190			(match new_facets.minLength with
191			\| None -> old_facets.minLength
192			\| v -> v);
193			maxLength =
194			(match new_facets.maxLength with
195			\| None -> old_facets.maxLength
196			\| v -> v);
197			enumeration =
198			(match new_facets.enumeration with
199			\| None -> old_facets.enumeration
200			\| v -> v);
201			whiteSpace = new_facets.whiteSpace;
202			maxInclusive = maxInclusive;
203			maxExclusive = maxExclusive;
204			minInclusive = minInclusive;
205			minExclusive = minExclusive;
206			}
207
208			let restrict base new_facets new_name =
209			let variety = variety_of_simple_type_definition base in
210			let facets =
211			merge_facets (facets_of_simple_type_definition base) new_facets
212			in
213			Derived (new_name, variety, facets, base)
214
215	abate	784	let get_type name schema =
216			List.find
217			(fun x ->
218			try
219			name_of_type_definition x = name
220			with Invalid_argument _ -> false)
221			schema.types
222			let get_attribute name schema =
223			List.find
224			(fun x ->
225			try
226			name_of_attribute_declaration x = name
227			with Invalid_argument _ -> false)
228			schema.attributes
229			let get_element name schema =
230			List.find
231			(fun x ->
232			try
233			name_of_element_declaration x = name
234			with Invalid_argument _ -> false)
235			schema.elements
236			let get_attribute_group name schema =
237			List.find
238			(fun x ->
239			try
240			name_of_attribute_group_definition x = name
241			with Invalid_argument _ -> false)
242			schema.attribute_groups
243			let get_model_group name schema =
244			List.find
245			(fun x ->
246			try
247			name_of_model_group_definition x = name
248			with Invalid_argument _ -> false)
249			schema.model_groups
250
251			(* policy for unqualified schema component resolution. The order should
252			* be consistent with Typer.find_schema_descr *)
253			let get_component kind name schema =
254			let rec tries = function
255			\| [] -> raise Not_found
256			\| hd :: tl -> (try hd () with Not_found -> tries tl)
257			in
258			let elt () = Element (get_element name schema) in
259			let typ () = Type (get_type name schema) in
260			let att () = Attribute (get_attribute name schema) in
261			let att_group () = Attribute_group (get_attribute_group name schema) in
262			let mod_group () = Model_group (get_model_group name schema) in
263			match kind with
264			\| Some `Element -> elt ()
265			\| Some `Type -> typ ()
266			\| Some `Attribute -> att ()
267			\| Some `Attribute_group -> att_group ()
268			\| Some `Model_group -> mod_group ()
269			\| None -> tries [ elt; typ; att; att_group; mod_group ]
270
271			let string_of_component_kind (kind: component_kind) =
272			match kind with
273			\| Some `Type -> "type"
274			\| Some `Element -> "element"
275			\| Some `Attribute -> "attribute"
276			\| Some `Attribute_group -> "attribute group"
277			\| Some `Model_group -> "model group"
278			\| None -> "component"
279
280