viewcvs.cgi/schema/schema_common.ml


open Printf

open Encodings
open Schema_pcre
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 elt = elt.elt_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
  | { ct_name = Some name } -> name
  | _ -> raise (Invalid_argument "anonymous complex type definition")
let name_of_type_definition = function
  | AnyType -> Encodings.Utf8.mk "xsd:anyType"
  | Simple st -> name_of_simple_type_definition st
  | Complex ct -> name_of_complex_type_definition ct
let name_of_attribute_declaration a = a.attr_name
let name_of_attribute_use { attr_decl = { attr_name = name } } = name
let name_of_attribute_group_definition ag = ag.ag_name
let name_of_model_group_definition mg = mg.mg_name
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_content = 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 string

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

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

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

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 "%a" Encodings.Utf8.dump name
  | Derived (Some name, _, _, _) ->
      Format.fprintf fmt "%a'" Encodings.Utf8.dump name
  | Derived (None, _, _, _) -> Format.fprintf fmt "unnamed'"
let print_complex_type fmt = function
  | { ct_uid = id; ct_name = Some name } ->
      Format.fprintf fmt "%d:%a" id Encodings.Utf8.dump name
  | { ct_uid = id } -> 
      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 { attr_name = name; attr_typdef = t } =
  Format.fprintf fmt "@@%a:%a" Utf8.dump name print_simple_type t
let print_element fmt { elt_uid = id; elt_name = name } =
  Format.fprintf fmt "E:%d:<%a>" id Utf8.dump name
let print_attributes fmt = List.iter (Format.fprintf fmt "%a" print_attribute)
let print_attribute_group fmt ag =
  Format.fprintf fmt "{agroup:%a}" Utf8.dump ag.ag_name
let print_model_group fmt mg =
  Format.fprintf fmt "{mgroup:%a}" Utf8.dump mg.mg_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"

(** 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
            what has still to be visited *)
    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
    | _ -> 
        failwith "Non XML element"
  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 ()
*)

1	abate	759
2			open Printf
3
4	abate	812	open Encodings
5	abate	1440	open Schema_pcre
6	abate	759	open Schema_types
7
8			let no_facets = {
9			length = None;
10			minLength = None;
11			maxLength = None;
12			(* pattern = []; *)
13			enumeration = None;
14			whiteSpace = `Collapse, true;
15			maxInclusive = None;
16			maxExclusive = None;
17			minInclusive = None;
18			minExclusive = None;
19			(*
20			totalDigits = None;
21			fractionDigits = None;
22			*)
23			}
24
25	abate	1294	let name_of_element_declaration elt = elt.elt_name
26	abate	759	let name_of_simple_type_definition = function
27			\| Primitive name -> name
28			\| Derived (Some name, _, _, _) -> name
29			\| _ -> raise (Invalid_argument "anonymous simple type definition")
30			let name_of_complex_type_definition = function
31	abate	1294	\| { ct_name = Some name } -> name
32	abate	759	\| _ -> raise (Invalid_argument "anonymous complex type definition")
33			let name_of_type_definition = function
34	abate	812	\| AnyType -> Encodings.Utf8.mk "xsd:anyType"
35	abate	759	\| Simple st -> name_of_simple_type_definition st
36			\| Complex ct -> name_of_complex_type_definition ct
37	abate	1294	let name_of_attribute_declaration a = a.attr_name
38			let name_of_attribute_use { attr_decl = { attr_name = name } } = name
39			let name_of_attribute_group_definition ag = ag.ag_name
40			let name_of_model_group_definition mg = mg.mg_name
41	abate	784	let name_of_particle = function
42	abate	844	\| (_, _, Elt elt_decl_ref, _) -> name_of_element_declaration !elt_decl_ref
43	abate	784	\| _ -> assert false
44	abate	759	let variety_of_simple_type_definition = function
45			\| (Primitive name) as st -> Atomic st
46			\| Derived (_, variety, _, _) -> variety
47			let simple_type_of_type = function
48			\| Simple s -> s
49			\| _ -> raise (Invalid_argument "simple_type_of_type")
50			let complex_type_of_type = function
51			\| Complex c -> c
52			\| _ -> raise (Invalid_argument "complex_type_of_type")
53			let content_type_of_type = function
54			\| AnyType -> assert false
55	abate	1294	\| Complex { ct_content = ct } -> ct
56	abate	759	\| Simple st -> CT_simple st
57			let facets_of_simple_type_definition = function
58			\| Primitive _ -> no_facets
59			\| Derived (_, _, facets, _) -> facets
60
61			let iter_types schema f = List.iter f schema.types
62			let iter_attributes schema f = List.iter f schema.attributes
63			let iter_elements schema f = List.iter f schema.elements
64			let iter_attribute_groups schema f = List.iter f schema.attribute_groups
65			let iter_model_groups schema f = List.iter f schema.model_groups
66
67			exception XSD_validation_error of string
68	abate	812	exception XSI_validation_error of string
69	abate	759
70			let rec normalize_white_space =
71	abate	812	let ws_RE = pcre_regexp "[\t\r\n]" in
72			let spaces_RE = pcre_regexp "[ ]+" in
73			let margins_RE = pcre_regexp "^ (.*) $" in
74	abate	759	fun handling s ->
75			match handling with
76			\| `Preserve -> s
77	abate	812	\| `Replace -> pcre_replace ~rex:ws_RE ~templ:(Utf8.mk " ") s
78	abate	759	\| `Collapse ->
79			let s' =
80	abate	812	pcre_replace ~rex:spaces_RE ~templ:(Utf8.mk " ")
81	abate	759	(normalize_white_space `Replace s)
82			in
83	abate	812	pcre_replace ~rex:margins_RE ~templ:(Utf8.mk "$1") s'
84	abate	759
85	abate	812	let anySimpleType = Primitive (Encodings.Utf8.mk "xsd:anySimpleType")
86	abate	759	let anyType = AnyType
87
88	abate	844	let first_of_particle (_, _, _, first) = first
89			let nullable p = List.mem None (first_of_particle p)
90			let first_of_model_group = function
91			\| All particles \| Choice particles ->
92			List.concat (List.map first_of_particle particles)
93			\| Sequence particles ->
94			let rec aux = function
95			\| hd :: tl when nullable hd -> (first_of_particle hd) @ (aux tl)
96			\| hd :: tl -> first_of_particle hd
97			\| [] -> []
98			in
99			aux particles
100			let rec is_in_first tag = function
101			\| [] -> false
102			\| Some tag' :: rest when Utf8.equal tag' tag -> true
103			\| _ :: rest -> is_in_first tag rest
104
105	abate	759	let get_interval facets =
106			(* ASSUMPTION:
107			* not (facets.minInclusive = Some _ && facets.minExclusive = Some _)
108			* not (facets.maxInclusive = Some _ && facets.maxExclusive = Some _)
109			* Value.t is an integer! (no other intervals are actually supported
110			* by the CDuce type system)
111			*)
112			let min =
113			match facets.minInclusive, facets.minExclusive with
114			\| Some (Value.Integer i, _), None -> Some i
115			\| None, Some (Value.Integer i, _) -> Some (Intervals.V.succ i)
116			\| None, None -> None
117			\| _ -> assert false
118			in
119			let max =
120			match facets.maxInclusive, facets.maxExclusive with
121			\| Some (Value.Integer i, _), None -> Some i
122			\| None, Some (Value.Integer i, _) -> Some (Intervals.V.pred i)
123			\| None, None -> None
124			\| _ -> assert false
125			in
126			match min, max with
127			\| Some min, Some max -> Intervals.bounded min max
128			\| Some min, None -> Intervals.right min
129			\| None, Some max -> Intervals.left max
130			\| None, None -> Intervals.any
131
132			let print_simple_type fmt = function
133	abate	812	\| Primitive name -> Format.fprintf fmt "%a" Encodings.Utf8.dump name
134			\| Derived (Some name, _, _, _) ->
135			Format.fprintf fmt "%a'" Encodings.Utf8.dump name
136	abate	759	\| Derived (None, _, _, _) -> Format.fprintf fmt "unnamed'"
137			let print_complex_type fmt = function
138	abate	1294	\| { ct_uid = id; ct_name = Some name } ->
139	abate	812	Format.fprintf fmt "%d:%a" id Encodings.Utf8.dump name
140	abate	1294	\| { ct_uid = id } ->
141			Format.fprintf fmt "%d:unnamed'" id
142	abate	759	let print_type fmt = function
143			\| AnyType -> Format.fprintf fmt "xsd:anyType"
144			\| Simple t -> Format.fprintf fmt "S:%a" print_simple_type t
145			\| Complex t -> Format.fprintf fmt "C:%a" print_complex_type t
146	abate	1294	let print_attribute fmt { attr_name = name; attr_typdef = t } =
147	abate	812	Format.fprintf fmt "@@%a:%a" Utf8.dump name print_simple_type t
148	abate	1294	let print_element fmt { elt_uid = id; elt_name = name } =
149	abate	812	Format.fprintf fmt "E:%d:<%a>" id Utf8.dump name
150	abate	759	let print_attributes fmt = List.iter (Format.fprintf fmt "%a" print_attribute)
151	abate	1294	let print_attribute_group fmt ag =
152			Format.fprintf fmt "{agroup:%a}" Utf8.dump ag.ag_name
153			let print_model_group fmt mg =
154			Format.fprintf fmt "{mgroup:%a}" Utf8.dump mg.mg_name
155	abate	759	let print_schema fmt schema =
156			let defined_types = (* filter out built-in types *)
157			List.filter
158			(fun def -> not (Schema_xml.has_xsd_prefix (name_of_type_definition def)))
159			schema.types
160			in
161			if defined_types <> [] then begin
162			Format.fprintf fmt "Types: ";
163			List.iter (fun c -> print_type fmt c; Format.fprintf fmt " ")
164			defined_types;
165			Format.fprintf fmt "\n"
166			end;
167			if schema.attributes <> [] then begin
168			Format.fprintf fmt "Attributes: ";
169			List.iter (fun c -> print_attribute fmt c; Format.fprintf fmt " ")
170			schema.attributes;
171			Format.fprintf fmt "\n"
172			end;
173			if schema.elements <> [] then begin
174			Format.fprintf fmt "Elements: ";
175			List.iter (fun c -> print_element fmt c; Format.fprintf fmt " ")
176			schema.elements;
177			Format.fprintf fmt "\n"
178			end;
179			if schema.attribute_groups <> [] then begin
180			Format.fprintf fmt "Attribute groups: ";
181			List.iter (fun c -> print_attribute_group fmt c; Format.fprintf fmt " ")
182			schema.attribute_groups;
183			Format.fprintf fmt "\n"
184			end;
185			if schema.model_groups <> [] then begin
186			Format.fprintf fmt "Model groups: ";
187			List.iter (fun c -> print_model_group fmt c; Format.fprintf fmt " ")
188			schema.model_groups;
189			Format.fprintf fmt "\n"
190			end
191
192			(** naive implementation: doesn't follow XML Schema constraints on facets
193			* merging. Here all new facets override old ones *)
194			let merge_facets old_facets new_facets =
195			let maxInclusive, maxExclusive =
196			match new_facets.maxInclusive, new_facets.maxExclusive with
197			\| None, None -> old_facets.maxInclusive, old_facets.maxExclusive
198			\| Some _, Some _ -> assert false
199			\| v -> v
200			in
201			let minInclusive, minExclusive =
202			match new_facets.minInclusive, new_facets.minExclusive with
203			\| None, None -> old_facets.minInclusive, old_facets.minExclusive
204			\| Some _, Some _ -> assert false
205			\| v -> v
206			in
207			{ old_facets with
208			length =
209			(match new_facets.length with
210			\| None -> old_facets.length
211			\| v -> v);
212			minLength =
213			(match new_facets.minLength with
214			\| None -> old_facets.minLength
215			\| v -> v);
216			maxLength =
217			(match new_facets.maxLength with
218			\| None -> old_facets.maxLength
219			\| v -> v);
220			enumeration =
221			(match new_facets.enumeration with
222			\| None -> old_facets.enumeration
223			\| v -> v);
224			whiteSpace = new_facets.whiteSpace;
225			maxInclusive = maxInclusive;
226			maxExclusive = maxExclusive;
227			minInclusive = minInclusive;
228			minExclusive = minExclusive;
229			}
230
231			let restrict base new_facets new_name =
232			let variety = variety_of_simple_type_definition base in
233			let facets =
234			merge_facets (facets_of_simple_type_definition base) new_facets
235			in
236			Derived (new_name, variety, facets, base)
237
238	abate	784	let get_type name schema =
239			List.find
240			(fun x ->
241			try
242			name_of_type_definition x = name
243			with Invalid_argument _ -> false)
244			schema.types
245			let get_attribute name schema =
246			List.find
247			(fun x ->
248			try
249			name_of_attribute_declaration x = name
250			with Invalid_argument _ -> false)
251			schema.attributes
252			let get_element name schema =
253			List.find
254			(fun x ->
255			try
256			name_of_element_declaration x = name
257			with Invalid_argument _ -> false)
258			schema.elements
259			let get_attribute_group name schema =
260			List.find
261			(fun x ->
262			try
263			name_of_attribute_group_definition x = name
264			with Invalid_argument _ -> false)
265			schema.attribute_groups
266			let get_model_group name schema =
267			List.find
268			(fun x ->
269			try
270			name_of_model_group_definition x = name
271			with Invalid_argument _ -> false)
272			schema.model_groups
273
274			(* policy for unqualified schema component resolution. The order should
275			* be consistent with Typer.find_schema_descr *)
276			let get_component kind name schema =
277			let rec tries = function
278			\| [] -> raise Not_found
279			\| hd :: tl -> (try hd () with Not_found -> tries tl)
280			in
281			let elt () = Element (get_element name schema) in
282			let typ () = Type (get_type name schema) in
283			let att () = Attribute (get_attribute name schema) in
284			let att_group () = Attribute_group (get_attribute_group name schema) in
285			let mod_group () = Model_group (get_model_group name schema) in
286			match kind with
287			\| Some `Element -> elt ()
288			\| Some `Type -> typ ()
289			\| Some `Attribute -> att ()
290			\| Some `Attribute_group -> att_group ()
291			\| Some `Model_group -> mod_group ()
292			\| None -> tries [ elt; typ; att; att_group; mod_group ]
293
294			let string_of_component_kind (kind: component_kind) =
295			match kind with
296			\| Some `Type -> "type"
297			\| Some `Element -> "element"
298			\| Some `Attribute -> "attribute"
299			\| Some `Attribute_group -> "attribute group"
300			\| Some `Model_group -> "model group"
301			\| None -> "component"
302
303	abate	812	(** Events *)
304	abate	784
305	abate	812	type to_be_visited =
306			\| Fully of Value.t (* xml values still to be visited *)
307			\| Half of Value.t (* xml values half visited (i.e. E_start_tag generated) *)
308			\| Other of Encodings.Utf8.t (* other values *)
309			\| Backlog of event (* old events not yet delivered *)
310
311			let stream_of_value v =
312			let stack = ref [Fully v] in
313			let f _ = (* lazy visit of a tree of CDuce XML values, stack keeps track of
314	abate	844	what has still to be visited *)
315	abate	812	match !stack with
316			\| (Fully ((Value.Xml (Value.Atom atom, attrs, _)) as v)) :: tl ->
317			stack := (Half v) :: tl;
318			let children = ref [] in (* TODO inefficient *)
319			let push v s = (s := v :: !s) in
320			Value.iter_xml
321			(fun pcdata -> push (Other pcdata) children)
322			(fun v ->
323			match v with
324			\| (Value.Xml (_, _, _)) as v -> push (Fully v) children
325			\| v -> raise (Invalid_argument "Schema_events.stream_of_value"))
326			v;
327			stack := (List.rev !children) @ !stack;
328			List.iter (* push attributes as events on the stack *)
329			(fun (qname, v) ->
330			push (Backlog (E_attribute (qname, fst (Value.get_string_utf8 v))))
331			stack)
332			(Value.get_fields attrs);
333			Some (E_start_tag (Atoms.V.value atom))
334			\| (Half (Value.Xml (Value.Atom atom, _, _))) :: tl ->
335			stack := tl;
336			Some (E_end_tag (Atoms.V.value atom))
337			\| (Fully (Value.Xml (_, _, _)))::_ \| (Half (Value.Xml (_, _, _)))::_ ->
338			failwith "Schema_xml.pxp_stream_of_value: non-atom-tag xml value"
339			\| (Backlog ev) :: tl -> (* consume backlog *)
340			stack := tl;
341			Some ev
342			\| (Other v) :: tl ->
343			stack := tl;
344			Some (E_char_data v)
345			\| [] -> None
346	abate	1453	\| _ ->
347			failwith "Non XML element"
348	abate	812	in
349			Stream.from f
350
351			let string_of_event = function
352			\| E_start_tag qname -> sprintf "<%s>" (Ns.QName.to_string qname)
353			\| E_end_tag qname -> sprintf "</%s>" (Ns.QName.to_string qname)
354			\| E_attribute (qname, value) ->
355			sprintf "@%s=%s" (Ns.QName.to_string qname) (Utf8.to_string value)
356			\| E_char_data value -> Utf8.to_string value
357
358			(*
359			let test v =
360			let s = stream_of_value v in
361			let rec aux () =
362			(match Stream.peek s with
363			\| None -> ()
364			\| Some (E_start_tag qname) ->
365			Ns.QName.print Format.std_formatter qname
366			\| Some (E_end_tag qname) ->
367			Format.fprintf Format.std_formatter "/";
368			Ns.QName.print Format.std_formatter qname
369			\| Some (E_attribute (qname, value)) ->
370			Format.fprintf Format.std_formatter "@@";
371			Ns.QName.print Format.std_formatter qname;
372			Format.fprintf Format.std_formatter " ";
373			Encodings.Utf8.print Format.std_formatter value
374			\| Some (E_char_data value) ->
375			Encodings.Utf8.print Format.std_formatter value);
376			Format.fprintf Format.std_formatter "\n";
377			(match Stream.peek s with
378			\| None -> ()
379			\| _ ->
380			Stream.junk s;
381			aux ())
382			in
383			aux ()
384			*)
385