Commit c272c7ec authored by Pietro Abate's avatar Pietro Abate

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

Original author: afrisch
Date: 2005-02-18 17:36:35+00:00
parent 6a14fe70
......@@ -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
......
......@@ -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
......
......@@ -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 ->
......
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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"
......
......@@ -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} *)
......
This diff is collapsed.
......@@ -45,9 +45,9 @@ and value_constraint = [ `Fixed of value_ref | `Default of value_ref ]
and type_ref = type_definition ref
and simple_type_definition =
| Primitive of Utf8.t
| Primitive of Ns.qname
| Derived of
Utf8.t option * (* name *)
Ns.qname option * (* name *)
variety *
facets *
type_ref (* base *)
......@@ -60,7 +60,7 @@ and variety =
| Restrict
and attribute_declaration =
{ attr_name : Utf8.t;
{ attr_name : Ns.qname;
attr_typdef : type_ref;
attr_cstr : value_constraint option }
......@@ -71,7 +71,7 @@ and attribute_use =
(* first construction as per predictive parsing. None stands for epsilon, Some
* Utf8.t stands for a start tag of identical name *)
and first = Utf8.t option list
and first = Ns.QName.t option list
and term =
| Elt of element_declaration ref
......@@ -97,13 +97,13 @@ and particle =
and element_declaration =
{ elt_uid: int;
elt_name: Utf8.t;
elt_name: Ns.qname;
elt_typdef: type_ref;
elt_cstr: value_constraint option }
and complex_type_definition =
{ ct_uid: int;
ct_name: Utf8.t option;
ct_name: Ns.qname option;
ct_typdef: type_definition;
ct_deriv: derivation_type;
ct_attrs: attribute_use list;
......@@ -115,11 +115,11 @@ and type_definition =
| Complex of complex_type_definition
type model_group_definition =
{ mg_name : Utf8.t;
{ mg_name : Ns.qname;
mg_def : model_group }
type attribute_group_definition =
{ ag_name : Utf8.t;
{ ag_name : Ns.qname;
ag_def : attribute_use list }
type schema = {
......
......@@ -45,9 +45,9 @@ and value_constraint = [ `Fixed of value_ref | `Default of value_ref ]
and type_ref = type_definition ref
and simple_type_definition =
| Primitive of Utf8.t
| Primitive of Ns.qname
| Derived of
Utf8.t option * (* name *)
Ns.qname option * (* name *)
variety *
facets *
type_ref (* base *)
......@@ -60,7 +60,7 @@ and variety =
| Restrict
and attribute_declaration =
{ attr_name : Utf8.t;
{ attr_name : Ns.qname;
attr_typdef : type_ref;
attr_cstr : value_constraint option }
......@@ -71,7 +71,7 @@ and attribute_use =
(* first construction as per predictive parsing. None stands for epsilon, Some
* Utf8.t stands for a start tag of identical name *)
and first = Utf8.t option list
and first = Ns.QName.t option list
and term =
| Elt of element_declaration ref
......@@ -97,13 +97,13 @@ and particle =
and element_declaration =
{ elt_uid: int;
elt_name: Utf8.t;
elt_name: Ns.qname;
elt_typdef: type_ref;
elt_cstr: value_constraint option }
and complex_type_definition =
{ ct_uid: int;
ct_name: Utf8.t option;
ct_name: Ns.qname option;
ct_typdef: type_definition;
ct_deriv: derivation_type;
ct_attrs: attribute_use list;
......@@ -115,11 +115,11 @@ and type_definition =
| Complex of complex_type_definition
type model_group_definition =
{ mg_name : Utf8.t;
{ mg_name : Ns.qname;
mg_def : model_group }
type attribute_group_definition =
{ ag_name : Utf8.t;
{ ag_name : Ns.qname;
ag_def : attribute_use list }
type schema = {
......
......@@ -8,6 +8,8 @@ open Schema_common
open Schema_types
open Value
module QTable = Hashtbl.Make(Ns.QName)
(** {2 Misc} *)
let empty_string = string_utf8 (Utf8.mk "")
......@@ -15,8 +17,8 @@ let empty_record = Value.vrecord []
let foo_atom = Value.Atom (Atoms.V.mk_ascii "foo")
let foo_event = E_char_data (Utf8.mk "")
let hashtbl_is_empty tbl =
try Hashtbl.iter (fun _ _ -> raise Exit) tbl; true
let qtable_is_empty tbl =
try QTable.iter (fun _ _ -> raise Exit) tbl; true
with Exit -> false
let string_of_value value =
......@@ -28,12 +30,12 @@ let string_of_value value =
let foo_qname = Ns.empty, Utf8.mk ""
let ptbl_of_particles particles =
let tbl = Hashtbl.create 20 in
let tbl = QTable.create 20 in
List.iter (* fill table *)
(* ASSUMPTION: firsts are disjoing as per UPA Schema constraint *)
(fun p ->
List.iter
(function None -> () | Some tag -> Hashtbl.add tbl tag p)
(function None -> () | Some tag -> QTable.add tbl tag p)
(first_of_particle p))
particles;
tbl
......@@ -42,8 +44,8 @@ let ptbl_of_particles particles =
class type validation_context =
object
(* if ns isn't given, targetNamespace of the schema is used *)
method expect_start_tag: ?ns:Ns.t -> Utf8.t -> unit
method expect_end_tag: ?ns:Ns.t -> Utf8.t -> unit
method expect_start_tag: Ns.qname -> unit
method expect_end_tag: Ns.qname -> unit
method expect_any_start_tag: Ns.qname
method expect_any_end_tag: Ns.qname
method get_string: Utf8.t
......@@ -53,7 +55,9 @@ class type validation_context =
method set_mixed: bool -> unit
method mixed: bool
(*
method ns: Ns.t
*)
end
let validation_error ?context s = raise (XSI_validation_error s)
......@@ -187,7 +191,7 @@ let rec validate_simple_type def v =
Schema_builtin.validate_builtin name s
with Schema_builtin.Schema_builtin_error name ->
validation_error (sprintf "%s isn't a valid %s"
(Utf8.to_string s) (Utf8.to_string name)))
(Utf8.to_string s) name))
| Primitive _ -> assert false
| Derived (_, Atomic primitive, facets, base) ->
let literal = normalize_white_space (fst facets.whiteSpace) s in
......@@ -231,13 +235,13 @@ let rec validate_any_type (context: validation_context) =
let cont = ref [] in
let rec aux () =
match context#peek with
| E_start_tag (ns, name) ->
| E_start_tag qname ->
context#junk;
let (attrs, content) = validate_any_type context in
let element =
Value.Xml (Value.Atom (Atoms.V.mk ns name), attrs, content)
Value.Xml (Value.Atom (Atoms.V.of_qname qname), attrs, content)
in
context#expect_end_tag ~ns name;
context#expect_end_tag qname;
cont := element :: !cont;
aux ()
| E_end_tag _ -> (Value.vrecord !attrs, Value.sequence (List.rev !cont))
......@@ -257,10 +261,11 @@ let check_fixed ~context fixed value =
validation_error ~context (sprintf "Expected fixed value: %s; found %s"
(string_of_value fixed) (string_of_value value))
let validate_attribute_uses context attr_uses =
let tbl = Hashtbl.create 11 in
let tbl = QTable.create 11 in
List.iter
(fun use -> Hashtbl.add tbl (Ns.empty, name_of_attribute_use use) use)
(fun use -> QTable.add tbl (name_of_attribute_use use) use)
attr_uses;
let attrs = ref [] in
let rec aux () = (* look for attribute events and fill "attrs" *)
......@@ -268,8 +273,7 @@ let validate_attribute_uses context attr_uses =
| E_attribute (qname, value) ->
let { attr_decl = { attr_typdef = st_def };