Skip to content

GitLab

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

[r2005-03-04 13:36:39 by afrisch] Clean 

Original author: afrisch
Date: 2005-03-04 13:39:08+00:00
parent d5664653
Hide whitespace changes
Inline Side-by-side
CHANGES
View file @ a0171f82
Since 0.2.2
- Warning for capture variables and projections that always return the empty
sequence.
- Bug fixes when printing location in source code.
- Major rewrite of the support for XML Schema
* removed print_schema directive
* removed the "kind" selector (e.g. S # t as element)
* include,import implemented
*
- removed the syntax "external {...}", replaced with
"unit.val with { ty1 ty2 ... }"
- removed the syntax H:val, replaced with H.val
- removed the syntax S#t, replaced with S.t
- overloaded the dot (record field acces, CDuce, OCaml, Schema units)
- identifiers (for types, values) are now qualified names
- A new tool cduce_mktop produce CDuce toplevels with embeded OCaml functions
- several bug fixes
- validate renamed to cduce_validate
- more efficient hash-consing of types
- better error message with script on stdin
- a dot in an identifier must be escaped with a backslash, e.g. x\.y
- improved #print_type (does not use the abbreviation for the printed type)
- float_of: String -> Float
- Language:
* Warning for capture variables and projections that always return the empty
sequence.
* Major rewrite of the support for XML Schema
* removed print_schema directive
* removed the "kind" selector (e.g. S # t as element)
* include,import implemented
* support wildcards any,anyAttrivbute
* support xsi:nil
* support xsd:decimal,xsd:float
* many bug fixes
* Removed the syntax "external {...}", replaced with
"unit.val with { ty1 ty2 ... }".
* Removed the syntax H:val, replaced with H.val.
* Removed the syntax S#t, replaced with S.t.
* Overloaded the dot (record field acces, CDuce, OCaml, Schema units).
A dot in an identifier must now be escaped with a backslash, e.g. x\.y
* Identifiers (for types, values) are now qualified names.
* float_of: String -> Float
- Tools:
* A new tool cduce_mktop produce customized CDuce toplevels with embedded
OCaml externals.
* validate renamed to cduce_validate
- Implementation:
* Various bug fixes
* More efficient hash-consing of types
* improved #print_type (does not use the abbreviation for the printed type)
0.2.2
......
schema/schema_common.ml
View file @ a0171f82
......@@ -10,17 +10,12 @@ let no_facets = {
length = None;
minLength = None;
maxLength = None;
(* pattern = []; *)
enumeration = None;
whiteSpace = `Collapse, true;
maxInclusive = None;
maxExclusive = None;
minInclusive = None;
minExclusive = None;
(*
totalDigits = None;
fractionDigits = None;
*)
}
(** naive implementation: doesn't follow XML Schema constraints on facets
......@@ -62,31 +57,6 @@ let merge_facets old_facets new_facets =
minExclusive = minExclusive;
}
let rec facets_of_simple_type_definition st = st.st_facets
let rec variety_of_simple_type_definition st = st.st_variety
(*
let get_simple_type c = match Lazy.force c with
| Simple c -> c
| AnyType -> Primitive (xsd,Utf8.mk "anySimpleType")
| _ -> assert false
*)
(*
let rec normalize_simple_type = function
| Derived (name, Restrict, new_facets, base) ->
(match normalize_simple_type (get_simple_type base) with
| Derived (_,variety,old_facets,base) ->
Derived (name,variety,merge_facets old_facets new_facets,base)
| Primitive _ as st ->
let b = lazy (Simple st) in
Derived (name,Atomic b,new_facets,b))
| st -> st
*)
let name_of_element_declaration elt = elt.elt_name
let name_of_simple_type_definition = function
| { st_name = Some name } -> name
| _ -> raise (Invalid_argument "anonymous simple type definition")
......@@ -97,13 +67,7 @@ let name_of_type_definition = function
| 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
let name_of_attribute_use { attr_decl = { attr_name = name } } = name
let name_of_attribute_group_definition ag = ag.ag_name
let name_of_model_group_definition mg = mg.mg_name
let name_of_particle = function
| { part_term = Elt e } -> name_of_element_declaration e
| _ -> assert false
let simple_type_of_type = function
| Simple s -> s
| _ -> raise (Invalid_argument "simple_type_of_type")
......@@ -115,12 +79,6 @@ let content_type_of_type = function
| Complex { ct_content = ct } -> ct
| Simple st -> CT_simple st
let iter_types schema f = List.iter f schema.types
let iter_attributes schema f = List.iter f schema.attributes
let iter_elements schema f = List.iter f schema.elements
let iter_attribute_groups schema f = List.iter f schema.attribute_groups
let iter_model_groups schema f = List.iter f schema.model_groups
exception XSD_validation_error of string
exception XSI_validation_error of string
......@@ -139,13 +97,6 @@ let rec normalize_white_space =
in
pcre_replace ~rex:margins_RE ~templ:(Utf8.mk "$1") s'
(*
let anySimpleType = Primitive (xsd, Utf8.mk "anySimpleType")
*)
let anyType = AnyType
let first_of_particle p = p.part_first
let nullable p = p.part_nullable
let first_of_wildcard_constraint = function
| WAny -> Atoms.any
......@@ -155,156 +106,20 @@ let first_of_wildcard_constraint = function
Atoms.empty l
let first_of_model_group = function
| All particles | Choice particles ->
List.fold_left (fun acc p -> Atoms.cup acc (first_of_particle p))
List.fold_left (fun acc p -> Atoms.cup acc p.part_first)
Atoms.empty particles
| Sequence particles ->
let rec aux = function
| hd::tl when nullable hd -> Atoms.cup (first_of_particle hd) (aux tl)
| hd::tl -> first_of_particle hd
| hd::tl when hd.part_nullable -> Atoms.cup hd.part_first (aux tl)
| hd::tl -> hd.part_first
| [] -> Atoms.empty
in
aux particles
let nullable_of_model_group = function
| All particles | Sequence particles -> List.for_all nullable particles
| Choice particles -> List.exists nullable particles
let get_interval facets =
(* ASSUMPTION:
* not (facets.minInclusive = Some _ && facets.minExclusive = Some _)
* not (facets.maxInclusive = Some _ && facets.maxExclusive = Some _)
* Value.t is an integer! (no other intervals are actually supported
* by the CDuce type system)
*)
let getint f = Value.get_integer f in
let min =
match facets.minInclusive, facets.minExclusive with
| Some (i, _), None -> Some (getint i)
| None, Some (i, _) -> Some (Intervals.V.succ (getint i))
| None, None -> None
| _ -> assert false
in
let max =
match facets.maxInclusive, facets.maxExclusive with
| Some (i, _), None -> Some (getint i)
| None, Some (i, _) -> Some (Intervals.V.pred (getint i))
| None, None -> None
| _ -> assert false
in
match min, max with
| Some min, Some max -> Intervals.bounded min max
| Some min, None -> Intervals.right min
| None, Some max -> Intervals.left max
| None, None -> Intervals.any
let print_simple_type fmt = function
| { st_name = Some name } -> Format.fprintf fmt "%a" Ns.QName.print name
| _ -> Format.fprintf fmt "unnamed"
let print_complex_type fmt = function
| { ct_uid = id; ct_name = Some 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
| AnyType -> Format.fprintf fmt "xsd:anyType"
| 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" Ns.QName.print name print_simple_type t
let print_element fmt { elt_uid = id; elt_name = 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}" Ns.QName.print ag.ag_name
let print_model_group_def fmt mg =
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 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: ";
List.iter (fun c -> print_type fmt c; Format.fprintf fmt " ")
defined_types;
Format.fprintf fmt "\n"
end;
if schema.attributes <> [] then begin
Format.fprintf fmt "Attributes: ";
List.iter (fun c -> print_attribute fmt c; Format.fprintf fmt " ")
schema.attributes;
Format.fprintf fmt "\n"
end;
if schema.elements <> [] then begin
Format.fprintf fmt "Elements: ";
List.iter (fun c -> print_element fmt c; Format.fprintf fmt " ")
schema.elements;
Format.fprintf fmt "\n"
end;
if schema.attribute_groups <> [] then begin
Format.fprintf fmt "Attribute groups: ";
List.iter (fun c -> print_attribute_group fmt c; Format.fprintf fmt " ")
schema.attribute_groups;
Format.fprintf fmt "\n"
end;
if schema.model_groups <> [] then begin
Format.fprintf fmt "Model groups: ";
List.iter (fun c -> print_model_group_def fmt c; Format.fprintf fmt " ")
schema.model_groups;
Format.fprintf fmt "\n"
end
let get_qual name table get_name =
List.find
(fun x ->
try Ns.QName.equal (get_name x) name
with Invalid_argument _ -> false)
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 =
get_qual name schema.elements name_of_element_declaration
let get_attribute_group name schema =
get_qual name schema.attribute_groups name_of_attribute_group_definition
let get_model_group name schema =
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 *)
let get_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"
| Some `Element -> "element"
| Some `Attribute -> "attribute"
| Some `Attribute_group -> "attribute group"
| Some `Model_group -> "model group"
| None -> "component"
(** Events *)
| All particles | Sequence particles ->
List.for_all (fun p -> p.part_nullable) particles
| Choice particles -> List.exists (fun p -> p.part_nullable) particles
type to_be_visited =
| Fully of Value.t (* xml values still to be visited *)
......@@ -359,51 +174,6 @@ let string_of_event = function
sprintf "@%s=%s" (Ns.QName.to_string qname) (Utf8.to_string value)
| E_char_data value -> Utf8.to_string value
(*
let test v =
let s = stream_of_value v in
let rec aux () =
(match Stream.peek s with
| None -> ()
| Some (E_start_tag qname) ->
Ns.QName.print Format.std_formatter qname
| Some (E_end_tag qname) ->
Format.fprintf Format.std_formatter "/";
Ns.QName.print Format.std_formatter qname
| Some (E_attribute (qname, value)) ->
Format.fprintf Format.std_formatter "@@";
Ns.QName.print Format.std_formatter qname;
Format.fprintf Format.std_formatter " ";
Encodings.Utf8.print Format.std_formatter value
| Some (E_char_data value) ->
Encodings.Utf8.print Format.std_formatter value);
Format.fprintf Format.std_formatter "\n";
(match Stream.peek s with
| None -> ()
| _ ->
Stream.junk s;
aux ())
in
aux ()
*)
let rec print_model_group ppf = function
| All pl -> Format.fprintf ppf "All(%a)" print_particle_list pl
| Choice pl -> Format.fprintf ppf "Choice(%a)" print_particle_list pl
| Sequence pl -> Format.fprintf ppf "Sequence(%a)" print_particle_list pl
and print_particle_list ppf = function
| [] -> ()
| [p] -> print_particle ppf p
| hd::tl -> Format.fprintf ppf "%a;%a" print_particle hd print_particle_list tl
and print_particle ppf p =
print_term ppf p.part_term
and print_term ppf = function
| Elt e -> Format.fprintf ppf "E%i" e.elt_uid
| Model m -> print_model_group ppf m
| Wildcard _ -> Format.fprintf ppf "Wildcard"
let simple_restrict name base new_facets =
{ st_name = name;
......
schema/schema_common.mli
View file @ a0171f82
(** Schema common functionalities depending only on Schema_types *)
open Encodings
open Schema_types
(** {2 Exceptions} *)
exception XSD_validation_error of string
exception XSI_validation_error of string
(** {2 XSD printer *)
val print_schema : Format.formatter -> schema -> unit
val print_type : Format.formatter -> type_definition -> unit
val print_attribute : Format.formatter -> attribute_declaration -> unit
val print_element : Format.formatter -> element_declaration -> unit
val print_attribute_group :
Format.formatter -> attribute_group_definition -> unit
val print_model_group_def : Format.formatter -> model_group_definition -> unit
val print_simple_type : Format.formatter -> simple_type_definition -> unit
val print_complex_type : Format.formatter -> complex_type_definition -> unit
(** {2 Deconstruction functions} *)
(*
val get_simple_type: type_ref -> simple_type_definition
*)
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
val variety_of_simple_type_definition : simple_type_definition -> variety
val facets_of_simple_type_definition : simple_type_definition -> facets
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: 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 -> Ns.qname -> schema -> component
val iter_types: schema -> (type_definition -> unit) -> unit
val iter_attributes: schema -> (attribute_declaration -> unit) -> unit
val iter_elements: schema -> (element_declaration -> unit) -> unit
val iter_attribute_groups:
schema -> (attribute_group_definition -> unit) -> unit
val iter_model_groups: schema -> (model_group_definition -> unit) -> unit
val first_of_wildcard_constraint: wildcard_constraint -> Atoms.t
val first_of_particle: particle -> Atoms.t
val first_of_model_group: model_group -> Atoms.t
val nullable: particle -> bool
val first_of_wildcard_constraint: wildcard_constraint -> Atoms.t
val nullable_of_model_group: model_group -> bool
(** {2 Facets} *)
val merge_facets: facets -> facets -> facets
(*
val normalize_simple_type: simple_type_definition -> simple_type_definition
*)
(** {2 Miscellaneous} *)
(** empty set of facets (with the only exception of "whiteSpace", which is set
to <`Collapse, true>, the mandatory value for all non string derived simple
types) *)
(** empty set of facets (with the only exception of "whiteSpace", which is set
to <`Collapse, true>, the mandatory value for all non string derived simple
types) *)
val no_facets: facets
val anyType: type_definition
(** @return the integer interval corrisponding to boundary facets *)
val get_interval: facets -> Intervals.t
(** perform white space normalization according to XML recommendation *)
(** perform white space normalization according to XML recommendation *)
val normalize_white_space: white_space_handling -> Utf8.t -> Utf8.t
(** {2 event interface on top of CDuce values} *)
......@@ -97,12 +27,6 @@ val stream_of_value: Value.t -> event Stream.t
val string_of_event: event -> string
val print_model_group: Format.formatter -> model_group -> unit
val print_particle: Format.formatter -> particle -> unit
val simple_restrict:
Ns.qname option -> simple_type_definition -> facets -> simple_type_definition
val simple_list:
......
schema/schema_parser.ml
View file @ a0171f82
......@@ -126,9 +126,6 @@ let parse_facets base n =
in
_fold_elems n no_facets aux
let merge_facets' base new_facets =
merge_facets (facets_of_simple_type_definition base) new_facets
let default_fixed n f =
match _may_attr "default" n with
| Some v -> Some (`Default (f v))
......@@ -377,7 +374,7 @@ let schema_of_uri uri =
| Complex { ct_attrs = uses }, `Restriction ->
let ( &= ) u1 u2 =
(* by name equality over attribute uses *)
(name_of_attribute_use u1 = name_of_attribute_use u2)
(u1.attr_decl.attr_name = u2.attr_decl.attr_name)
in
let l =
List.filter
......@@ -514,7 +511,7 @@ let schema_of_uri uri =
| Some ref -> elt (resolve_elt ref) ref
| None ->
let decl = parse_elt_decl false n in
elt decl (name_of_element_declaration decl))
elt decl decl.elt_name)
| "xsd:group" -> model (resolve_model_group (_qname_attr "ref" n)).mg_def
| "xsd:all" | "xsd:sequence" | "xsd:choice" ->
model (parse_model_group n)
......
schema/schema_types.ml
View file @ a0171f82
......@@ -143,19 +143,5 @@ type schema = {
type event =
| E_start_tag of Ns.qname
| E_end_tag of Ns.qname
| E_attribute of Ns.qname * Encodings.Utf8.t (* qualified name, value *)
| E_attribute of Ns.qname * Encodings.Utf8.t
| E_char_data of Encodings.Utf8.t
(** {2 Misc} *)
(* kind of a schema component *)
type component_kind =
[ `Type | `Element | `Attribute | `Attribute_group | `Model_group ] option
type component =
| Type of type_definition
| Element of element_declaration
| Attribute of attribute_declaration
| Attribute_group of attribute_group_definition
| Model_group of model_group_definition
schema/schema_types.mli
View file @ a0171f82
......@@ -5,17 +5,8 @@
exceptions are available here. See Schema_common.
*)
(**
Glossary:
XSD XML Schema Document
PSV Post Schema Validation
PSVI Post Schema Validation Infoset
*)
open Encodings
(** {2 XSD representation} *)
type derivation_type = [ `Extension | `Restriction ]
type white_space_handling = [ `Preserve | `Replace | `Collapse ]
......@@ -138,24 +129,8 @@ type schema = {
model_groups: model_group_definition list;
}
(** {2 Events} see Schema_events module *)
type event =
| E_start_tag of Ns.qname
| E_end_tag of Ns.qname
| E_attribute of Ns.qname * Encodings.Utf8.t (* qualified name, value *)
| E_attribute of Ns.qname * Encodings.Utf8.t
| E_char_data of Encodings.Utf8.t
(** {2 Misc} *)
(* kind of a schema component *)
type component_kind =
[ `Type | `Element | `Attribute | `Attribute_group | `Model_group ] option
type component =
| Type of type_definition
| Element of element_declaration
| Attribute of attribute_declaration
| Attribute_group of attribute_group_definition
| Model_group of model_group_definition
schema/schema_validator.ml
View file @ a0171f82
......@@ -333,7 +333,7 @@ let next_tag ctx =
let validate_attribute_uses attrs (attr_uses,anyattr) =
let tbl = QTable.create 11 in
List.iter
(fun use -> QTable.add tbl (name_of_attribute_use use) use)
(fun use -> QTable.add tbl use.attr_decl.attr_name use)
attr_uses;
let attribs = ref [] in
List.iter
......@@ -417,13 +417,6 @@ and validate_content_type ctx content_type =
get ctx
and validate_particle ctx particle =
(*
Format.fprintf ppf "Particle first";
List.iter (fun n -> Format.fprintf ppf "%a;" Ns.QName.print n)
particle.part_first;
Format.fprintf ppf "@.";
*)
let rec validate_once ~cont_ok ~cont_failure =
do_pcdata ctx;
match peek ctx with
......@@ -472,7 +465,7 @@ and validate_term ctx term =
and validate_choice ctx particles =
(* TODO: Handle case when one of the choices is nullable *)
let tbl = Atoms.mk_map
(List.map (fun p -> first_of_particle p, p) particles) in
(List.map (fun p -> p.part_first, p) particles) in
do_pcdata ctx;
try
(match peek ctx with
......@@ -487,7 +480,7 @@ and validate_all_group ctx particles =
let tbl = QTable.create 20 in
let slots = List.map (fun p -> (p, ref None)) particles in
let tbl = Atoms.mk_map
(List.map (fun (p,slot) -> first_of_particle p, (p,slot)) slots) in
(List.map (fun (p,slot) -> p.part_first, (p,slot)) slots) in
let contents = ref Value.nil in
let rec aux () =
......@@ -509,7 +502,7 @@ and validate_all_group ctx particles =
(fun (p,slot) ->
match !slot with
| Some x -> concat ctx x
| None when nullable p -> ()
| None when p.part_nullable -> ()
| None -> error "One particle of the all group is missing"
) slots