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
  | (_, _, Elt elt_decl_ref, _) -> name_of_element_declaration (Lazy.force elt_decl_ref)
  | _ -> 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 (_, _, _, 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 Ns.QName.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" 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_unqual name table get_name =
  List.find
    (fun x ->
      try Utf8.equal (snd (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 get_type name schema = 
  get_unqual name schema.types name_of_type_definition 
let get_attribute name schema =
  get_unqual name schema.attributes name_of_attribute_declaration
let get_element name schema =
  get_unqual name schema.elements name_of_element_declaration
let get_attribute_group name schema =
  get_unqual name schema.attribute_groups name_of_attribute_group_definition
let get_model_group name schema =
  get_unqual 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_unqual_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 (min,max,term,_) =
  print_term ppf term
and print_term ppf = function
  | Elt e -> Format.fprintf ppf "E%i" ((Lazy.force 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	1462	\| (_, _, Elt elt_decl_ref, _) -> name_of_element_declaration (Lazy.force elt_decl_ref)
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	844	let first_of_particle (_, _, _, first) = first
150			let nullable p = List.mem None (first_of_particle p)
151			let first_of_model_group = function
152			\| All particles \| Choice particles ->
153			List.concat (List.map first_of_particle particles)
154			\| Sequence particles ->
155			let rec aux = function
156			\| hd :: tl when nullable hd -> (first_of_particle hd) @ (aux tl)
157			\| hd :: tl -> first_of_particle hd
158			\| [] -> []
159			in
160			aux particles
161			let rec is_in_first tag = function
162			\| [] -> false
163	abate	1460	\| Some tag' :: rest when Ns.QName.equal tag' tag -> true
164	abate	844	\| _ :: rest -> is_in_first tag rest
165
166	abate	759	let get_interval facets =
167			(* ASSUMPTION:
168			* not (facets.minInclusive = Some _ && facets.minExclusive = Some _)
169			* not (facets.maxInclusive = Some _ && facets.maxExclusive = Some _)
170			* Value.t is an integer! (no other intervals are actually supported
171			* by the CDuce type system)
172			*)
173	abate	1455	let getint f = Value.get_integer (Lazy.force f) in
174	abate	759	let min =
175			match facets.minInclusive, facets.minExclusive with
176	abate	1455	\| Some (i, _), None -> Some (getint i)
177			\| None, Some (i, _) -> Some (Intervals.V.succ (getint i))
178	abate	759	\| None, None -> None
179			\| _ -> assert false
180			in
181			let max =
182			match facets.maxInclusive, facets.maxExclusive with
183	abate	1455	\| Some (i, _), None -> Some (getint i)
184			\| None, Some (i, _) -> Some (Intervals.V.pred (getint i))
185	abate	759	\| None, None -> None
186			\| _ -> assert false
187			in
188			match min, max with
189			\| Some min, Some max -> Intervals.bounded min max
190			\| Some min, None -> Intervals.right min
191			\| None, Some max -> Intervals.left max
192			\| None, None -> Intervals.any
193
194	abate	1455
195	abate	759	let print_simple_type fmt = function
196	abate	1460	\| Primitive name -> Format.fprintf fmt "%a" Ns.QName.print name
197	abate	812	\| Derived (Some name, _, _, _) ->
198	abate	1460	Format.fprintf fmt "%a'" Ns.QName.print name
199			\| Derived (None, _, _, _) -> Format.fprintf fmt "unnamed"
200	abate	759	let print_complex_type fmt = function
201	abate	1294	\| { ct_uid = id; ct_name = Some name } ->
202	abate	1460	Format.fprintf fmt "%d:%a" id Ns.QName.print name
203	abate	1294	\| { ct_uid = id } ->
204			Format.fprintf fmt "%d:unnamed'" id
205	abate	759	let print_type fmt = function
206			\| AnyType -> Format.fprintf fmt "xsd:anyType"
207			\| Simple t -> Format.fprintf fmt "S:%a" print_simple_type t
208			\| Complex t -> Format.fprintf fmt "C:%a" print_complex_type t
209	abate	1294	let print_attribute fmt { attr_name = name; attr_typdef = t } =
210	abate	1460	Format.fprintf fmt "@@%a:%a" Ns.QName.print name print_simple_type
211	abate	1455	(get_simple_type t)
212	abate	1294	let print_element fmt { elt_uid = id; elt_name = name } =
213	abate	1460	Format.fprintf fmt "E:%d:<%a>" id Ns.QName.print name
214	abate	759	let print_attributes fmt = List.iter (Format.fprintf fmt "%a" print_attribute)
215	abate	1294	let print_attribute_group fmt ag =
216	abate	1460	Format.fprintf fmt "{agroup:%a}" Ns.QName.print ag.ag_name
217	abate	1463	let print_model_group_def fmt mg =
218	abate	1460	Format.fprintf fmt "{mgroup:%a}" Ns.QName.print mg.mg_name
219	abate	759	let print_schema fmt schema =
220			let defined_types = (* filter out built-in types *)
221	abate	1460	List.filter (fun t ->
222			let (ns,_) = name_of_type_definition t in
223			not (Ns.equal ns xsd)) schema.types
224	abate	759	in
225			if defined_types <> [] then begin
226			Format.fprintf fmt "Types: ";
227			List.iter (fun c -> print_type fmt c; Format.fprintf fmt " ")
228			defined_types;
229			Format.fprintf fmt "\n"
230			end;
231			if schema.attributes <> [] then begin
232			Format.fprintf fmt "Attributes: ";
233			List.iter (fun c -> print_attribute fmt c; Format.fprintf fmt " ")
234			schema.attributes;
235			Format.fprintf fmt "\n"
236			end;
237			if schema.elements <> [] then begin
238			Format.fprintf fmt "Elements: ";
239			List.iter (fun c -> print_element fmt c; Format.fprintf fmt " ")
240			schema.elements;
241			Format.fprintf fmt "\n"
242			end;
243			if schema.attribute_groups <> [] then begin
244			Format.fprintf fmt "Attribute groups: ";
245			List.iter (fun c -> print_attribute_group fmt c; Format.fprintf fmt " ")
246			schema.attribute_groups;
247			Format.fprintf fmt "\n"
248			end;
249			if schema.model_groups <> [] then begin
250			Format.fprintf fmt "Model groups: ";
251	abate	1463	List.iter (fun c -> print_model_group_def fmt c; Format.fprintf fmt " ")
252	abate	759	schema.model_groups;
253			Format.fprintf fmt "\n"
254			end
255
256
257	abate	1460	let get_qual name table get_name =
258	abate	784	List.find
259			(fun x ->
260	abate	1460	try Ns.QName.equal (get_name x) name
261	abate	784	with Invalid_argument _ -> false)
262	abate	1460	table
263			let get_unqual name table get_name =
264	abate	784	List.find
265			(fun x ->
266	abate	1460	try Utf8.equal (snd (get_name x)) name
267	abate	784	with Invalid_argument _ -> false)
268	abate	1460	table
269
270
271			let get_type name schema = get_qual name schema.types name_of_type_definition
272			let get_attribute name schema =
273			get_qual name schema.attributes name_of_attribute_declaration
274	abate	784	let get_element name schema =
275	abate	1460	get_qual name schema.elements name_of_element_declaration
276	abate	784	let get_attribute_group name schema =
277	abate	1460	get_qual name schema.attribute_groups name_of_attribute_group_definition
278	abate	784	let get_model_group name schema =
279	abate	1460	get_qual name schema.model_groups name_of_model_group_definition
280	abate	784
281			(* policy for unqualified schema component resolution. The order should
282			* be consistent with Typer.find_schema_descr *)
283			let get_component kind name schema =
284			let rec tries = function
285			\| [] -> raise Not_found
286			\| hd :: tl -> (try hd () with Not_found -> tries tl)
287			in
288			let elt () = Element (get_element name schema) in
289			let typ () = Type (get_type name schema) in
290			let att () = Attribute (get_attribute name schema) in
291			let att_group () = Attribute_group (get_attribute_group name schema) in
292			let mod_group () = Model_group (get_model_group name schema) in
293			match kind with
294			\| Some `Element -> elt ()
295			\| Some `Type -> typ ()
296			\| Some `Attribute -> att ()
297			\| Some `Attribute_group -> att_group ()
298			\| Some `Model_group -> mod_group ()
299			\| None -> tries [ elt; typ; att; att_group; mod_group ]
300
301	abate	1460	let get_type name schema =
302			get_unqual name schema.types name_of_type_definition
303			let get_attribute name schema =
304			get_unqual name schema.attributes name_of_attribute_declaration
305			let get_element name schema =
306			get_unqual name schema.elements name_of_element_declaration
307			let get_attribute_group name schema =
308			get_unqual name schema.attribute_groups name_of_attribute_group_definition
309			let get_model_group name schema =
310			get_unqual name schema.model_groups name_of_model_group_definition
311
312			(* policy for unqualified schema component resolution. The order should
313			* be consistent with Typer.find_schema_descr *)
314			let get_unqual_component kind name schema =
315			let rec tries = function
316			\| [] -> raise Not_found
317			\| hd :: tl -> (try hd () with Not_found -> tries tl)
318			in
319			let elt () = Element (get_element name schema) in
320			let typ () = Type (get_type name schema) in
321			let att () = Attribute (get_attribute name schema) in
322			let att_group () = Attribute_group (get_attribute_group name schema) in
323			let mod_group () = Model_group (get_model_group name schema) in
324			match kind with
325			\| Some `Element -> elt ()
326			\| Some `Type -> typ ()
327			\| Some `Attribute -> att ()
328			\| Some `Attribute_group -> att_group ()
329			\| Some `Model_group -> mod_group ()
330			\| None -> tries [ elt; typ; att; att_group; mod_group ]
331
332	abate	784	let string_of_component_kind (kind: component_kind) =
333			match kind with
334			\| Some `Type -> "type"
335			\| Some `Element -> "element"
336			\| Some `Attribute -> "attribute"
337			\| Some `Attribute_group -> "attribute group"
338			\| Some `Model_group -> "model group"
339			\| None -> "component"
340
341	abate	812	(** Events *)
342	abate	784
343	abate	812	type to_be_visited =
344			\| Fully of Value.t (* xml values still to be visited *)
345			\| Half of Value.t (* xml values half visited (i.e. E_start_tag generated) *)
346			\| Other of Encodings.Utf8.t (* other values *)
347			\| Backlog of event (* old events not yet delivered *)
348
349			let stream_of_value v =
350			let stack = ref [Fully v] in
351			let f _ = (* lazy visit of a tree of CDuce XML values, stack keeps track of
352	abate	844	what has still to be visited *)
353	abate	812	match !stack with
354			\| (Fully ((Value.Xml (Value.Atom atom, attrs, _)) as v)) :: tl ->
355			stack := (Half v) :: tl;
356			let children = ref [] in (* TODO inefficient *)
357			let push v s = (s := v :: !s) in
358			Value.iter_xml
359			(fun pcdata -> push (Other pcdata) children)
360			(fun v ->
361			match v with
362			\| (Value.Xml (_, _, _)) as v -> push (Fully v) children
363			\| v -> raise (Invalid_argument "Schema_events.stream_of_value"))
364			v;
365			stack := (List.rev !children) @ !stack;
366			List.iter (* push attributes as events on the stack *)
367			(fun (qname, v) ->
368			push (Backlog (E_attribute (qname, fst (Value.get_string_utf8 v))))
369			stack)
370			(Value.get_fields attrs);
371			Some (E_start_tag (Atoms.V.value atom))
372			\| (Half (Value.Xml (Value.Atom atom, _, _))) :: tl ->
373			stack := tl;
374			Some (E_end_tag (Atoms.V.value atom))
375			\| (Fully (Value.Xml (_, _, _)))::_ \| (Half (Value.Xml (_, _, _)))::_ ->
376			failwith "Schema_xml.pxp_stream_of_value: non-atom-tag xml value"
377			\| (Backlog ev) :: tl -> (* consume backlog *)
378			stack := tl;
379			Some ev
380			\| (Other v) :: tl ->
381			stack := tl;
382			Some (E_char_data v)
383			\| [] -> None
384	abate	1453	\| _ ->
385			failwith "Non XML element"
386	abate	812	in
387			Stream.from f
388
389			let string_of_event = function
390			\| E_start_tag qname -> sprintf "<%s>" (Ns.QName.to_string qname)
391			\| E_end_tag qname -> sprintf "</%s>" (Ns.QName.to_string qname)
392			\| E_attribute (qname, value) ->
393			sprintf "@%s=%s" (Ns.QName.to_string qname) (Utf8.to_string value)
394			\| E_char_data value -> Utf8.to_string value
395
396			(*
397			let test v =
398			let s = stream_of_value v in
399			let rec aux () =
400			(match Stream.peek s with
401			\| None -> ()
402			\| Some (E_start_tag qname) ->
403			Ns.QName.print Format.std_formatter qname
404			\| Some (E_end_tag qname) ->
405			Format.fprintf Format.std_formatter "/";
406			Ns.QName.print Format.std_formatter qname
407			\| Some (E_attribute (qname, value)) ->
408			Format.fprintf Format.std_formatter "@@";
409			Ns.QName.print Format.std_formatter qname;
410			Format.fprintf Format.std_formatter " ";
411			Encodings.Utf8.print Format.std_formatter value
412			\| Some (E_char_data value) ->
413			Encodings.Utf8.print Format.std_formatter value);
414			Format.fprintf Format.std_formatter "\n";
415			(match Stream.peek s with
416			\| None -> ()
417			\| _ ->
418			Stream.junk s;
419			aux ())
420			in
421			aux ()
422			*)
423
424	abate	1463
425			let rec print_model_group ppf = function
426			\| All pl -> Format.fprintf ppf "All(%a)" print_particle_list pl
427			\| Choice pl -> Format.fprintf ppf "Choice(%a)" print_particle_list pl
428			\| Sequence pl -> Format.fprintf ppf "Sequence(%a)" print_particle_list pl
429			and print_particle_list ppf = function
430			\| [] -> ()
431			\| [p] -> print_particle ppf p
432			\| hd::tl -> Format.fprintf ppf "%a;%a" print_particle hd print_particle_list tl
433			and print_particle ppf (min,max,term,_) =
434			print_term ppf term
435			and print_term ppf = function
436			\| Elt e -> Format.fprintf ppf "E%i" ((Lazy.force e).elt_uid)
437			\| Model m -> print_model_group ppf m