Commit f2bb44af authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-10-20 16:31:05 by afrisch] ...

Original author: afrisch
Date: 2004-10-20 16:31:07+00:00
parent 514518e0
......@@ -135,7 +135,6 @@ 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 \
......@@ -143,6 +142,9 @@ SCHEMA_OBJS = \
schema/schema_validator.cmo \
schema/schema_parser.cmo \
NEW_SCHEMA_OBJS = \
schema/schema_components.cmo schema/schema_import.cmo \
OBJECTS = \
driver/config.cmo \
misc/stats.cmo \
......@@ -214,7 +216,7 @@ CDUCE = $(OBJECTS) driver/run.cmo $(CQL_OBJECTS_RUN)
WEBIFACE = $(OBJECTS) driver/examples.cmo driver/webiface.cmo
DTD2CDUCE = tools/dtd2cduce.cmo
ALL_OBJECTS = $(OBJECTS) \
ALL_OBJECTS = $(OBJECTS) $(NEW_SCHEMA_OBJS) \
driver/run.cmo driver/examples.cmo driver/webiface.cmo \
tools/dtd2cduce.cmo tools/validate.cmo \
$(ML_INTERFACE_OBJS) parser/cduce_curl.cmo \
......@@ -231,6 +233,11 @@ cduce: $(CDUCE:.cmo=.$(EXTENSION))
@echo "Build $@"
$(HIDE)$(LINK) $(INCLUDES) -o $@ $^ $(EXTRA_LINK_OPTS)
test_schema: $(OBJECTS:.cmo=.$(EXTENSION)) $(NEW_SCHEMA_OBJS:.cmo=.$(EXTENSION))
@echo "Build $@"
$(HIDE)$(LINK) $(INCLUDES) -o $@ $^ $(EXTRA_LINK_OPTS)
cduce_packed.ml: $(CDUCE:.cmo=.ml)
rm -f cduce_packed.ml
ocaml tools/pack.ml $^ > cduce_packed.ml
......
......@@ -80,6 +80,12 @@ runtime/value.cmo: types/atoms.cmi types/builtin_defs.cmi types/chars.cmi \
runtime/value.cmx: types/atoms.cmx types/builtin_defs.cmx types/chars.cmx \
misc/encodings.cmx types/ident.cmx types/intervals.cmx compile/lambda.cmx \
misc/ns.cmx types/sequence.cmx types/types.cmx runtime/value.cmi
schema/schema_components.cmo: misc/ns.cmi runtime/value.cmi
schema/schema_components.cmx: misc/ns.cmx runtime/value.cmx
schema/schema_import.cmo: misc/encodings.cmi misc/ns.cmi \
schema/schema_components.cmo
schema/schema_import.cmx: misc/encodings.cmx misc/ns.cmx \
schema/schema_components.cmx
schema/schema_types.cmo: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
runtime/value.cmi schema/schema_types.cmi
schema/schema_types.cmx: misc/encodings.cmx types/intervals.cmx misc/ns.cmx \
......
......@@ -5,6 +5,7 @@ struct
include Custom.String
type uindex = int
let empty = ""
(* TODO: handle UTF-8 viewport *)
let to_string s =
......
......@@ -9,6 +9,7 @@ sig
val to_string: t -> string
val print: Format.formatter -> t -> unit
val empty: t
val end_index: t -> uindex
val start_index: t -> uindex
val equal_index: uindex -> uindex -> bool
......
......@@ -2,6 +2,7 @@
Reference: http://www.w3.org/TR/xmlschema-1/
*)
open Ns
open Encodings
type xs_nonNegativeInteger = Big_int.big_int
type white_space_handling = [ `Preserve | `Replace | `Collapse ]
......@@ -19,12 +20,14 @@ type facets = {
type value_constraint =
| No_constraint
| Default of string
| Fixed of string
| Default of Utf8.t
| Fixed of Utf8.t
type 'a ptr = 'a option ref
type attribute_declaration = {
ad_name: qname;
ad_type: simple_type_definition ref;
ad_type: simple_type_definition ptr;
ad_cstr: value_constraint;
}
and element_declaration = {
......@@ -76,8 +79,8 @@ and schema = {
sch_model_groups: model_group_definition list
}
and type_definition =
| Simple of simple_type_definition
| Complex of complex_type_definition
| Simple of simple_type_definition ptr
| Complex of complex_type_definition ptr
and term =
| Model_group of model_group
| Wildcard of wildcard
......@@ -92,15 +95,15 @@ and derivation_method =
and content_type =
| Ct_empty
| Ct_simple of simple_type_definition
| Ct_model of particle * mixed
| Ct_model of mixed * particle
and mixed =
| Mixed
| Element_only
and ns_wildcard =
| Aw_any
| Aw_ns of Ns.t list
| Aw_not of Ns.t
| W_any
| W_ns of Ns.t list
| W_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
| VRestriction of simple_type_definition ptr * facets
| VList of simple_type_definition ptr
| VUnion of simple_type_definition ptr list
open Schema_components
open Encodings
module U = Utf8
let xsd = Ns.mk_ascii "http://www.w3.org/2001/XMLSchema"
let (!!) s = (xsd, U.mk s)
let (@@) s = (Ns.empty, U.mk s)
let _name = (@@) "name"
let _type = (@@) "type"
let _default = (@@) "default"
let _fixed = (@@) "fixed"
let _base = (@@) "base"
let _itemType = (@@) "itemType"
let _elementFormDefault = (@@) "elementFormDefault"
let _attributeFormDefault = (@@) "attributeFormDefault"
let _targetNamespace = (@@) "targetNamespace"
let _memberTypes = (@@) "memberTypes"
let _simpleType = (!!) "simpleType"
let _complexType = (!!) "complexType"
let _restriction = (!!) "restriction"
let _list = (!!) "list"
let _union = (!!) "union"
let _attribute = (!!) "attribute"
let _element = (!!) "element"
let _attributeGroup = (!!) "attributeGroup"
let _group = (!!) "group"
let (//) x f = f x
type xml_node = {
ns_bindings: ns_bindings;
tag : string;
attrs : (string * string) list;
ns_table: Ns.table;
tag : Ns.qname;
attrs : (Ns.qname * U.t) list;
children : xml_node list
}
and ns_bindings = (string * Ns.t) list
type env = {
target_ns : Ns.t;
attr_qual : bool;
elt_qual : bool;
type_defs : (Ns.qname * type_definition) list;
attr_decls : (Ns.qname * attribute_declaration ptr) list;
elt_decls : (Ns.qname * element_declaration ptr) list;
mg_defs : (Ns.qname * model_group_definition ptr) list;
ag_defs : (Ns.qname * attribute_group_definition ptr) list;
}
let empty_facets =
......@@ -26,16 +59,65 @@ let empty_facets =
let rec simple_ur_type =
{ st_name = None;
st_variety = Union [] }
st_variety = VUnion [] }
let ur_type_ptr = Complex (ref None)
let anyType = ref None
let () =
anyType := Some
{ xt_name = (!!) "anyType";
xt_base = Complex anyType;
xt_derivation = Restriction;
xt_attrs = [];
xt_wild = Some W_any;
xt_ct = Ct_model
(Mixed, { p_min = Big_int.unit_big_int;
p_max = Some Big_int.unit_big_int;
p_term = Model_group
(Sequence [
{ p_min = Big_int.zero_big_int;
p_max = None;
p_term = Wildcard {
wc_ns = W_any;
wc_process = `Strict; (* ??? *)
} } ])} )
}
let simple_ur_type_ref = ref simple_ur_type
let ptr x = ref (Some x)
let mk_qname (env,s) = (env.target_ns, Utf8.mk s)
let str_of_qname (ns,l) =
"{" ^ U.get_str (Ns.value ns) ^ "}:" ^ U.get_str l
let simple_ur_type_ptr = ptr simple_ur_type
let mk_qname (env,s) = (env.target_ns, s)
let mk_qname_option a = Some (mk_qname a)
let rec drop_initial_ws s i =
if (i = String.length s) then i
else match s.[i] with
| '\009' | '\010' | '\013' | '\032' -> drop_initial_ws s (succ i)
| _ -> i
let rec drop_final_ws s i =
if (i = 0) then i
else match s.[pred i] with
| '\009' | '\010' | '\013' | '\032' -> drop_final_ws s (pred i)
| _ -> i
let normalize s =
let s = U.get_str s in
let j = drop_final_ws s (String.length s) in
if (j = 0) then U.empty
else
let i = drop_initial_ws s 0 in
U.mk (String.sub s i (j-i))
let resolve_qname n s =
(* todo ! *)
s
Ns.map_tag n.ns_table (normalize s)
let resolve_qnames n slist =
(* todo ! *)
......@@ -47,92 +129,277 @@ let need_attribute attr _ =
let error msg _ =
failwith ("Error: " ^ msg)
let norm_attr attr found notfound ((env,n) as arg) =
let print_qname (ns,l) =
print_endline ("Looking for " ^ (U.get_str l))
let norm_attr attr found ?notfound ((env,n) as arg) =
print_qname attr;
try
let v = List.assoc attr n.attrs in
let v = (* normalize *) v in
let v = normalize v in
found (env,v)
with Not_found -> notfound arg
with Not_found ->
match notfound with
| Some f -> f arg
| None -> failwith ("Need attribute " ^ U.get_str (snd attr))
let qname_attr attr found notfound ((env,n) as 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
?notfound arg
let child tag found notfound ((env,n) as arg) =
let child tag found ?notfound ((env,n) as arg) =
print_qname tag;
try
let n = List.find (fun n -> n.tag = tag) n.children in
found (env,n)
with Not_found -> notfound arg
with Not_found ->
match notfound with
| Some f -> f arg
| None -> failwith ("Need child " ^ U.get_str (snd tag))
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) =
let qnames_attr attr found ?notfound ((env,n) as arg) =
norm_attr attr
(fun (env,v) -> found (env,resolve_qnames n v))
notfound arg
?notfound arg
let cst x _ = x
let rec global_attribute_declaration arg =
{ ad_name =
norm_attr "name"
mk_qname
(need_attribute "name")
arg;
let top_name = norm_attr _name mk_qname
let opt_name = norm_attr _name mk_qname_option ~notfound:(cst None)
let value_constraint =
norm_attr _default
(fun (_,s) -> Default s)
~notfound:
(norm_attr _fixed
(fun (_,s) -> Fixed s)
~notfound:(cst No_constraint))
let set_ref ((env,n) as arg) resolve decl =
let name = arg // top_name in
let r = resolve (env,name) in
let x = decl arg in
r := Some x
let rec toplevel_attribute_declaration arg =
{ ad_name = arg // top_name;
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
arg //
child _simpleType simple_type
~notfound:
(qname_attr _type resolve_simple_type
~notfound:(cst simple_ur_type_ptr));
ad_cstr = arg // value_constraint
}
and toplevel_element_declaration arg =
{ ed_name = arg // top_name;
ed_type =
arg //
child _simpleType (fun arg -> Simple (simple_type arg))
~notfound:
(child _complexType complex_type
~notfound:
(qname_attr _type resolve_type
~notfound:(cst ur_type_ptr)));
ed_cstr = arg // value_constraint;
ed_nillable = false; (* TODO *)
}
and simple_type arg =
let name = norm_attr "name" mk_qname_option (cst None) arg in
let name = arg // opt_name in
let v =
child "restriction" restriction
(child "list" list
(child "union" union
(error "Need simple type"))) arg in
ref
child _restriction restriction
~notfound:
(child _list list
~notfound:
(child _union union ?notfound:None))
arg in
ptr
{ st_name = name;
st_variety = v }
and complex_type arg =
failwith "complex_type"
and restriction arg =
let base =
qname_attr "base"
qname_attr _base
resolve_simple_type
(child "simpleType" simple_type
(error "Need simple type")) arg in
Restriction (base,empty_facets)
~notfound:(child _simpleType simple_type)
arg in
VRestriction (base,empty_facets)
and list arg =
let item_type =
qname_attr "itemType"
qname_attr _itemType
resolve_simple_type
(child "simpleType" simple_type
(error "Need simple type")) arg in
List item_type
~notfound:(child _simpleType simple_type)
arg in
VList item_type
and union arg =
let member_types =
qnames_attr "itemType"
qnames_attr _memberTypes
resolve_simple_types
(children "simpleType" simple_type) arg in
Union member_types
~notfound:(children _simpleType simple_type) arg in
VUnion member_types
and toplevel ((env,n) as arg) =
match U.get_str (snd n.tag) with
| "attribute" ->
set_ref arg resolve_attribute toplevel_attribute_declaration
| "element" ->
set_ref arg resolve_element toplevel_element_declaration
| s -> failwith s
and schema n =
let arg = (),n in
let qual a =
norm_attr a
(function (_,v) -> U.get_str v = "qualified")
~notfound:(cst false)
arg in
let env = {
target_ns = norm_attr _targetNamespace
(fun (_,ns) -> Ns.mk ns) ~notfound:(cst Ns.empty) arg;
attr_qual = qual _attributeFormDefault;
elt_qual= qual _elementFormDefault;
type_defs = [];
attr_decls = [];
elt_decls = [];
mg_defs = [];
ag_defs = []
} in
let names a f = List.map f (children a top_name (env,n)) in
let names_none a = names a (fun name -> (name, ref None)) in
let env =
{ env with
type_defs = (
names _simpleType (fun name -> (name,Simple (ref None))) @
names _complexType (fun name -> (name,Simple (ref None))) );
attr_decls = names_none _attribute;
elt_decls = names_none _element;
mg_defs = names_none _group;
ag_defs = names_none _attributeGroup
} in
List.iter (fun x -> toplevel (env,x)) n.children;
Printf.printf "# type defs: %d\n" (List.length env.type_defs);
Printf.printf "# mg defs: %d\n" (List.length env.mg_defs);
Printf.printf "# ag defs: %d\n" (List.length env.ag_defs);
Printf.printf "# attr decls: %d\n" (List.length env.attr_decls);
Printf.printf "# elt decls: %d\n" (List.length env.elt_decls);
()
and resolve_simple_type arg =
match resolve_type arg with
| Simple t -> t
| Complex _ ->
failwith "Complex type used where simple type expected"
and resolve_attribute (env,x) =
print_endline ("Resolve attribute " ^ (str_of_qname x));
List.assoc x env.attr_decls
and resolve_simple_type arg = assert false
and resolve_element (env,x) =
print_endline ("Resolve element " ^ (str_of_qname x));
List.assoc x env.elt_decls
and resolve_type (env,x) =
print_endline ("Resolve type " ^ (str_of_qname x));
List.assoc x env.type_defs
and resolve_simple_types (env,args) =
List.map (fun a -> resolve_simple_type (env,a)) args
(***************************************)
type stack =
| Start of Ns.table * Ns.qname * (Ns.qname * U.t) list * Ns.table * stack
| Element of xml_node * stack
| SEmpty
let stack = ref SEmpty
let ns_table = ref Ns.empty_table
let rec create_elt accu = function
| Element (x,st) -> create_elt (x::accu) st
| Start (t,name,att,table,st) ->
let elt = {
ns_table = t;
tag = name;
attrs = att;
children = accu
} in
stack := Element (elt,st);
ns_table := table
| SEmpty -> assert false
let start_element_handler name att =
let (table,name,att) = Ns.process_start_tag !ns_table name att in
stack := Start (table,name,att,!ns_table, !stack);
ns_table := table
let end_element_handler _ =
create_elt [] !stack
open Pxp_yacc
open Pxp_lexer_types
open Pxp_types
open Pxp_ev_parser
let pxp_config =
{ default_config with
encoding = `Enc_utf8;
store_element_positions = false;
drop_ignorable_whitespace = true
}
let pxp_handle_event = function
| E_start_tag (name,att,_,_) -> start_element_handler name att
| E_end_tag (_,_) -> end_element_handler ()
| _ -> ()
let load_xml s =
ns_table := Ns.empty_table;
stack := SEmpty;
let src = from_file s in
let mgr = create_entity_manager pxp_config src in
process_entity pxp_config (`Entry_document[`Extend_dtd_fully]) mgr
pxp_handle_event;
match !stack with
| Element (x,SEmpty) -> stack := SEmpty; x
| _ -> failwith "No XML stream to parse"
let print_qname ppf (_,s) =
Format.fprintf ppf "%s" (U.get_str s)
let rec print_node x ppf n =
Format.fprintf ppf "%s%a%a@.%a"
x
print_qname n.tag
print_attrs n.attrs
(print_children (x ^ " ")) n.children
and print_attrs ppf a =
List.iter
(fun (n,v) -> Format.fprintf ppf " %a=%s" print_qname n (U.get_str v))
a
and print_children x ppf l =
List.iter (print_node x ppf) l
let () =
let xml = load_xml "tests/schema/mails.xsd" in
Format.fprintf Format.std_formatter "%a@." (print_node "") xml;
let _ = schema xml in
()
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