[r2005-02-18 17:36:34 by afrisch] Schema and namespaces

Original author: afrisch
Date: 2005-02-18 17:36:35+00:00

compile/lambda.ml

@@ -56,7 +56,7 @@ type expr =
   | Transform of expr * branches
   | Xtrans of expr * branches
   | Try of expr * branches
-  | Validate of expr * schema_component_kind * string * U.t
+  | Validate of expr * schema_component_kind * string * Ns.qname
   | RemoveField of expr * label
   | Dot of expr * label
   | Ref of expr * Types.Node.t
@@ -191,7 +191,7 @@ module Put = struct
 	expr s e;
 	serialize_schema_component_kind s k;
 	string s sch;
-	U.serialize s t
+	Ns.QName.serialize s t
 (*	assert false (* TODO:Need to store a pointer to the schema ... *) *)
     | RemoveField (e,l) ->
 	bits nbits s 14;
@@ -315,7 +315,7 @@ module Get = struct
 	  let e = expr s in
 	  let k = deserialize_schema_component_kind s in
 	  let sch = string s in
-	  let t = U.deserialize s in
+	  let t = Ns.QName.deserialize s in
 	  Validate (e,k,sch,t)
       | 14 ->
 	  let e = expr s in

compile/lambda.mli

@@ -29,7 +29,7 @@ type expr =
   | Transform of expr * branches
   | Xtrans of expr * branches
   | Try of expr * branches
-  | Validate of expr * schema_component_kind * string * U.t
+  | Validate of expr * schema_component_kind * string * Ns.qname
   | RemoveField of expr * label
   | Dot of expr * label
   | Ref of expr * Types.Node.t

driver/cduce.ml

@@ -258,8 +258,9 @@ let directive ppf tenv cenv = function
       Typer.dump_type ppf tenv name;
       flush_ppf ppf
   | `Print_schema_type schema_ref ->
-      Typer.dump_schema_type ppf tenv schema_ref;
-      flush_ppf ppf
+      assert false
+(*      Typer.dump_schema_type ppf tenv schema_ref;
+      flush_ppf ppf *)
   | `Reinit_ns ->
       Typer.set_ns_table_for_printer tenv
   | `Help ->

misc/ns.ml

@@ -21,6 +21,10 @@ module P = Pool.Make(U)
 include P
 let empty = mk empty_str
 let xml_ns = mk (U.mk "http://www.w3.org/XML/1998/namespace")
+let xsd_ns = mk (U.mk "http://www.w3.org/2001/XMLSchema")
+let xsi_ns = mk (U.mk "http://www.w3.org/2001/XMLSchema-instance")
+
+
 let mk_ascii s = mk (U.mk s)
 
 module Table = Map.Make(U)
@@ -52,7 +56,11 @@ let deserialize_table s =
 let global_hints = State.ref "Ns.prefixes" (Hashtbl.create 63)
 
 let empty_table =
-  Table.add empty_str empty (Table.add (U.mk "xml") xml_ns Table.empty)
+  List.fold_left
+    (fun table (pr,ns) -> Table.add (U.mk pr) ns table)
+    Table.empty
+    ["", empty; "xml", xml_ns; "xsd", xsd_ns; "xsi", xsi_ns]
+     
 let add_prefix pr ns table =
   if (U.get_str pr <> "") then Hashtbl.add !global_hints ns pr;
   Table.add pr ns table

schema/schema_builtin.ml

@@ -12,7 +12,8 @@ open Schema_types
 
   (** {2 Aux/Misc stuff} *)
 
-let add_xsd_prefix s = Utf8.mk ("xsd:"^s)
+let xsd = Schema_xml.xsd
+let add_xsd_prefix s = (xsd, Utf8.mk s)
 
 let unsupported =
   List.map (fun s -> add_xsd_prefix s)
@@ -50,8 +51,8 @@ let char_of_hex =
 let strip_parens s = Pcre.replace ~pat:"[()]" s
 let add_limits s = "^" ^ s ^ "$"
 
-exception Schema_builtin_error of Utf8.t
-let simple_type_error name = raise (Schema_builtin_error (add_xsd_prefix name))
+exception Schema_builtin_error of string
+let simple_type_error name = raise (Schema_builtin_error name)
 
 let qualify s = (Ns.empty, Encodings.Utf8.mk s)
 
@@ -402,12 +403,14 @@ let validate_anyURI s =
 
   (** {2 API backend} *)
 
-let builtins = Hashtbl.create 50
-let reg name spec = Hashtbl.add builtins (add_xsd_prefix name) spec
+module QTable = Hashtbl.Make(Ns.QName)
+
+let builtins = QTable.create 50
+let reg name spec = QTable.add builtins (add_xsd_prefix name) spec
 let alias alias name =
   let (alias, name) = (add_xsd_prefix alias, add_xsd_prefix name) in
-  Hashtbl.add builtins alias
-    (let (st_def, descr, validator) = Hashtbl.find builtins name in
+  QTable.add builtins alias
+    (let (st_def, descr, validator) = QTable.find builtins name in
     let new_def =
       match st_def with
       | Primitive _ -> Primitive alias
@@ -417,7 +420,7 @@ let alias alias name =
     (new_def, descr, validator))
 let restrict' name basename new_facets =
   let (name, basename) = (add_xsd_prefix name, add_xsd_prefix basename) in
-  let (base, _, _) = Hashtbl.find builtins basename in
+  let (base, _, _) = QTable.find builtins basename in
   let variety = variety_of_simple_type_definition base in
   let facets =
     merge_facets (facets_of_simple_type_definition base) new_facets
@@ -425,7 +428,7 @@ let restrict' name basename new_facets =
   Derived (Some name, variety, facets, ref (Simple base))
 let list' name itemname =
   let (name, itemname) = (add_xsd_prefix name, add_xsd_prefix itemname) in
-  let (base, _, _) = Hashtbl.find builtins itemname in
+  let (base, _, _) = QTable.find builtins itemname in
   let base = ref (Simple base) in
   Derived (Some name, List base, no_facets, base)
 
@@ -563,7 +566,7 @@ let null_value = {
 }
 
 let string_of_time_type fields =
-  let fail () = raise (Schema_builtin_error (Utf8.mk "")) in
+  let fail () = raise (Schema_builtin_error "") in
   let parse_int = function Value.Integer i -> i | _ -> fail () in
   let parse_timezone v =
     let fields =
@@ -694,11 +697,11 @@ let string_of_time_type fields =
 
   (** {2 API} *)
 
-let is_builtin = Hashtbl.mem builtins
+let is_builtin = QTable.mem builtins
 let iter_builtin f =
-  Hashtbl.iter (fun _ (type_def, _, _) -> f type_def) builtins
+  QTable.iter (fun _ (type_def, _, _) -> f type_def) builtins
 
-let lookup name = Hashtbl.find builtins name
+let lookup name = QTable.find builtins name
 
 let fst (x,_,_) = x
 let snd (_,y,_) = y

schema/schema_builtin.mli

@@ -3,13 +3,13 @@ open Encodings
 (** all schema simple type names used in this API are prefixed with
  * Schema_xml.xsd_prefix *)
 
-exception Schema_builtin_error of Utf8.t
+exception Schema_builtin_error of string
 
-val is_builtin: Utf8.t -> bool
-val get_builtin: Utf8.t -> Schema_types.simple_type_definition
+val is_builtin: Ns.QName.t -> bool
+val get_builtin: Ns.QName.t -> Schema_types.simple_type_definition
 val iter_builtin: (Schema_types.simple_type_definition -> unit) -> unit
 
-val cd_type_of_builtin: Utf8.t -> Types.descr
+val cd_type_of_builtin: Ns.QName.t -> Types.descr
 
   (** validate_builtin <builtin> <string>
    * validates <string> against builtin type <builtin> and return the resulting
@@ -17,7 +17,7 @@ val cd_type_of_builtin: Utf8.t -> Types.descr
    * @raise Schema_builtin_error [name] in case of validation error, where
    * [name] is the name of a schema built in type prefixed with
    * Schema_xml.xsd_prefix *)
-val validate_builtin: Utf8.t -> Utf8.t -> Value.t
+val validate_builtin: Ns.QName.t -> Utf8.t -> Value.t
 
 val string_of_time_type: (Ns.qname * Value.t) list -> Utf8.t
 

schema/schema_common.ml

@@ -4,6 +4,8 @@ open Encodings
 open Schema_pcre
 open Schema_types
 
+let xsd = Schema_xml.xsd
+
 let no_facets = {
   length = None;
   minLength = None;
@@ -71,7 +73,7 @@ let rec variety_of_simple_type_definition = function
 
 let get_simple_type = function
   | { contents = Simple c } -> c
-  | { contents = AnyType } -> Primitive (Utf8.mk "xsd:anySimpleType")
+  | { contents = AnyType } -> Primitive (xsd,Utf8.mk "anySimpleType")
   | _ -> assert false
 
 let rec normalize_simple_type = function
@@ -93,7 +95,7 @@ let name_of_complex_type_definition = function
   | { ct_name = Some name } -> name
   | _ -> raise (Invalid_argument "anonymous complex type definition")
 let name_of_type_definition = function
-  | AnyType -> Encodings.Utf8.mk "xsd:anyType"
+  | 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
@@ -141,7 +143,7 @@ let rec normalize_white_space =
       in
       pcre_replace ~rex:margins_RE ~templ:(Utf8.mk "$1") s'
 
-let anySimpleType = Primitive (Encodings.Utf8.mk "xsd:anySimpleType")
+let anySimpleType = Primitive (xsd, Utf8.mk "anySimpleType")
 let anyType = AnyType
 
 let first_of_particle (_, _, _, first) = first
@@ -158,7 +160,7 @@ let first_of_model_group = function
       aux particles
 let rec is_in_first tag = function
   | [] -> false
-  | Some tag' :: rest when Utf8.equal tag' tag -> true
+  | Some tag' :: rest when Ns.QName.equal tag' tag -> true
   | _ :: rest -> is_in_first tag rest
 
 let get_interval facets =
@@ -191,13 +193,13 @@ let get_interval facets =
 
 
 let print_simple_type fmt = function
-  | Primitive name -> Format.fprintf fmt "%a" Encodings.Utf8.dump name
+  | Primitive name -> Format.fprintf fmt "%a" Ns.QName.print name
   | Derived (Some name, _, _, _) ->
-      Format.fprintf fmt "%a'" Encodings.Utf8.dump name
-  | Derived (None, _, _, _) -> Format.fprintf fmt "unnamed'"
+      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 Encodings.Utf8.dump 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
@@ -205,20 +207,20 @@ let print_type fmt = function
   | Simple t -> Format.fprintf fmt "S:%a" print_simple_type t
   | Complex t -> Format.fprintf fmt "C:%a" print_complex_type t
 let print_attribute fmt { attr_name = name; attr_typdef = t } =
-  Format.fprintf fmt "@@%a:%a" Utf8.dump name print_simple_type 
+  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 Utf8.dump 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}" Utf8.dump ag.ag_name
+  Format.fprintf fmt "{agroup:%a}" Ns.QName.print ag.ag_name
 let print_model_group fmt mg =
-  Format.fprintf fmt "{mgroup:%a}" Utf8.dump mg.mg_name
+  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 def -> not (Schema_xml.has_xsd_prefix (name_of_type_definition def)))
-      schema.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: ";
@@ -252,41 +254,29 @@ let print_schema fmt schema =
   end
 
 
-let get_type name schema =
+let get_qual name table get_name =
   List.find
     (fun x ->
-      try
-        name_of_type_definition x = name
+      try Ns.QName.equal (get_name x) name
       with Invalid_argument _ -> false)
-    schema.types
-let get_attribute name schema =
+    table
+let get_unqual name table get_name =
   List.find
     (fun x ->
-      try
-        name_of_attribute_declaration x = name
+      try Utf8.equal (snd (get_name x)) name
       with Invalid_argument _ -> false)
-    schema.attributes
+    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 =
-  List.find
-    (fun x ->
-      try
-        name_of_element_declaration x = name
-      with Invalid_argument _ -> false)
-    schema.elements
+  get_qual name schema.elements name_of_element_declaration
 let get_attribute_group name schema =
-  List.find
-    (fun x ->
-      try
-        name_of_attribute_group_definition x = name
-      with Invalid_argument _ -> false)
-    schema.attribute_groups
+  get_qual name schema.attribute_groups name_of_attribute_group_definition
 let get_model_group name schema =
-  List.find
-    (fun x ->
-      try
-        name_of_model_group_definition x = name
-      with Invalid_argument _ -> false)
-    schema.model_groups
+  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 *)
@@ -308,6 +298,37 @@ let get_component kind name schema =
   | 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"

schema/schema_common.mli

@@ -25,15 +25,15 @@ val print_complex_type : Format.formatter -> complex_type_definition -> unit
 
 val get_simple_type: type_ref -> simple_type_definition
 
-val name_of_element_declaration : element_declaration -> Utf8.t
-val name_of_type_definition : type_definition -> Utf8.t
-val name_of_simple_type_definition : simple_type_definition -> Utf8.t
-val name_of_complex_type_definition : complex_type_definition -> Utf8.t
-val name_of_attribute_declaration : attribute_declaration -> Utf8.t
-val name_of_attribute_use : attribute_use -> Utf8.t
-val name_of_attribute_group_definition : attribute_group_definition -> Utf8.t
-val name_of_model_group_definition : model_group_definition -> Utf8.t
-val name_of_particle : particle -> Utf8.t
+val name_of_element_declaration : element_declaration -> Ns.qname
+val name_of_type_definition : type_definition -> Ns.qname
+val name_of_simple_type_definition : simple_type_definition -> Ns.qname
+val name_of_complex_type_definition : complex_type_definition -> Ns.qname
+val name_of_attribute_declaration : attribute_declaration -> Ns.qname
+val name_of_attribute_use : attribute_use -> Ns.qname
+val name_of_attribute_group_definition : attribute_group_definition -> Ns.qname
+val name_of_model_group_definition : model_group_definition -> Ns.qname
+val name_of_particle : particle -> Ns.qname
 
 val string_of_component_kind : component_kind -> string
 
@@ -43,13 +43,16 @@ val simple_type_of_type : type_definition -> simple_type_definition
 val complex_type_of_type : type_definition -> complex_type_definition
 val content_type_of_type : type_definition -> content_type
 
-val get_type: Utf8.t -> schema -> type_definition
-val get_attribute: Utf8.t -> schema -> attribute_declaration
-val get_element: Utf8.t -> schema -> element_declaration
-val get_attribute_group: Utf8.t -> schema -> attribute_group_definition
-val get_model_group: Utf8.t -> schema -> model_group_definition
+(*
+val get_type: Ns.qname -> schema -> type_definition
+val get_attribute: Ns.qname -> schema -> attribute_declaration
+val get_element: Ns.qname -> schema -> element_declaration
+val get_attribute_group: Ns.qname -> schema -> attribute_group_definition
+val get_model_group: Ns.qname -> schema -> model_group_definition
+*)
 
-val get_component: component_kind -> Utf8.t -> schema -> component
+val get_component: component_kind -> Ns.qname -> schema -> component
+val get_unqual_component: component_kind -> Utf8.t -> schema -> component
 
 val iter_types: schema -> (type_definition -> unit) -> unit
 val iter_attributes: schema -> (attribute_declaration -> unit) -> unit
@@ -60,7 +63,7 @@ val iter_model_groups: schema -> (model_group_definition -> unit) -> unit
 
 val first_of_particle: particle -> first
 val first_of_model_group: model_group -> first
-val is_in_first: Utf8.t -> first -> bool
+val is_in_first: Ns.qname -> first -> bool
 val nullable: particle -> bool
 
 (** {2 Facets} *)

schema/schema_parser.ml

@@ -7,19 +7,23 @@ open Schema_types
 open Schema_validator
 open Schema_xml
 
+module QTable = Hashtbl.Make(Ns.QName)
+
 let validation_error s = raise (XSD_validation_error s)
 
+let xsd = Schema_xml.xsd
+
 let fake_type_def =
   Complex 
     { ct_uid = -1;
-      ct_name = Some (Utf8.mk "   FAKE TYP   ");
+      ct_name = Some (xsd, Utf8.mk "   FAKE TYP   ");
       ct_typdef = AnyType;
       ct_deriv = `Restriction;
       ct_attrs = [];
       ct_content = CT_empty }
 let fake_elt_decl = 
   { elt_uid = -2;
-    elt_name = Utf8.mk "   FAKE ELT   ";
+    elt_name = (xsd, Utf8.mk "   FAKE ELT   ");
     elt_typdef = ref fake_type_def;
     elt_cstr =  None }
 let is_fake_type_def = (==) fake_type_def
@@ -52,14 +56,14 @@ let split s = pcre_split ~rex:space_RE s
 
 let unqualify s = snd (Ns.split_qname s)
 
-let hashtbl_deref tbl =  Hashtbl.fold (fun _ v acc -> !v :: acc) tbl []
-let hashtbl_values tbl = Hashtbl.fold (fun _ v acc -> v :: acc) tbl []
+let hashtbl_deref tbl =  QTable.fold (fun _ v acc -> !v :: acc) tbl []
+let hashtbl_values tbl = QTable.fold (fun _ v acc -> v :: acc) tbl []
 
 let parse_facets base n =
   let validate_base_type v = 
     lazy (Schema_validator.validate_simple_type (get_simple_type base) v) in 
   let validate_nonNegativeInteger =
-    Schema_builtin.validate_builtin (Utf8.mk "xsd:nonNegativeInteger")
+    Schema_builtin.validate_builtin (xsd, Utf8.mk "nonNegativeInteger")
   in
   let aux facets n tag =
     let fixed = _is_attr "fixed" n "true" in
@@ -144,148 +148,116 @@ let find_particles n =
 let find_particle n =
   first n _may_elem ["xsd:all"; "xsd:choice"; "xsd:group"; "xsd:sequence"]
     
+
 let register_builtins typs =
   Schema_builtin.iter_builtin
     (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)
+       QTable.replace typs name (ref type_def));
+  QTable.replace typs (xsd, Utf8.mk "anyType") (ref AnyType)
 
 (* Main parsing function *)
 let schema_of_uri uri =
-  let nsman = new Pxp_dtd.namespace_manager in
-  List.iter
-    (fun (p, ns) ->nsman#add_namespace (Utf8.get_str p) (Utf8.get_str ns))
-    Schema_xml.schema_ns_prefixes;
-
-  let root = node_of_uri uri in
-
-  let orig_ns = Hashtbl.create 17 in
-  let register_ns rt = 
-    List.iter
-      (fun (prefix,uri) ->
-	 if prefix <> "" then begin
-           Hashtbl.add orig_ns prefix uri;
-           ignore (nsman#lookup_or_add_namespace prefix uri)
-	 end)
-      (_namespaces rt)
-  in
-  register_ns root;
-
-  let qualify,targetNamespace = 
-    match _may_attr "targetNamespace" root with
-      | Some ns ->
-	  let pr = nsman#lookup_or_add_namespace "target" (Utf8.get_str ns) in
-	  let pr = Utf8.mk (pr ^ ":") in
-	  (fun name -> Utf8.concat pr name),
-	  Ns.mk ns
-      | None -> 
-	  (fun name -> name), Ns.empty
-  in
-
-  let typs = Hashtbl.create 17
-  and attrs = Hashtbl.create 17
-  and elts = Hashtbl.create 17
-  and attr_groups = Hashtbl.create 17
-  and model_groups = Hashtbl.create 17 in
 
+  let typs = QTable.create 17 in
+  let elts = QTable.create 17 in
+  let attrs= QTable.create 17 in
+  let attr_groups = QTable.create 17 in
+  let model_groups = QTable.create 17 in
   register_builtins typs;
 
-  let fix_namespace s =
-    match Ns.split_qname s with
-      | "", base -> qualify base
-      | prefix, base ->
-          (try
-           let orig_uri = Hashtbl.find orig_ns prefix in
-           let new_prefix = nsman#get_normprefix orig_uri in
-           Utf8.concat (Utf8.mk (new_prefix ^ ":")) base
-         with Not_found ->
-           validation_error ("Can't resolve: " ^ Utf8.get_str s))
+  let attr_elems = QTable.create 17
+  and attr_group_elems = QTable.create 17
+  and model_group_elems = QTable.create 17 in
+
+  let resolve k t1 t2 f qname =
+    try QTable.find t1 qname
+    with Not_found ->
+      let node = 
+	try QTable.find t2 qname
+	with Not_found ->
+	  validation_error ("Can't find declaration for " ^ k ^ " " ^
+			      Ns.QName.to_string qname)
+      in
+      let decl = f node in
+      QTable.replace t1 qname decl;
+      decl
   in
+  let todo = ref [] in
 
-  let roots = ref [ ] in
 
-  let find_global_component tag_pred name err =
-    let basename = Utf8.get_str (snd (Ns.split_qname name)) in
-    let sel n = (_has_tag n tag_pred) && (_is_attr "name" n basename) in
-    let rec aux = function
-      | [] -> 
-	  validation_error ("Can't find declaration for " ^ err ^ " " ^
-			      Utf8.get_str name)
-      | hd::tl -> (try _find sel hd with Not_found -> aux tl)
+  let rec parse_uri uri =
+    let root = node_of_uri uri in
+    let targetNamespace =  
+      match _may_attr "targetNamespace" root with
+	| Some ns -> Ns.mk ns
+	| None -> Ns.empty
     in
-    aux !roots
-  in
+    let attributeFormDefault = 
+      _is_attr "attributeFormDefault" root "qualified" in
+    let elementFormDefault = 
+      _is_attr "elementFormDefault" root "qualified" in
+
+    let parse_root root =
+
+  let may_name n =
+    match _may_attr "name" n with
+      | Some local -> Some (targetNamespace,local)
+      | None -> None in
+  let get_name n = (targetNamespace, _attr "name" n) in
 
-  let rec resolve_typ name =
-    try Hashtbl.find typs (fix_namespace name)
+  let rec resolve_typ qname =
+    try QTable.find typs qname