viewcvs.cgi/schema/schema_common.ml

open Printf

open Encodings
open Schema_pcre
open Schema_types

let xsd = Schema_xml.xsd

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 (lazy (Simple st))
  | Derived (_, variety, _, _) -> variety


let get_simple_type c = match Lazy.force c with
  | Simple c -> c
  | AnyType -> Primitive (xsd,Utf8.mk "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 = lazy (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 -> (xsd, Utf8.mk "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
  | { part_term = Elt e } ->  name_of_element_declaration e
  | _ -> assert false
let variety_of_simple_type_definition = function
  | (Primitive name) as st -> Atomic (lazy (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 (lazy (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 (xsd, Utf8.mk "anySimpleType")
let anyType = AnyType

let first_of_particle p = p.part_first
let nullable p = p.part_nullable

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 nullable_of_model_group = function
  | All particles | Sequence particles -> List.for_all nullable particles
  | Choice particles -> List.exists nullable particles


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" Ns.QName.print name
  | Derived (Some name, _, _, _) ->
      Format.fprintf fmt "%a'" Ns.QName.print 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 Ns.QName.print 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" Ns.QName.print 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 Ns.QName.print name
let print_attributes fmt = List.iter (Format.fprintf fmt "%a" print_attribute)
let print_attribute_group fmt ag =
  Format.fprintf fmt "{agroup:%a}" Ns.QName.print ag.ag_name
let print_model_group_def fmt mg =
  Format.fprintf fmt "{mgroup:%a}" Ns.QName.print mg.mg_name
let print_schema fmt schema =
  let defined_types = (* filter out built-in types *)
    List.filter (fun t -> 
                   let (ns,_) = name_of_type_definition t in
                   not (Ns.equal ns xsd)) 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_def fmt c; Format.fprintf fmt " ")
      schema.model_groups;
    Format.fprintf fmt "\n"
  end


let get_qual name table get_name =
  List.find
    (fun x ->
      try Ns.QName.equal (get_name x) name
      with Invalid_argument _ -> false)
    table

let get_type name schema = get_qual name schema.types name_of_type_definition 
let get_attribute name schema =
  get_qual name schema.attributes name_of_attribute_declaration
let get_element name schema =
  get_qual name schema.elements name_of_element_declaration
let get_attribute_group name schema =
  get_qual name schema.attribute_groups name_of_attribute_group_definition
let get_model_group name schema =
  get_qual name schema.model_groups name_of_model_group_definition

  (* 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 ()
*)


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