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

Original author: afrisch
Date: 2004-10-19 16:07:52+00:00

Makefile.distrib

@@ -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 \

schema/schema_components.ml

+(** 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

schema/schema_import.ml

+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