viewcvs.cgi/schema/schema_common.ml


open Printf

open Encodings
open Encodings.Utf8.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 (_, 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 -> 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 (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 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
  | (id, Some name, _, _, _, _) ->
      Format.fprintf fmt "%d:%a" id Encodings.Utf8.dump 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 "@@%a:%a" Utf8.dump name print_simple_type t
let print_element fmt (id, 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 (name, _) =
  Format.fprintf fmt "{agroup:%a}" Utf8.dump name
let print_model_group fmt (name, _) =
  Format.fprintf fmt "{mgroup:%a}" Utf8.dump 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
    | _ -> assert false
  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			open Encodings.Utf8.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			let name_of_element_declaration (_, name, _, _) = name
26			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			\| _, Some name, _, _, _, _ -> name
32			\| _ -> 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			let name_of_attribute_declaration (name, _, _) = name
38			let name_of_attribute_use (_, (name, _, _), _) = name
39	abate	784	let name_of_attribute_group_definition = fst
40			let name_of_model_group_definition = fst
41			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			\| Complex (_, _, _, _, _, ct) -> ct
56			\| 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	812	\| (id, Some name, _, _, _, _) ->
139			Format.fprintf fmt "%d:%a" id Encodings.Utf8.dump name
140	abate	759	\| (id, None, _, _, _, _) -> Format.fprintf fmt "%d:unnamed'" id
141			let print_type fmt = function
142			\| AnyType -> Format.fprintf fmt "xsd:anyType"
143			\| Simple t -> Format.fprintf fmt "S:%a" print_simple_type t
144			\| Complex t -> Format.fprintf fmt "C:%a" print_complex_type t
145			let print_attribute fmt (name, t, _) =
146	abate	812	Format.fprintf fmt "@@%a:%a" Utf8.dump name print_simple_type t
147			let print_element fmt (id, name, _, _) =
148			Format.fprintf fmt "E:%d:<%a>" id Utf8.dump name
149	abate	759	let print_attributes fmt = List.iter (Format.fprintf fmt "%a" print_attribute)
150	abate	812	let print_attribute_group fmt (name, _) =
151			Format.fprintf fmt "{agroup:%a}" Utf8.dump name
152			let print_model_group fmt (name, _) =
153			Format.fprintf fmt "{mgroup:%a}" Utf8.dump name
154	abate	759	let print_schema fmt schema =
155			let defined_types = (* filter out built-in types *)
156			List.filter
157			(fun def -> not (Schema_xml.has_xsd_prefix (name_of_type_definition def)))
158			schema.types
159			in
160			if defined_types <> [] then begin
161			Format.fprintf fmt "Types: ";
162			List.iter (fun c -> print_type fmt c; Format.fprintf fmt " ")
163			defined_types;
164			Format.fprintf fmt "\n"
165			end;
166			if schema.attributes <> [] then begin
167			Format.fprintf fmt "Attributes: ";
168			List.iter (fun c -> print_attribute fmt c; Format.fprintf fmt " ")
169			schema.attributes;
170			Format.fprintf fmt "\n"
171			end;
172			if schema.elements <> [] then begin
173			Format.fprintf fmt "Elements: ";
174			List.iter (fun c -> print_element fmt c; Format.fprintf fmt " ")
175			schema.elements;
176			Format.fprintf fmt "\n"
177			end;
178			if schema.attribute_groups <> [] then begin
179			Format.fprintf fmt "Attribute groups: ";
180			List.iter (fun c -> print_attribute_group fmt c; Format.fprintf fmt " ")
181			schema.attribute_groups;
182			Format.fprintf fmt "\n"
183			end;
184			if schema.model_groups <> [] then begin
185			Format.fprintf fmt "Model groups: ";
186			List.iter (fun c -> print_model_group fmt c; Format.fprintf fmt " ")
187			schema.model_groups;
188			Format.fprintf fmt "\n"
189			end
190
191			(** naive implementation: doesn't follow XML Schema constraints on facets
192			* merging. Here all new facets override old ones *)
193			let merge_facets old_facets new_facets =
194			let maxInclusive, maxExclusive =
195			match new_facets.maxInclusive, new_facets.maxExclusive with
196			\| None, None -> old_facets.maxInclusive, old_facets.maxExclusive
197			\| Some _, Some _ -> assert false
198			\| v -> v
199			in
200			let minInclusive, minExclusive =
201			match new_facets.minInclusive, new_facets.minExclusive with
202			\| None, None -> old_facets.minInclusive, old_facets.minExclusive
203			\| Some _, Some _ -> assert false
204			\| v -> v
205			in
206			{ old_facets with
207			length =
208			(match new_facets.length with
209			\| None -> old_facets.length
210			\| v -> v);
211			minLength =
212			(match new_facets.minLength with
213			\| None -> old_facets.minLength
214			\| v -> v);
215			maxLength =
216			(match new_facets.maxLength with
217			\| None -> old_facets.maxLength
218			\| v -> v);
219			enumeration =
220			(match new_facets.enumeration with
221			\| None -> old_facets.enumeration
222			\| v -> v);
223			whiteSpace = new_facets.whiteSpace;
224			maxInclusive = maxInclusive;
225			maxExclusive = maxExclusive;
226			minInclusive = minInclusive;
227			minExclusive = minExclusive;
228			}
229
230			let restrict base new_facets new_name =
231			let variety = variety_of_simple_type_definition base in
232			let facets =
233			merge_facets (facets_of_simple_type_definition base) new_facets
234			in
235			Derived (new_name, variety, facets, base)
236
237	abate	784	let get_type name schema =
238			List.find
239			(fun x ->
240			try
241			name_of_type_definition x = name
242			with Invalid_argument _ -> false)
243			schema.types
244			let get_attribute name schema =
245			List.find
246			(fun x ->
247			try
248			name_of_attribute_declaration x = name
249			with Invalid_argument _ -> false)
250			schema.attributes
251			let get_element name schema =
252			List.find
253			(fun x ->
254			try
255			name_of_element_declaration x = name
256			with Invalid_argument _ -> false)
257			schema.elements
258			let get_attribute_group name schema =
259			List.find
260			(fun x ->
261			try
262			name_of_attribute_group_definition x = name
263			with Invalid_argument _ -> false)
264			schema.attribute_groups
265			let get_model_group name schema =
266			List.find
267			(fun x ->
268			try
269			name_of_model_group_definition x = name
270			with Invalid_argument _ -> false)
271			schema.model_groups
272
273			(* policy for unqualified schema component resolution. The order should
274			* be consistent with Typer.find_schema_descr *)
275			let get_component kind name schema =
276			let rec tries = function
277			\| [] -> raise Not_found
278			\| hd :: tl -> (try hd () with Not_found -> tries tl)
279			in
280			let elt () = Element (get_element name schema) in
281			let typ () = Type (get_type name schema) in
282			let att () = Attribute (get_attribute name schema) in
283			let att_group () = Attribute_group (get_attribute_group name schema) in
284			let mod_group () = Model_group (get_model_group name schema) in
285			match kind with
286			\| Some `Element -> elt ()
287			\| Some `Type -> typ ()
288			\| Some `Attribute -> att ()
289			\| Some `Attribute_group -> att_group ()
290			\| Some `Model_group -> mod_group ()
291			\| None -> tries [ elt; typ; att; att_group; mod_group ]
292
293			let string_of_component_kind (kind: component_kind) =
294			match kind with
295			\| Some `Type -> "type"
296			\| Some `Element -> "element"
297			\| Some `Attribute -> "attribute"
298			\| Some `Attribute_group -> "attribute group"
299			\| Some `Model_group -> "model group"
300			\| None -> "component"
301
302	abate	812	(** Events *)
303	abate	784
304	abate	812	type to_be_visited =
305			\| Fully of Value.t (* xml values still to be visited *)
306			\| Half of Value.t (* xml values half visited (i.e. E_start_tag generated) *)
307			\| Other of Encodings.Utf8.t (* other values *)
308			\| Backlog of event (* old events not yet delivered *)
309
310			let stream_of_value v =
311			let stack = ref [Fully v] in
312			let f _ = (* lazy visit of a tree of CDuce XML values, stack keeps track of
313	abate	844	what has still to be visited *)
314	abate	812	match !stack with
315			\| (Fully ((Value.Xml (Value.Atom atom, attrs, _)) as v)) :: tl ->
316			stack := (Half v) :: tl;
317			let children = ref [] in (* TODO inefficient *)
318			let push v s = (s := v :: !s) in
319			Value.iter_xml
320			(fun pcdata -> push (Other pcdata) children)
321			(fun v ->
322			match v with
323			\| (Value.Xml (_, _, _)) as v -> push (Fully v) children
324			\| v -> raise (Invalid_argument "Schema_events.stream_of_value"))
325			v;
326			stack := (List.rev !children) @ !stack;
327			List.iter (* push attributes as events on the stack *)
328			(fun (qname, v) ->
329			push (Backlog (E_attribute (qname, fst (Value.get_string_utf8 v))))
330			stack)
331			(Value.get_fields attrs);
332			Some (E_start_tag (Atoms.V.value atom))
333			\| (Half (Value.Xml (Value.Atom atom, _, _))) :: tl ->
334			stack := tl;
335			Some (E_end_tag (Atoms.V.value atom))
336			\| (Fully (Value.Xml (_, _, _)))::_ \| (Half (Value.Xml (_, _, _)))::_ ->
337			failwith "Schema_xml.pxp_stream_of_value: non-atom-tag xml value"
338			\| (Backlog ev) :: tl -> (* consume backlog *)
339			stack := tl;
340			Some ev
341			\| (Other v) :: tl ->
342			stack := tl;
343			Some (E_char_data v)
344			\| [] -> None
345			\| _ -> assert false
346			in
347			Stream.from f
348
349			let string_of_event = function
350			\| E_start_tag qname -> sprintf "<%s>" (Ns.QName.to_string qname)
351			\| E_end_tag qname -> sprintf "</%s>" (Ns.QName.to_string qname)
352			\| E_attribute (qname, value) ->
353			sprintf "@%s=%s" (Ns.QName.to_string qname) (Utf8.to_string value)
354			\| E_char_data value -> Utf8.to_string value
355
356			(*
357			let test v =
358			let s = stream_of_value v in
359			let rec aux () =
360			(match Stream.peek s with
361			\| None -> ()
362			\| Some (E_start_tag qname) ->
363			Ns.QName.print Format.std_formatter qname
364			\| Some (E_end_tag qname) ->
365			Format.fprintf Format.std_formatter "/";
366			Ns.QName.print Format.std_formatter qname
367			\| Some (E_attribute (qname, value)) ->
368			Format.fprintf Format.std_formatter "@@";
369			Ns.QName.print Format.std_formatter qname;
370			Format.fprintf Format.std_formatter " ";
371			Encodings.Utf8.print Format.std_formatter value
372			\| Some (E_char_data value) ->
373			Encodings.Utf8.print Format.std_formatter value);
374			Format.fprintf Format.std_formatter "\n";
375			(match Stream.peek s with
376			\| None -> ()
377			\| _ ->
378			Stream.junk s;
379			aux ())
380			in
381			aux ()
382			*)
383