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;
*)
}

(** 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 rec facets_of_simple_type_definition = function
  | Primitive _ -> no_facets
  | Derived (_, _, facets, _) -> facets

let rec variety_of_simple_type_definition = function
  | (Primitive name) as st -> Atomic (ref (Simple st))
  | Derived (_, variety, _, _) -> variety


let get_simple_type = function
  | { contents = Simple c } -> c
  | { contents = AnyType } -> Primitive (Utf8.mk "xsd:anySimpleType")
  | _ -> assert false

let rec normalize_simple_type = function
  | Derived (name, Restrict, new_facets, base) ->
      (match normalize_simple_type (get_simple_type base) with
         | Derived (_,variety,old_facets,base) ->
             Derived (name,variety,merge_facets old_facets new_facets,base)
         | Primitive _ as st ->
             let b = ref (Simple st) in
             Derived (name,Atomic b,new_facets,b))
  | st -> st
         
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 (ref (Simple 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 (ref (Simple st))

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 getint f = Value.get_integer (Lazy.force f) in
  let min =
    match facets.minInclusive, facets.minExclusive with
    | Some (i, _), None -> Some (getint i)
    | None, Some (i, _) -> Some (Intervals.V.succ (getint i))
    | None, None -> None
    | _ -> assert false
  in
  let max =
    match facets.maxInclusive, facets.maxExclusive with
    | Some (i, _), None -> Some (getint i)
    | None, Some (i, _) -> Some (Intervals.V.pred (getint 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 
    (get_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


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