Commit 7ef3399f authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-10-19 16:07:51 by afrisch] Beginning pf schema reimplem

Original author: afrisch
Date: 2004-10-19 16:07:52+00:00
parent f966b782
......@@ -135,6 +135,7 @@ CLEAN_DIRS = $(DIRS) cdo2cmo tools tests
# Objects to build
SCHEMA_OBJS = \
schema/schema_components.cmo schema/schema_import.cmo \
schema/schema_types.cmo \
schema/schema_xml.cmo \
schema/schema_common.cmo \
......
(** Components of XML Schema
Reference: http://www.w3.org/TR/xmlschema-1/
*)
open Ns
type xs_nonNegativeInteger = Big_int.big_int
type white_space_handling = [ `Preserve | `Replace | `Collapse ]
type facets = {
length: (xs_nonNegativeInteger * bool) option; (* length, fixed *)
minLength: (xs_nonNegativeInteger * bool) option; (* length, fixed *)
maxLength: (xs_nonNegativeInteger * bool) option; (* length, fixed *)
enumeration: Value.ValueSet.t option;
whiteSpace: white_space_handling * bool; (* handling, fixed *)
maxInclusive: (Value.t * bool) option; (* max, fixed *)
maxExclusive: (Value.t * bool) option; (* max, fixed *)
minInclusive: (Value.t * bool) option; (* min, fixed *)
minExclusive: (Value.t * bool) option; (* min, fixed *)
}
type value_constraint =
| No_constraint
| Default of string
| Fixed of string
type attribute_declaration = {
ad_name: qname;
ad_type: simple_type_definition ref;
ad_cstr: value_constraint;
}
and element_declaration = {
ed_name: qname;
ed_type: type_definition;
ed_cstr: value_constraint;
ed_nillable: bool;
}
and complex_type_definition = {
xt_name: qname;
xt_base: type_definition;
xt_derivation: derivation_method;
xt_attrs: attribute_use list;
xt_wild: ns_wildcard option;
xt_ct: content_type;
}
and simple_type_definition = {
st_name: qname option;
st_variety: variety;
}
and attribute_use = {
au_required: bool;
au_decl: attribute_declaration;
au_cstr: value_constraint;
}
and attribute_group_definition = {
ag_name: qname;
ag_attrs: attribute_use list;
ag_wild: ns_wildcard option;
}
and model_group_definition = {
mg_name: qname;
mg_model: model_group
}
and particle = {
p_min: Big_int.big_int;
p_max: Big_int.big_int option;
p_term: term;
}
and wildcard = {
wc_ns: ns_wildcard;
wc_process: [ `Skip | `Lax | `Strict ]
}
and schema = {
sch_types: type_definition list;
sch_attributes: attribute_declaration list;
sch_elements: element_declaration list;
sch_att_groups: attribute_group_definition list;
sch_model_groups: model_group_definition list
}
and type_definition =
| Simple of simple_type_definition
| Complex of complex_type_definition
and term =
| Model_group of model_group
| Wildcard of wildcard
| Element of element_declaration
and model_group =
| All of particle list
| Choice of particle list
| Sequence of particle list
and derivation_method =
| Extension
| Restriction
and content_type =
| Ct_empty
| Ct_simple of simple_type_definition
| Ct_model of particle * mixed
and mixed =
| Mixed
| Element_only
and ns_wildcard =
| Aw_any
| Aw_ns of Ns.t list
| Aw_not of Ns.t
and variety =
| Restriction of simple_type_definition ref * facets
| List of simple_type_definition ref
| Union of simple_type_definition ref list
open Schema_components
open Encodings
type xml_node = {
ns_bindings: ns_bindings;
tag : string;
attrs : (string * string) list;
children : xml_node list
}
and ns_bindings = (string * Ns.t) list
type env = {
target_ns : Ns.t;
}
let empty_facets =
{ length = None;
minLength = None;
maxLength = None;
enumeration = None;
whiteSpace = `Preserve, false;
maxInclusive = None;
maxExclusive = None;
minInclusive = None;
minExclusive = None }
let rec simple_ur_type =
{ st_name = None;
st_variety = Union [] }
let simple_ur_type_ref = ref simple_ur_type
let mk_qname (env,s) = (env.target_ns, Utf8.mk s)
let mk_qname_option a = Some (mk_qname a)
let resolve_qname n s =
(* todo ! *)
s
let resolve_qnames n slist =
(* todo ! *)
[]
let need_attribute attr _ =
failwith ("Missing attribute " ^ attr)
let error msg _ =
failwith ("Error: " ^ msg)
let norm_attr attr found notfound ((env,n) as arg) =
try
let v = List.assoc attr n.attrs in
let v = (* normalize *) v in
found (env,v)
with Not_found -> notfound arg
let qname_attr attr found notfound ((env,n) as arg) =
norm_attr attr
(fun (env,v) -> found (env,resolve_qname n v))
notfound arg
let child tag found notfound ((env,n) as arg) =
try
let n = List.find (fun n -> n.tag = tag) n.children in
found (env,n)
with Not_found -> notfound arg
let children tag found ((env,n) as arg) =
let c = List.filter (fun n -> n.tag = tag) n.children in
List.map (fun n -> found (env,n)) c
let qnames_attr attr found notfound ((env,n) as arg) =
norm_attr attr
(fun (env,v) -> found (env,resolve_qnames n v))
notfound arg
let cst x _ = x
let rec global_attribute_declaration arg =
{ ad_name =
norm_attr "name"
mk_qname
(need_attribute "name")
arg;
ad_type =
child "simpleType"
simple_type
(qname_attr "type"
resolve_simple_type
(cst simple_ur_type_ref))
arg;
ad_cstr =
norm_attr "default"
(fun (_,s) -> Default s)
(norm_attr "fixed"
(fun (_,s) -> Fixed s)
(cst No_constraint))
arg
}
and simple_type arg =
let name = norm_attr "name" mk_qname_option (cst None) arg in
let v =
child "restriction" restriction
(child "list" list
(child "union" union
(error "Need simple type"))) arg in
ref
{ st_name = name;
st_variety = v }
and restriction arg =
let base =
qname_attr "base"
resolve_simple_type
(child "simpleType" simple_type
(error "Need simple type")) arg in
Restriction (base,empty_facets)
and list arg =
let item_type =
qname_attr "itemType"
resolve_simple_type
(child "simpleType" simple_type
(error "Need simple type")) arg in
List item_type
and union arg =
let member_types =
qnames_attr "itemType"
resolve_simple_types
(children "simpleType" simple_type) arg in
Union member_types
and resolve_simple_type arg = assert false
and resolve_simple_types (env,args) =
List.map (fun a -> resolve_simple_type (env,a)) args
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment