viewcvs.cgi/schema/schema_parser.ml


open Printf
open Pxp_document

open Encodings
open Encodings.Utf8.Pcre
open Schema_common
open Schema_types
open Schema_validator
open Schema_xml
open Schema_xml.Pxp_helpers

let debug = false
let debug_print ?(n: pxp_node option) s =
  if debug then
    (match n with
    | None -> prerr_endline s
    | Some n ->
        let line = match n#position with (_,l,_) -> l in
        prerr_endline (sprintf "[%d] %s" line s);
        flush stderr)

let space_RE = pcre_regexp " "
let split s = pcre_split ~rex:space_RE s
let unqualify s = snd (Ns.split_qname s)
let hashtbl_deref tbl =
  (* ASSUMPTION: no multiple bindings *)
  let tbl' = Hashtbl.create 1024 in
  Hashtbl.iter (fun key value -> Hashtbl.add tbl' key !value) tbl;
  tbl'
let hashtbl_values tbl = Hashtbl.fold (fun _ v acc -> v :: acc) tbl []

class type resolver =
  object
      (** add a node to the list of "seen" nodes.
      @raise Osv_validation_error if the same node is seen twice *)
    method see : pxp_node -> unit

    method resolve_att: ?fix_ns:bool -> Utf8.t -> attribute_declaration
    method resolve_elt:
      ?fix_ns:bool -> now:bool -> Utf8.t -> element_declaration ref
    method resolve_typ:
      ?fix_ns:bool -> now:bool -> Utf8.t -> type_definition ref
    method resolve_att_group:
      ?fix_ns:bool -> Utf8.t -> attribute_group_definition
    method resolve_model_group: ?fix_ns:bool -> Utf8.t -> model_group_definition
    method resolve_simple_typ: ?fix_ns:bool -> Utf8.t -> simple_type_definition
  end

module OrderedNode =
  struct
    type t = pxp_node
    let compare = Pxp_document.compare
  end
module NodeSet = Set.Make (OrderedNode)

  (* element and complex type constructors which take cares of unique id *)
let element, complex =
  let counter = ref 0 in
  let element name (type_def: type_definition ref) constr =
    incr counter;
    !counter, name, type_def, constr
  in
  let complex name (type_def: type_definition) deriv attrs ct =
    incr counter;
    !counter, name, type_def, deriv, attrs, ct
  in
  (element, complex)

let integer_of_value_t = function
  | Value.Integer i -> i
  | _ -> assert false

let parse_facets base n =
  debug_print ~n "Schema_parser.parse_facet"; 
  let validate_base_type = Schema_validator.validate_simple_type base in
  let validate_nonNegativeInteger =
    Schema_builtin.validate_builtin
      (Schema_xml.add_xsd_prefix (Utf8.mk "nonNegativeInteger"))
  in
  let facets = ref no_facets in
  n#iter_nodes (fun n ->
    let fixed =
      (_has_attribute "fixed" n) && (_attribute "fixed" n = Utf8.mk "true")
    in
    match n#node_type with
    | T_element "xsd:length" ->
        let value = _attribute "value" n in
        let length = integer_of_value_t (validate_nonNegativeInteger value) in
        facets := { !facets with length = Some (length, fixed) }
    | T_element "xsd:minLength" ->
        let value = _attribute "value" n in
        let length = integer_of_value_t (validate_nonNegativeInteger value) in
        facets := { !facets with minLength = Some (length, fixed) }
    | T_element "xsd:maxLength" ->
        let value = _attribute "value" n in
        let length = integer_of_value_t (validate_nonNegativeInteger value) in
        facets := { !facets with maxLength = Some (length, fixed) }
    | T_element "xsd:enumeration" ->
        let value = Value.string_utf8 (_attribute "value" n) in
        let value = validate_base_type value in
        let new_enumeration =
          (match !facets.enumeration with
          | None -> Some (Value.ValueSet.singleton value)
          | Some entries -> Some (Value.ValueSet.add value entries))
        in
        facets := { !facets with enumeration = new_enumeration }
    | T_element "xsd:whiteSpace" ->
        let value = Utf8.get_str (_attribute "value" n) in
        facets := { !facets with whiteSpace =
          ((match value with
            | "collapse" -> `Collapse
            | "preserve" -> `Preserve
            | "replace" -> `Replace
            | _ -> assert false),
          fixed) }
    | T_element "xsd:maxInclusive" ->
        let value = Value.string_utf8 (_attribute "value" n) in
        facets := { !facets with
          maxInclusive = Some (validate_base_type value, fixed) }
    | T_element "xsd:maxExclusive" ->
        let value = Value.string_utf8 (_attribute "value" n) in
        facets := { !facets with
          maxExclusive = Some (validate_base_type value, fixed) }
    | T_element "xsd:minInclusive" ->
        let value = Value.string_utf8 (_attribute "value" n) in
        facets := { !facets with
          minInclusive = Some (validate_base_type value, fixed) }
    | T_element "xsd:minExclusive" ->
        let value = Value.string_utf8 (_attribute "value" n) in
        facets := { !facets with
          minExclusive = Some (validate_base_type value, fixed) }
    | _ -> ());
  !facets
  
let merge_facets' base new_facets =
  merge_facets (facets_of_simple_type_definition base) new_facets

  (* parse an xsd:simpleType element *)
let rec parse_simple_type (resolver: resolver) n =
  debug_print ~n "Schema_parser.parse_simple_type";
  resolver#see n;
  let name =
    if _has_attribute "name" n then Some (_attribute "name" n) else None
  in
  if _has_element "xsd:restriction" n then begin    (* restriction *)
    let restriction = _element "xsd:restriction" n in
    let base = find_base_simple_type resolver restriction in
    let facets = parse_facets base restriction in
    restrict base facets name
  end else if _has_element "xsd:list" n then begin  (* list *)
    let list = _element "xsd:list" n in
    let items = find_item_type resolver list in
    Derived (name, List items, no_facets, anySimpleType)
  end else begin                                    (* union *)
    let union = _element "xsd:union" n in
    let members = find_member_types resolver union in
    Derived (name, Union members, no_facets, anySimpleType)
  end

  (* look for a simple type def: try attribute "base", try "simpleType" child,
   * fail *)
and find_base_simple_type (resolver: resolver) n =
  if _has_attribute "base" n then
    resolver#resolve_simple_typ (_attribute "base" n)
  else if _has_element "xsd:simpleType" n then
    parse_simple_type resolver (_element "xsd:simpleType" n)
  else
    raise (XSD_validation_error "no base simple type specified")

  (* look for a simple type def: try attribute "itemType", try "simpleType"
   * child, fail *)
and find_item_type (resolver: resolver) n =
  if _has_attribute "itemType" n then
    resolver#resolve_simple_typ (_attribute "itemType" n)
  else if _has_element "xsd:simpleType" n then
    parse_simple_type resolver (_element "xsd:simpleType" n)
  else
    raise (XSD_validation_error "no itemType specified")

  (* look for a list of simple type defs: try attribute "memberTypes", try
   * "simpleType" children, fail *)
and find_member_types (resolver: resolver) n =
  let members1 =
    if _has_attribute "memberTypes" n then
      let names = split (_attribute "memberTypes" n) in
      List.map resolver#resolve_simple_typ names
    else
      []
  in
  let members2 =
    let nodes = _elements "xsd:simpleType" n in
    List.map (parse_simple_type resolver) nodes
  in
  (match members1 @ members2 with
  | [] -> raise (XSD_validation_error "no member types specified")
  | members -> members)

  (* parse an attribute value constraint *)
let parse_att_value_constraint stype_def n =
  debug_print ~n "Schema_parser.parse_att_value_constraint";
  if _has_attribute "default" n then
    let value = Value.string_utf8 (_attribute "default" n) in
    let value = validate_simple_type stype_def value in
    Some (`Default value)
  else if _has_attribute "fixed" n then
    let value = Value.string_utf8 (_attribute "fixed" n) in
    let value = validate_simple_type stype_def value in
    Some (`Fixed value)
  else
    None

  (* parse an element value constraint *)
let parse_elt_value_constraint type_def n =
  debug_print ~n "Schema_parser.parse_elt_value_constraint";
  let validate_value =
    match type_def with
    | Simple st_def | Complex (_, _, _, _, _, CT_simple st_def) ->
        validate_simple_type st_def
    | _ -> validate_simple_type (Primitive (Utf8.mk "xsd:string"))
  in
  if _has_attribute "default" n then
    let value = Value.string_utf8 (_attribute "default" n) in
    let value = validate_value value in
    Some (`Default value)
  else if _has_attribute "fixed" n then
    let value = Value.string_utf8 (_attribute "fixed" n) in
    let value = validate_value value in
    Some (`Fixed value)
  else
    None

  (* look for a simple type def, try "simpleType" child, try "type" attribute,
   * return anySimpleType *)
let find_simple_type (resolver: resolver) n =
  if _has_element "xsd:simpleType" n then
    parse_simple_type resolver (_element "xsd:simpleType" n)
  else if _has_attribute "type" n then
    resolver#resolve_simple_typ (_attribute "type" n)
  else
    anySimpleType

let parse_att_decl (resolver: resolver) n =
  debug_print ~n "Schema_parser.parse_att_decl";
  resolver#see n;
  let name = _attribute "name" n in
  let type_def = find_simple_type resolver n in
  let value_constr = parse_att_value_constraint type_def n in
  name, type_def, value_constr

let parse_attribute_use (resolver: resolver) n =
  debug_print ~n "Schema_parser.parse_attribute_use";
  let required =
    (_has_attribute "use" n) && (_attribute "use" n = Utf8.mk "required")
  in
  let (name, type_def, value_constr) as att_decl =
    if _has_attribute "ref" n then
      resolver#resolve_att (_attribute "ref" n)
    else
      let (name, type_def, constr) = parse_att_decl resolver n in
      (name, type_def, None)  (* forget attribute value constraint *)
  in
  let value_constr = parse_att_value_constraint type_def n in
  required, att_decl, value_constr

let parse_attribute_uses (resolver: resolver) derivation_type base n =
  debug_print ~n "Schema_parser.parse_attribute_uses";
  let uses1 = (* attribute uses from "attribute" children *)
    List.map (parse_attribute_use resolver) (_elements "xsd:attribute" n)
  in
  let uses2 = (* attribute uses from "attributeGroup" children ref *)
    List.concat (List.map
      (fun att_group ->
        if _has_attribute "ref" att_group then
          snd (resolver#resolve_att_group (_attribute "ref" att_group))
        else [])
      (_elements "xsd:attributeGroup" n))
  in
  let uses3 = (* attribute uses from base type *)
    match base with
    | Complex (_, _, _, _, uses, _) ->
        (match derivation_type with
        | `Extension -> uses
        | `Restriction ->
            let ( &= ) u1 u2 = (* by name equality over attribute uses *)
              (name_of_attribute_use u1 = name_of_attribute_use u2)
            in
            let defined_uses = uses1 @ uses2 in
            List.filter
              (fun use -> not (List.exists (fun u -> u &= use) defined_uses))
(*                   && not (List.mem name prohibited_uses1) *) (* TODO prohibited attribute uses *)
              uses)
    | _ -> []
  in
  uses1 @ uses2 @ uses3

let parse_min_max n =
  ((if _has_attribute "minOccurs" n then
    Intervals.V.mk (Utf8.get_str (_attribute "minOccurs" n))
  else
    Intervals.V.one),
  (if _has_attribute "maxOccurs" n then
    match Utf8.get_str (_attribute "maxOccurs" n) with
    | "unbounded" -> None
    | s -> Some (Intervals.V.mk s)
  else
    Some Intervals.V.one))

let find_particles =
  _elements' ["xsd:element"; "xsd:group"; "xsd:choice"; "xsd:sequence"]

let rec parse_complex_type (resolver: resolver) n =
  let find_particle n =
    try
      Some (_element' ["xsd:all"; "xsd:choice"; "xsd:group"; "xsd:sequence"] n)
    with Not_found -> None
  in
  debug_print ~n "Schema_parser.parse_complex_type";
  resolver#see n;
  let name =
    if _has_attribute "name" n then Some (_attribute "name" n) else None
  in
  if _has_element "xsd:simpleContent" n then
    let content = _element "xsd:simpleContent" n in
    let derivation, derivation_type =
      if _has_element "xsd:restriction" content then
        (_element "xsd:restriction" content, `Restriction)
      else  (* _has_element "xsd:extension" *)
        (_element "xsd:extension" content, `Extension)
    in
    let base = resolver#resolve_typ ~now:true (_attribute "base" derivation) in
    let uses = parse_attribute_uses resolver derivation_type !base derivation in
    let content_type =
      match derivation_type with
      | `Restriction ->
          (match !base with
          | Complex (_, _, _, _, _, (CT_simple base)) ->
              let base =
                if _has_element "xsd:simpleType" derivation then
                  parse_simple_type resolver
                    (_element "xsd:simpleType" derivation)
                else
                  base
              in
              let new_facets = merge_facets' base (parse_facets base n) in
              let restricted_simple_type_def =
                (match base with
                | Primitive name ->
                    Derived (None, variety_of_simple_type_definition base,
                      new_facets, base)
                | Derived (_, variety, _, _) ->
                    Derived (None, variety, new_facets, base))
              in
              CT_simple restricted_simple_type_def
          | _ -> assert false)
      | `Extension ->
          (match !base with
          | Complex (_, _, _, _, _, (CT_simple base)) -> CT_simple base
          | Simple simple_type_def -> CT_simple simple_type_def
          | _ -> assert false)
    in
    complex name !base derivation_type uses content_type
  else if _has_element "xsd:complexContent" n then
    let content = _element "xsd:complexContent" n in
    let derivation, derivation_type =
      if _has_element "xsd:restriction" content then
        (_element "xsd:restriction" content, `Restriction)
      else  (* _has_element "xsd:extension" *)
        (_element "xsd:extension" content, `Extension)
    in
    let base = resolver#resolve_typ ~now:true (_attribute "base" derivation) in
    let uses = parse_attribute_uses resolver derivation_type !base derivation in
    let mixed =
      (_has_attribute "mixed" content &&
       (_attribute "mixed" content = Utf8.mk "true"))
      || (_has_attribute "mixed" n && (_attribute "mixed" n = Utf8.mk "true"))
    in
    let particle_node = find_particle derivation in
    let content_type =
      match derivation_type with
      | `Restriction ->
          (match particle_node with
          | None -> CT_empty
          | Some p_node ->
              let particle = parse_particle resolver p_node in
              CT_model (particle, mixed))
      | `Extension ->
          let base_ct = content_type_of_type !base in (* TODO BUG HERE if base =
                                                      AnyType *)
          (match particle_node with
          | None -> base_ct
          | Some pnode ->
              let particle = parse_particle resolver pnode in
              (match base_ct with
              | CT_empty -> CT_model (particle, mixed)
              | CT_model (p, _) ->
                  let model = Sequence (p::[particle]) in
                  CT_model
                    ((Intervals.V.one, Some (Intervals.V.one), Model model,
                      first_of_model_group model),
                     mixed)
              | CT_simple _ -> assert false))
    in
    complex name !base derivation_type uses content_type
  else  (* neither simpleContent nor complexContent *)
    let base = anyType in
    let uses = parse_attribute_uses resolver `Restriction base n in
    let mixed =
      _has_attribute "mixed" n && (_attribute "mixed" n = Utf8.mk "true")
    in
    let content_type =
      match find_particle n with
      | None -> CT_empty
      | Some pnode ->
          let particle = parse_particle resolver pnode in
          CT_model (particle, mixed)
    in
    complex name anyType `Restriction uses content_type

and parse_elt_decl (resolver: resolver) n: element_declaration =
  debug_print ~n "Schema_parser.parse_elt_decl";
  resolver#see n;
  if not (_has_attribute "name" n) then
    raise (XSD_validation_error "missing element name");
  let name = _attribute "name" n in
  let type_def = find_element_type resolver n in
  let value_constr = parse_elt_value_constraint type_def n in
  element name (ref type_def) value_constr

  (* look for a type definition, try "simpleType" child, try "complexType"
   * child, try "type" attribute, return anyType *)
and find_element_type (resolver: resolver) n =
  if _has_element "xsd:simpleType" n then
    Simple (parse_simple_type resolver (_element "xsd:simpleType" n))
  else if _has_element "xsd:complexType" n then
    Complex (parse_complex_type resolver (_element "xsd:complexType" n))
  else if _has_attribute "type" n then
    !(resolver#resolve_typ ~now:true (_attribute "type" n))
  else
    anyType

and parse_particle (resolver: resolver) n =
  debug_print ~n "Schema_parser.parse_particle";
  let min, max = parse_min_max n in
  match n#node_type with
  | T_element "xsd:element" ->
      let elt_decl, first =
        if _has_attribute "ref" n then
          let ref = _attribute "ref" n in
          (resolver#resolve_elt ~now:false ref, [ Some ref ])
        else  (* no "ref" attribute *)
          let decl = parse_elt_decl resolver n in
          (ref decl, [ Some (name_of_element_declaration decl) ])
      in
      (min, max, Elt elt_decl, first)
  | T_element "xsd:group" ->
      let model_group =
        snd (resolver#resolve_model_group (_attribute "ref" n))
      in
      (min, max, Model model_group, first_of_model_group model_group)
  | T_element "xsd:all" | T_element "xsd:sequence" | T_element "xsd:choice" ->
      let model_group = parse_model_group resolver n in
      (min, max, Model model_group, first_of_model_group model_group)
  | _ -> assert false

and parse_model_group (resolver: resolver) n =
  debug_print ~n "Schema_parser.parse_model_group";
  match n#node_type with
  | T_element "xsd:all" ->
      All (List.map (parse_particle resolver) (_elements "xsd:element" n))
  | T_element "xsd:sequence" ->
      Sequence (List.map (parse_particle resolver) (find_particles n))
  | T_element "xsd:choice" ->
      Choice (List.map (parse_particle resolver) (find_particles n))
  | _ -> assert false

and parse_att_group (resolver: resolver) n =
  debug_print ~n "Schema_parser.parse_att_group";
  resolver#see n;
  let name = _attribute "name" n in
  let uses1 =
    List.map (parse_attribute_use resolver) (_elements "xsd:attribute" n)
  in
  let uses2 =
    List.concat (List.map (fun name -> snd (resolver#resolve_att_group name))
      (List.map (_attribute "ref") (_elements "xsd:attributeGroup" n)))
  in
  name, (uses1 @ uses2)

let parse_model_group_def (resolver: resolver) n =
  debug_print ~n "Schema_parser.parse_model_group_def";
  resolver#see n;
  let name = _attribute "name" n in
  let model_group_node =
    _element' ["xsd:all"; "xsd:choice"; "xsd:sequence"] n
  in
  let model_group = parse_model_group resolver model_group_node in
  name, model_group

  (** @param root schema document root node *)
class lazy_resolver =
  let fake_type_def =
    Complex (~-1, Some (Utf8.mk "   FAKE TYP   "), AnyType, `Restriction, [],
      CT_empty)
  in
  let fake_elt_decl = ~-2, Utf8.mk "   FAKE ELT   ", ref fake_type_def, None in
  let is_fake_type_def = (==) fake_type_def in
  let is_fake_elt_decl = (==) fake_elt_decl in
  let validation_error s = raise (XSD_validation_error s) in
  let get_ns_prefix n =
    match n#node_type with T_namespace p -> p | _ -> assert false
  in
  let (^^) x y = Utf8.concat x y in
  fun root ->
  object (self)

    val typs: (Utf8.t, type_definition ref) Hashtbl.t =
      Hashtbl.create 17
    val attrs: (Utf8.t, attribute_declaration) Hashtbl.t =
      Hashtbl.create 17
    val elts: (Utf8.t, element_declaration ref) Hashtbl.t =
      Hashtbl.create 17
    val attr_groups: (Utf8.t, attribute_group_definition) Hashtbl.t =
      Hashtbl.create 17
    val model_groups: (Utf8.t, model_group_definition) Hashtbl.t =
      Hashtbl.create 17

    val mutable seen_nodes = NodeSet.empty

    val mutable targetNamespace = None
    val mutable targetNamespace_prefix = "0TARGET0"
    val namespace_manager = new Pxp_dtd.namespace_manager
    val orig_ns_prefixes = Hashtbl.create 17

    initializer
      Schema_builtin.iter_builtin (* register built-in types *)
        (fun st_def ->
          let type_def = Simple st_def in
          let name = name_of_type_definition type_def in
          Hashtbl.replace typs name (ref type_def));
      Hashtbl.replace typs (Utf8.mk "xsd:anyType") (ref AnyType);
      List.iter (* fill namespace manager *)
        (fun (p, ns) ->
          namespace_manager#add_namespace (Utf8.get_str p) (Utf8.get_str ns))
        Schema_xml.schema_ns_prefixes;
      List.iter
        (fun n ->
          let prefix = get_ns_prefix n in
          let uri = n#data in
          if prefix <> "" then begin
            Hashtbl.add orig_ns_prefixes prefix uri;
            ignore (namespace_manager#lookup_or_add_namespace prefix uri)
          end)
        root#namespace_info#declaration;
      if _has_attribute "targetNamespace" root then begin
        let ns = _attribute "targetNamespace" root in
        targetNamespace <- Some ns;
        targetNamespace_prefix <-
          namespace_manager#lookup_or_add_namespace
            targetNamespace_prefix (Utf8.get_str ns)
      end;

      (** schemas namespaces handling *)

    method targetNamespace =
      match targetNamespace with
      | None -> Ns.empty
      | Some s -> Ns.mk s

      (* qualify names of entities before registering them with defined
       * targetNamespace, if any *)
    method private qualify_name name =
      match targetNamespace with
      | None -> name
      | Some _ -> (Utf8.mk (targetNamespace_prefix ^ ":")) ^^ name

      (* resolve user references using our namespace manager *)
    method private fix_namespace s =
      match Ns.split_qname s with
      | "", base ->
          (match targetNamespace with
          | None -> base
          | Some _ -> (Utf8.mk targetNamespace_prefix) ^^ (Utf8.mk ":") ^^ base)
      | prefix, base ->
          (try
            let orig_uri = Hashtbl.find orig_ns_prefixes prefix in
            let new_prefix = namespace_manager#get_normprefix orig_uri in
            (Utf8.mk new_prefix) ^^ (Utf8.mk ":") ^^ base
          with Not_found ->
            validation_error ("Can't resolve: " ^ Utf8.get_str s))

      (** seen nodes accounting *)

    method already_seen n = NodeSet.mem n seen_nodes
    method see (n: pxp_node) =
      debug_print "lazy_resolver.see";
      if NodeSet.mem n seen_nodes then
        validation_error "Types/Elements loop";
      seen_nodes <- NodeSet.add n seen_nodes

    method private find_global_component tag_pred name =
      let basename = snd (Ns.split_qname name) in
      find (fun n -> match n#node_type with
        | T_element tag when tag_pred tag ->
            (_has_attribute "name" n) && (_attribute "name" n = basename)
        | _ -> false) root

      (** registration of global entities *)

    method register_typ name def =
      debug_print "lazy_resolver.register_typ";
      let name = self#qualify_name name in
      if (Hashtbl.mem typs name) &&
         (not (is_fake_type_def !(Hashtbl.find typs name))) then
        validation_error ("Redefinition of type: " ^ Utf8.get_str name);
      debug_print (sprintf "Osv_parser: registering TYPE %s"
        (Utf8.get_str name));
      let type_def_ref = self#resolve_typ ~fix_ns:false ~now:false name in
      type_def_ref := def

    method register_elt name decl =
      debug_print "lazy_resolver.register_elt";
      let name = self#qualify_name name in
      if (Hashtbl.mem elts name) &&
         (not (is_fake_elt_decl !(Hashtbl.find elts name))) then
        validation_error ("Redefinition of element: " ^ Utf8.get_str name);
      debug_print (sprintf "Osv_parser: registering ELEMENT %s"
        (Utf8.get_str name));
      let elt_decl_ref = self#resolve_elt ~fix_ns:false ~now:false name in
      elt_decl_ref := decl

    method register_att name decl =
      debug_print "lazy_resolver.register_att";
      let name = self#qualify_name name in
      if Hashtbl.mem attrs name then
        validation_error ("Redefinition of attribute: " ^ Utf8.get_str name);
      debug_print (sprintf "Osv_parser: registering ATTRIBUTE %s"
        (Utf8.get_str name));
      Hashtbl.replace attrs name decl

    method register_att_group name def =
      debug_print "lazy_resolver.register_att_group";
      let name = self#qualify_name name in
      if Hashtbl.mem attr_groups name then
        validation_error ("Redefinition of attribute group: " ^
          Utf8.get_str name);
      debug_print (sprintf "Osv_parser: registering ATTRIBUTE GROUP %s"
        (Utf8.get_str name));
      Hashtbl.replace attr_groups name def

    method register_model_group name def =
      debug_print "lazy_resolver.register_model_group";
      let name = self#qualify_name name in
      if Hashtbl.mem model_groups name then
        validation_error ("Redefinition of model group: " ^ Utf8.get_str name);
      debug_print (sprintf "Osv_parser: registering MODEL GROUP %s"
        (Utf8.get_str name));
      Hashtbl.replace model_groups name def

      (** entities lookup *)

    method resolve_typ ?(fix_ns = true) ~now name =
      debug_print "lazy_resolver.resolve_typ";
      let name = if fix_ns then self#fix_namespace name else name in
      try
        Hashtbl.find typs name
      with Not_found ->
        let type_def =
          if now then (* resolve now: look for global type definitions *)
            let type_node =
              try
                self#find_global_component
                  (fun tag ->
                    (tag = "xsd:simpleType") || (tag = "xsd:complexType"))
                  name
              with Not_found ->
                validation_error ("Can't find definition of type: " ^
                  Utf8.get_str name)
            in
            if _tag_name type_node = Utf8.mk "xsd:simpleType" then
              Simple (parse_simple_type (self :> resolver) type_node)
            else  (* _tag_name type_node = "xsd:complexType" *)
              Complex (parse_complex_type (self :> resolver) type_node)
          else  (* resolve later: return a fake type ref *)
            fake_type_def
        in
        let type_def_ref = ref type_def in
        Hashtbl.replace typs name type_def_ref;
        type_def_ref

    method resolve_simple_typ ?(fix_ns = true) name =
      match !(self#resolve_typ ~fix_ns ~now:true name) with
      | AnyType -> Primitive (Utf8.mk "xsd:anySimpleType")
      | Simple st -> st
      | Complex _ -> assert false

    method resolve_elt ?(fix_ns = true) ~now name =
      debug_print "lazy_resolver.resolve_elt";
      let name = if fix_ns then self#fix_namespace name else name in
      try
        Hashtbl.find elts name
      with Not_found ->
        let elt_decl =
          if now then (* resolve now: look for global element declarations *)
            let elt_node =
              try
                self#find_global_component ((=) "xsd:element") name
              with Not_found ->
                validation_error ("Can't find declaration of element: " ^
                  Utf8.get_str name)
            in
            parse_elt_decl (self :> resolver) elt_node
          else  (* resolve later: return a fake element declaration *)
            fake_elt_decl
        in
        let elt_decl_ref = ref elt_decl in
        Hashtbl.replace elts name elt_decl_ref;
        elt_decl_ref

    method resolve_att ?(fix_ns = true) name =
      debug_print "lazy_resolver.resolve_att";
      let name = if fix_ns then self#fix_namespace name else name in
      try
        Hashtbl.find attrs name
      with Not_found ->
        let node =
          try
            self#find_global_component ((=) "xsd:attribute") name
          with Not_found ->
            validation_error ("Can't find declaration of attribute: " ^
              Utf8.get_str name)
        in
        let att_decl = parse_att_decl (self :> resolver) node in
        Hashtbl.replace attrs name att_decl;
        att_decl

    method resolve_att_group ?(fix_ns = true) name =
      debug_print "lazy_resolver.resolve_att_group";
      let name = if fix_ns then self#fix_namespace name else name in
      try
        Hashtbl.find attr_groups name
      with Not_found ->
        let node =
          try
            self#find_global_component ((=) "xsd:attributeGroup") name
          with Not_found ->
            validation_error
              ("Can't find definition of attribute group: " ^ Utf8.get_str name)
        in
        let att_group_decl = parse_att_group (self :> resolver) node in
        Hashtbl.replace attr_groups name att_group_decl;
        att_group_decl

    method resolve_model_group ?(fix_ns = true) name =
      debug_print "lazy_resolver.resolve_model_group";
      let name = if fix_ns then self#fix_namespace name else name in
      try
        Hashtbl.find model_groups name
      with Not_found ->
        let node =
          try
            self#find_global_component ((=) "xsd:group") name
          with Not_found ->
            validation_error
              ("Can't find definition of model group: " ^ Utf8.get_str name)
        in
        let model_group = parse_model_group_def (self :> resolver) node in
        Hashtbl.replace model_groups name model_group;
        model_group

      (** acces to registered global entities *)

    method elt_decls = hashtbl_values (hashtbl_deref elts)
    method type_defs = hashtbl_values (hashtbl_deref typs)
    method att_decls = hashtbl_values attrs
    method att_groups = hashtbl_values attr_groups
    method model_groups = hashtbl_values model_groups

  end

  (** {2 module's interface implementation} *)

let schema_of_node root =
  let resolver = new lazy_resolver root in
  let resolver' = (resolver :> resolver) in
  root#iter_nodes (fun n ->
    if not (resolver#already_seen n) then
      match n#node_type with
      | T_element "xsd:element" ->
          let name = _attribute "name" n in
          resolver#register_elt name (parse_elt_decl resolver' n)
      | T_element "xsd:simpleType" ->
          let name = _attribute "name" n in
          resolver#register_typ name (Simple (parse_simple_type resolver' n))
      | T_element "xsd:complexType" ->
          let name = _attribute "name" n in
          resolver#register_typ name (Complex (parse_complex_type resolver' n))
      | T_element "xsd:attribute" ->
          let name = _attribute "name" n in
          resolver#register_att name (parse_att_decl resolver' n)
      | T_element "xsd:attributeGroup" ->
          let name = _attribute "name" n in
          resolver#register_att_group name (parse_att_group resolver' n)
      | T_element "xsd:group" ->
          let name = _attribute "name" n in
          resolver#register_model_group name (parse_model_group_def resolver' n)
      | _ -> ());
  {
    targetNamespace = resolver#targetNamespace;
    types = resolver#type_defs;
    attributes = resolver#att_decls;
    elements = resolver#elt_decls;
    attribute_groups = resolver#att_groups;
    model_groups = resolver#model_groups
  }

let parse_schema source =
  let config =
    { new_xsd_config () with Pxp_types.enable_namespace_info = true }
  in
  let schema = schema_of_node (pxp_node_of ~config source) in
  debug_print "parse_schema completed successfully";
  schema

let schema_of_file fname = parse_schema (Pxp_types.from_file fname)

let schema_of_string s = parse_schema (Pxp_types.from_string s)

