Skip to content

GitLab

Commit 6a26ef06 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-02-22 15:33:36 by afrisch] Clean 

Original author: afrisch
Date: 2005-02-22 15:33:36+00:00
parent a7461174
Hide whitespace changes
Inline Side-by-side
Showing with 105 additions and 121 deletions
schema/schema_common.ml
View file @ 6a26ef06
......@@ -103,7 +103,7 @@ 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
| (_, _, Elt elt_decl_ref, _) -> name_of_element_declaration (Lazy.force elt_decl_ref)
| { part_term = Elt e } -> name_of_element_declaration (Lazy.force e)
| _ -> assert false
let variety_of_simple_type_definition = function
| (Primitive name) as st -> Atomic (lazy (Simple st))
......@@ -146,8 +146,9 @@ let rec normalize_white_space =
let anySimpleType = Primitive (xsd, Utf8.mk "anySimpleType")
let anyType = AnyType
let first_of_particle (_, _, _, first) = first
let nullable p = List.mem None (first_of_particle p)
let first_of_particle p = p.part_first
let nullable p = p.part_nullable
let first_of_model_group = function
| All particles | Choice particles ->
List.concat (List.map first_of_particle particles)
......@@ -158,10 +159,11 @@ let first_of_model_group = function
| [] -> []
in
aux particles
let rec is_in_first tag = function
| [] -> false
| Some tag' :: rest when Ns.QName.equal tag' tag -> true
| _ :: rest -> is_in_first tag rest
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:
......@@ -430,8 +432,8 @@ 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 (min,max,term,_) =
print_term ppf term
and print_particle ppf p =
print_term ppf p.part_term
and print_term ppf = function
| Elt e -> Format.fprintf ppf "E%i" ((Lazy.force e).elt_uid)
| Model m -> print_model_group ppf m
schema/schema_common.mli
View file @ 6a26ef06
......@@ -61,10 +61,10 @@ val iter_attribute_groups:
schema -> (attribute_group_definition -> unit) -> unit
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: Ns.qname -> first -> bool
val first_of_particle: particle -> Ns.qname list
val nullable: particle -> bool
val first_of_model_group: model_group -> Ns.qname list
val nullable_of_model_group: model_group -> bool
(** {2 Facets} *)
......
schema/schema_parser.ml
View file @ 6a26ef06
......@@ -11,6 +11,20 @@ module QTable = Hashtbl.Make(Ns.QName)
let validation_error s = raise (XSD_validation_error s)
let particle min max term first nullable =
{ part_min = min;
part_max = max;
part_term = term;
part_first = first;
part_nullable = nullable }
let particle_model min max mg =
particle min max
(Model mg)
(first_of_model_group mg)
(nullable_of_model_group mg)
let xsd = Schema_xml.xsd
(*
......@@ -65,23 +79,23 @@ let hashtbl_values tbl = QTable.fold (fun _ v acc -> v :: acc) tbl []
let parse_facets base n =
let validate_base_type v =
lazy (Schema_validator.validate_simple_type (get_simple_type base) v) in
let validate_nonNegativeInteger =
Schema_builtin.validate_builtin (xsd, Utf8.mk "nonNegativeInteger")
let parse_nonneg n =
let s = Utf8.get_str (_attr "value" n) in
let i = int_of_string s in
if (i < 0) then failwith "Unexpected negative integer";
i
in
let aux facets n tag =
let fixed = _is_attr "fixed" n "true" in
match tag with
| "xsd:length" ->
let value = _attr "value" n in
let length = Value.get_integer (validate_nonNegativeInteger value) in
let length = parse_nonneg n in
{ facets with length = Some (length, fixed) }
| "xsd:minLength" ->
let value = _attr "value" n in
let length = Value.get_integer (validate_nonNegativeInteger value) in
let length = parse_nonneg n in
{ facets with minLength = Some (length, fixed) }
| "xsd:maxLength" ->
let value = _attr "value" n in
let length = Value.get_integer (validate_nonNegativeInteger value) in
let length = parse_nonneg n in
{ facets with maxLength = Some (length, fixed) }
| "xsd:enumeration" ->
let value = Value.string_utf8 (_attr "value" n) in
......@@ -134,12 +148,14 @@ let parse_att_value_constraint stype_def n =
let parse_min_max n =
(match _may_attr "minOccurs" n with
| Some v -> Intervals.V.mk (Utf8.get_str v)
| None -> Intervals.V.one),
| Some v -> int_of_string (Utf8.get_str v)
| None -> 1),
(match _may_attr "maxOccurs" n with
| Some v when Utf8.get_str v = "unbounded" -> None
| Some v -> Some (Intervals.V.mk (Utf8.get_str v))
| None -> Some Intervals.V.one)
| Some v ->
(match Utf8.get_str v with
| "unbounded" -> None
| v -> Some (int_of_string v))
| None -> Some 1)
let rec first n f = function
| [] -> None
......@@ -453,10 +469,7 @@ let schema_of_uri uri =
CT_model (particle, mixed)
| CT_model (p, _) ->
let model = Sequence (p::[particle]) in
CT_model
((Intervals.V.one, Some (Intervals.V.one), Model model,
first_of_model_group model),
mixed)
CT_model (particle_model 1 (Some 1) model, mixed)
| CT_simple _ -> assert false
in
base,derivation_type,uses,content_type
......@@ -502,22 +515,18 @@ let schema_of_uri uri =
and parse_particle n =
let min, max = parse_min_max n in
let model mg = particle_model min max mg in
let elt e n = particle min max (Elt e) [ n ] false in
match _tag n with
| "xsd:element" ->
let elt_decl, first =
match _may_qname_attr "ref" n with
| Some ref -> (resolve_elt ref, [ Some ref ])
| None ->
let decl = parse_elt_decl false n in
(lazy decl, [ Some (name_of_element_declaration decl) ])
in
(min, max, Elt elt_decl, first)
| "xsd:group" ->
let mg = resolve_model_group (_qname_attr "ref" n) in
(min, max, Model mg.mg_def, first_of_model_group mg.mg_def)
| "xsd:all" | "xsd:sequence" | "xsd:choice" ->
let model_group = parse_model_group n in
(min, max, Model model_group, first_of_model_group model_group)
(match _may_qname_attr "ref" n with
| Some ref -> elt (resolve_elt ref) ref
| None ->
let decl = parse_elt_decl false n in
elt (lazy decl) (name_of_element_declaration decl))
| "xsd:group" -> model (resolve_model_group (_qname_attr "ref" n)).mg_def
| "xsd:all" | "xsd:sequence" | "xsd:choice" ->
model (parse_model_group n)
| _ -> assert false
and parse_model_group n =
......
schema/schema_types.ml
View file @ 6a26ef06
......@@ -16,16 +16,13 @@ open Encodings
(** {2 XSD representation} *)
type xs_nonNegativeInteger = Intervals.V.t (* = Big_int.big_int *)
(* type xs_positiveInteger = Intervals.V.t *)
type derivation_type = [ `Extension | `Restriction ]
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 *)
length: (int * bool) option; (* length, fixed *)
minLength: (int * bool) option; (* length, fixed *)
maxLength: (int * bool) option; (* length, fixed *)
(* pattern: Schema_regexp.regexp list; (* list of ANDed patterns *) *)
enumeration: value_ref list option;
whiteSpace: white_space_handling * bool; (* handling, fixed *)
......@@ -69,10 +66,6 @@ and attribute_use =
attr_decl : attribute_declaration;
attr_use_cstr : value_constraint option }
(* first construction as per predictive parsing. None stands for epsilon, Some
* Utf8.t stands for a start tag of identical name *)
and first = Ns.QName.t option list
and term =
| Elt of element_declaration Lazy.t
| Model of model_group
......@@ -85,15 +78,14 @@ and model_group =
and content_type =
| CT_empty
| CT_simple of type_ref
| CT_model of
particle *
bool (* mixed *)
| CT_model of particle * bool (* mixed *)
and particle =
xs_nonNegativeInteger * (* minOccurs *)
xs_nonNegativeInteger option * (* maxOccurs (None = "unbounded") *)
term *
first
{ part_min: int;
part_max: int option; (* None = unbounded *)
part_term: term;
part_first: Ns.qname list;
part_nullable: bool }
and element_declaration =
{ elt_uid: int;
......
schema/schema_types.mli
View file @ 6a26ef06
......@@ -16,16 +16,13 @@ open Encodings
(** {2 XSD representation} *)
type xs_nonNegativeInteger = Intervals.V.t (* = Big_int.big_int *)
(* type xs_positiveInteger = Intervals.V.t *)
type derivation_type = [ `Extension | `Restriction ]
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 *)
length: (int * bool) option; (* length, fixed *)
minLength: (int * bool) option; (* length, fixed *)
maxLength: (int * bool) option; (* length, fixed *)
(* pattern: Schema_regexp.regexp list; (* list of ANDed patterns *) *)
enumeration: value_ref list option;
whiteSpace: white_space_handling * bool; (* handling, fixed *)
......@@ -69,10 +66,6 @@ and attribute_use =
attr_decl : attribute_declaration;
attr_use_cstr : value_constraint option }
(* first construction as per predictive parsing. None stands for epsilon, Some
* Utf8.t stands for a start tag of identical name *)
and first = Ns.QName.t option list
and term =
| Elt of element_declaration Lazy.t
| Model of model_group
......@@ -85,15 +78,14 @@ and model_group =
and content_type =
| CT_empty
| CT_simple of type_ref
| CT_model of
particle *
bool (* mixed *)
| CT_model of particle * bool (* mixed *)
and particle =
xs_nonNegativeInteger * (* minOccurs *)
xs_nonNegativeInteger option * (* maxOccurs (None = "unbounded") *)
term *
first
{ part_min: int;
part_max: int option; (* None = unbounded *)
part_term: term;
part_first: Ns.qname list;
part_nullable: bool }
and element_declaration =
{ elt_uid: int;
......
schema/schema_validator.ml
View file @ 6a26ef06
......@@ -33,10 +33,8 @@ let ptbl_of_particles particles =
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 -> QTable.add tbl tag p)
(first_of_particle p))
(fun p ->
List.iter (fun tag -> QTable.add tbl tag p) (first_of_particle p))
particles;
tbl
......@@ -54,10 +52,6 @@ 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)
......@@ -103,21 +97,20 @@ struct
* and no Concat, but just Pair *)
let length v =
let rec aux acc = function
| Pair (_, rest) -> aux (Intervals.V.succ acc) rest
| v when v = Value.nil -> Intervals.V.zero
| _ -> assert false
| Pair (_, rest) -> aux (succ acc) rest
| _ -> 0
in
aux Intervals.V.zero v
aux 0 v
let length_valid len value =
if not (Intervals.V.equal (length value) len) then
raise (Facet_error "length")
if (length value != len)
then raise (Facet_error "length")
let minLength_valid min_len value =
if Intervals.V.lt (length value) min_len then
raise (Facet_error "minLength")
if (length value < min_len)
then raise (Facet_error "minLength")
let maxLength_valid max_len value =
if Intervals.V.gt (length value) max_len then
raise (Facet_error "maxLength")
if (length value > max_len)
then raise (Facet_error "maxLength")
let enumeration_valid enum value =
if not (List.exists (fun x -> Value.equal value (Lazy.force x)) enum)
......@@ -341,13 +334,13 @@ and validate_content_type context content_type : Value.t =
validate_particle context particle
and validate_particle context particle =
let (min, max, term, first) = particle in
let content = ref Value.nil in
let concat v = content := Value.concat !content v in
let rec validate_once ~cont_ok ~cont_failure =
match context#peek with
| E_start_tag qname when is_in_first qname first ->
concat (validate_term context term);
| E_start_tag qname
when List.exists (Ns.QName.equal qname) particle.part_first ->
concat (validate_term context particle.part_term);
cont_ok ()
| E_char_data utf8_data when context#mixed ->
concat (string_utf8 utf8_data);
......@@ -356,10 +349,10 @@ and validate_particle context particle =
| ev -> cont_failure ev
in
let rec required = function
| v when Intervals.V.equal v Intervals.V.zero -> ()
| n (* when n > 0 *) ->
| 0 -> ()
| n ->
validate_once
~cont_ok:(fun () -> required (Intervals.V.pred n))
~cont_ok:(fun () -> required (pred n))
~cont_failure:(fun event ->
validation_error ~context (sprintf "Unexpected content: %s"
(string_of_event event)))
......@@ -369,10 +362,10 @@ and validate_particle context particle =
validate_once
~cont_ok:(fun () -> optional None)
~cont_failure:(fun _ -> ())
| Some v when Intervals.V.equal v Intervals.V.zero -> ()
| Some n (* when n > 0 *) ->
| Some 0 -> ()
| Some n ->
validate_once
~cont_ok:(fun () -> optional (Some (Intervals.V.pred n)))
~cont_ok:(fun () -> optional (Some (pred n)))
~cont_failure:(fun _ -> ())
in
let rec trailing_cdata () =
......@@ -383,9 +376,11 @@ and validate_particle context particle =
trailing_cdata ()
| _ -> ()
in
required min;
required particle.part_min;
optional
(match max with None -> None | Some v -> Some (Intervals.V.sub v min));
(match particle.part_max with
| None -> None
| Some v -> Some (v - particle.part_min));
if context#mixed then trailing_cdata ();
!content
......@@ -518,10 +513,6 @@ class context ~stream ~schema =
(string_of_event ev));
foo_qname (* useless *)
(*
method ns = schema.targetNamespace
*)
end
(** {2 API} *)
......
typing/typer.ml
View file @ 6a26ef06
......@@ -1508,22 +1508,19 @@ module Schema_converter =
let mk_len_regexp ?min ?max base =
let rec repeat_regexp re = function
| z when Intervals.V.is_zero z -> PEpsilon
| n when Intervals.V.gt n Intervals.V.zero ->
seq re (repeat_regexp re (Intervals.V.pred n))
| _ -> assert false
| 0 -> PEpsilon
| n -> seq re (repeat_regexp re (pred n))
in
let min = match min with Some min -> min | _ -> Intervals.V.one in
let min = match min with Some min -> min | _ -> 1 in
let min_regexp = repeat_regexp base min in
match max with
| Some max ->
(* assert (max >= min); Need to use Bigint comparison ! -- AF *)
let rec aux acc = function
| z when Intervals.V.is_zero z -> acc
| n ->
aux (PAlt (PEpsilon, (seq base acc))) (Intervals.V.pred n)
| 0 -> acc
| n -> aux (PAlt (PEpsilon, (seq base acc))) (pred n)
in
seq min_regexp (aux PEpsilon (Intervals.V.sub max min))
seq min_regexp (aux PEpsilon (max-min))
| None -> seq min_regexp (PStar base)
(* given a base derecurs create a derecurs value representing a sequence
......@@ -1621,8 +1618,9 @@ module Schema_converter =
seq acc (regexp_of_particle ~schema particle))
(regexp_of_particle ~schema hd) tl
and regexp_of_particle ~schema (min, max, term, _) =
mk_len_regexp ?min:(Some min) ?max (regexp_of_term ~schema term)
and regexp_of_particle ~schema p =
mk_len_regexp ?min:(Some p.part_min) ?max:p.part_max
(regexp_of_term ~schema p.part_term)
(** @return a pair composed by a type for the attributes (a record) and a
type for the content model (a sequence) *)
......
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