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

[r2005-03-13 16:11:53 by afrisch] Clean. Bug fix for type corresponding to fixed constraint

Original author: afrisch
Date: 2005-03-13 16:11:53+00:00
parent d5a7ccf0
......@@ -17,16 +17,14 @@ let xsd_any_type = Types.any
let nil_type = itype Sequence.nil_type
let mk_len_regexp ?min ?max base =
let mk_len_regexp min max base =
let rec repeat_regexp re = function
| 0 -> eps
| n -> seq re (repeat_regexp re (pred n))
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
| 0 -> acc
| n -> aux (alt eps (seq base acc)) (pred n)
......@@ -43,10 +41,10 @@ let mk_seq_derecurs base facets =
| _ -> 1, Some 1 in
Sequence.repet min max base
let xsi_nil_field_map =
LabelMap.singleton xsi_nil_label (Types.cons Builtin_defs.true_type)
let xsi_nil_field_map' =
LabelMap.singleton xsi_nil_label (itype Builtin_defs.true_type, None)
let xsi_nil_type =
let m = LabelMap.singleton xsi_nil_label (Types.cons Builtin_defs.true_type)
in
Types.record' (false,m)
......@@ -63,6 +61,19 @@ let rec simple_type = function
let members = List.map simple_type members in
List.fold_left (fun acc x -> Types.cup x acc) Types.empty members
let attr_uses (attrs,other) =
let fields =
List.map
(fun at ->
let r =
match at.attr_use_cstr with
| Some (`Fixed (_,v)) -> Types.constant (Value.inv_const v)
| _ -> simple_type at.attr_decl.attr_typdef
in
(not at.attr_required, at.attr_decl.attr_name, r))
attrs in
Types.rec_of_list false fields
let rec regexp_of_term = function
| Model group -> regexp_of_model_group group
| Elt decl -> elem (elt_decl decl)
......@@ -74,25 +85,22 @@ and wildcard w =
and regexp_of_model_group = function
| Choice l ->
List.fold_left
(fun acc particle ->
alt acc (regexp_of_particle particle))
(fun acc particle -> alt acc (regexp_of_particle particle))
emp l
| All l | Sequence l ->
List.fold_left
(fun acc particle ->
seq acc (regexp_of_particle particle))
(fun acc particle -> seq acc (regexp_of_particle particle))
eps l
and regexp_of_particle p =
mk_len_regexp ?min:(Some p.part_min) ?max:p.part_max
(regexp_of_term p.part_term)
mk_len_regexp p.part_min p.part_max (regexp_of_term p.part_term)
and get_complex ct =
try Hashtbl.find complex_memo ct.ct_uid
with Not_found ->
let slot = delayed () in
let attrs = attr_uses ct.ct_attrs in
let r = times attrs slot in
let r = times (itype attrs) slot in
Hashtbl.add complex_memo ct.ct_uid r;
link slot (content ct.ct_content);
r
......@@ -100,9 +108,9 @@ and get_complex ct =
and complex nil ct =
let c = get_complex ct in
if nil then
let (o,fields,content) = get_ct c in
let fields = LabelMap.union_disj fields xsi_nil_field_map' in
ior c (times (record o fields) (itype Sequence.nil_type))
let (attrs,content) = get_ct c in
let attrs = Types.Record.merge attrs xsi_nil_type in
ior c (itype (Types.times (Types.cons attrs) Sequence.nil_node))
else c
and content = function
......@@ -112,42 +120,24 @@ and content = function
let regexp = regexp_of_particle particle in
rexp (if mixed then mix regexp else regexp)
(** @return a closed record *)
and attr_uses (attrs,other) =
(* TODO: produce directly internal types *)
(* (is it better ? we wouln't benefit from hash-consing) *)
let fields =
List.map
(fun at ->
let r =
match at.attr_use_cstr with
| Some (`Fixed v) ->
itype (Types.constant (Value.inv_const v))
| _ -> itype (simple_type at.attr_decl.attr_typdef)
in
let r = if at.attr_required then r else optional r in
(LabelPool.mk at.attr_decl.attr_name, (r,None)))
attrs in
record other (LabelMap.from_list_disj fields)
and att_decl att =
let r = itype (simple_type att.attr_typdef) in
record false
(LabelMap.from_list_disj [(LabelPool.mk att.attr_name, (r,None))])
and elt_decl elt =
let atom_type =
itype (Types.atom (Atoms.atom (Atoms.V.of_qname elt.elt_name)))
in
let content=complex_type_def elt.elt_nillable (Lazy.force elt.elt_typdef) in
let content =
match elt.elt_cstr,elt.elt_nillable with
| Some (`Fixed _), true ->
failwith "Fixed value constraint and nillable are incompatible"
| Some (`Fixed v), false ->
itype (Types.constant (Value.inv_const v))
| _, nil -> complex_type_def nil (Lazy.force elt.elt_typdef)
in
match elt.elt_cstr with
| Some (`Fixed (_,v)) ->
iand content (
itype (Types.times
(Types.cons Types.any)
(Types.cons (Types.constant (Value.inv_const v)))))
| _ -> content in
xml atom_type content
and complex_type_def nil = function
| AnyType ->
itype (Types.times
......@@ -163,23 +153,19 @@ and complex_type_def nil = function
if nil then
Types.cup nonnil
(Types.times
(Types.cons (Types.record' (false,xsi_nil_field_map)))
(Types.cons xsi_nil_type)
(Types.cons Sequence.nil_type))
else nonnil in
itype t
| Complex ct -> complex nil ct
let complex_type ct = xml (itype Types.any) (complex false ct)
let model_group g = rexp (regexp_of_model_group g)
let type_def = function
| AnyType -> xsd_any_type
| Simple st -> simple_type st
| Complex ct -> get_type (complex_type ct)
| Complex ct -> get_type (xml (itype Types.any) (complex false ct))
let elt_decl x = get_type (elt_decl x)
let att_decl x = get_type (att_decl x)
let attr_uses x = get_type (attr_uses x)
let model_group x = get_type (model_group x.mg_def)
let attr_group ag = attr_uses ag.ag_def
......@@ -206,8 +192,6 @@ let load_schema schema_name uri =
) lst
in
let schema = Schema_parser.schema_of_uri uri in
(* defs "attribute" (fun a -> a.attr_name) att_decl
(fun _ _ -> assert false) schema.attributes; *)
defs "attribute group" (fun ag -> ag.ag_name) attr_group
validate_attribute_group schema.attribute_groups;
defs "model group" (fun mg -> mg.mg_name) model_group
......
......@@ -39,29 +39,24 @@ let bool_attr attr n =
| s ->
error ("Invalid boolean value (" ^ s ^ ") for attribute " ^ attr))
(* element and complex type constructors which take cares of unique id *)
let element, complex =
let counter = ref 0 in
let element name type_def constr nillable =
incr counter;
{ elt_uid = !counter;
elt_name = name;
elt_typdef = type_def;
elt_cstr = constr;
elt_nillable = nillable
}
in
let complex name (type_def: type_definition) deriv attrs ct =
incr counter;
{ ct_uid = !counter;
ct_name = name;
ct_typdef = type_def;
ct_deriv = deriv;
ct_attrs = attrs;
ct_content = ct;
}
in
(element, complex)
let element name type_def constr nillable =
{ elt_name = name;
elt_typdef = type_def;
elt_cstr = constr;
elt_nillable = nillable
}
let counter = ref 0
let complex name (type_def: type_definition) deriv attrs ct =
incr counter;
{ ct_uid = !counter;
ct_name = name;
ct_typdef = type_def;
ct_deriv = deriv;
ct_attrs = attrs;
ct_content = ct;
}
let space_RE = pcre_regexp " "
let split s = pcre_split ~rex:space_RE s
......@@ -129,10 +124,10 @@ let parse_facets base n =
let default_fixed n f =
match _may_attr "default" n with
| Some v -> Some (`Default (f v))
| Some v -> Some (`Default (v,(f v)))
| None ->
match _may_attr "fixed" n with
| Some v -> Some (`Fixed (f v))
| Some v -> Some (`Fixed (v,(f v)))
| None -> None
let parse_att_value_constraint st n =
......
......@@ -28,7 +28,7 @@ type facets = {
}
and value_ref = Value.t
and value_constraint = [ `Fixed of value_ref | `Default of value_ref ]
and value_constraint = [ `Fixed of Utf8.t * Value.t | `Default of Utf8.t * Value.t ]
and type_ref = type_definition Lazy.t
......@@ -77,8 +77,7 @@ and particle =
part_nullable: bool }
and element_declaration =
{ elt_uid: int;
elt_name: Ns.qname;
{ elt_name: Ns.qname;
elt_typdef: type_ref;
elt_cstr: value_constraint option;
elt_nillable: bool;
......@@ -132,5 +131,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
| E_char_data of Encodings.Utf8.t
| E_attribute of Ns.qname * Utf8.t
| E_char_data of Utf8.t
......@@ -28,7 +28,8 @@ type facets = {
}
and value_ref = Value.t
and value_constraint = [ `Fixed of value_ref | `Default of value_ref ]
and value_constraint =
[ `Fixed of Utf8.t * Value.t | `Default of Utf8.t * Value.t ]
and type_ref = type_definition Lazy.t
......@@ -77,8 +78,7 @@ and particle =
part_nullable: bool }
and element_declaration =
{ elt_uid: int;
elt_name: Ns.qname;
{ elt_name: Ns.qname;
elt_typdef: type_ref;
elt_cstr: value_constraint option;
elt_nillable: bool;
......@@ -132,5 +132,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
| E_char_data of Encodings.Utf8.t
| E_attribute of Ns.qname * Utf8.t
| E_char_data of Utf8.t
......@@ -14,7 +14,6 @@ let ppf = Format.std_formatter
(** {2 Misc} *)
let empty_string = string_utf8 (Utf8.mk "")
let empty_record = Value.vrecord []
let foo_atom = Value.Atom (Atoms.V.mk_ascii "foo")
let foo_event = E_char_data (Utf8.mk "")
......@@ -39,6 +38,9 @@ type context = {
let subctx mixed ctx = { ctx with ctx_current = Value.nil; ctx_mixed = mixed }
let push_str ctx s =
{ ctx with ctx_stream = Stream.icons (E_char_data s) ctx.ctx_stream }
let get ctx = ctx.ctx_current
let rec only_ws s i =
......@@ -112,6 +114,11 @@ let expect_end_tag ctx =
| E_end_tag _ -> ()
| ev -> error (sprintf "Expected end tag, found %s" (string_of_event ev))
let is_end_tag ctx =
match peek ctx with
| E_end_tag _ -> true
| ev -> false
let check_nil ctx =
match peek ctx with
| E_end_tag _ -> ()
......@@ -283,9 +290,6 @@ let rec validate_simple_type def s = match def with
Schema_facets.facets_valid facets value;
value
let validate_simple_type_wrapper ctx st_def =
validate_simple_type st_def (get_string ctx)
(** {2 Complex type validation} *)
let rec validate_any_type ctx =
......@@ -343,7 +347,7 @@ let validate_attribute_uses attrs (attr_uses,anyattr) =
let a = QTable.find tbl qname in
let value = validate_simple_type a.attr_decl.attr_typdef value in
(match a.attr_use_cstr with (* check fixed constraint *)
| Some (`Fixed v) -> check_fixed v value
| Some (`Fixed (_,v)) -> check_fixed v value
| _ -> ());
QTable.remove tbl qname;
value
......@@ -363,7 +367,7 @@ let validate_attribute_uses attrs (attr_uses,anyattr) =
(Ns.QName.to_string qname))
else (* add default values *)
match at.attr_use_cstr with
| Some (`Default v) -> attribs := (qname, v) :: !attribs
| Some (`Default (_,v)) -> attribs := (qname, v) :: !attribs
| _ -> ())
tbl;
Value.vrecord !attribs
......@@ -373,13 +377,15 @@ let rec validate_element ctx elt =
let attrs = get_attributes ctx in
if (attrs.xsi_nil && not elt.elt_nillable) then
error "xsi:nil attribute on non-nillable element";
let (attrs, content) = validate_type_ref ctx attrs elt.elt_typdef in
let content = (* use default if needed and check fixed constraints *)
match elt.elt_cstr with
| Some (`Default v) when Value.equal content empty_string -> v
| Some (`Fixed v) -> check_fixed v content; content
| _ -> content
in
let is_empty = is_end_tag ctx in
let ctx =
match is_empty, elt.elt_cstr with
| true, Some (`Default (v,_) | `Fixed (v,_)) -> push_str ctx v
| _ -> ctx in
let (attrs, content) = validate_type ctx attrs (Lazy.force elt.elt_typdef) in
(match is_empty, elt.elt_cstr with
| false, Some (`Fixed (_,v)) -> check_fixed v content
| _ -> ());
expect_end_tag ctx;
xml elt.elt_name attrs content
......@@ -391,12 +397,9 @@ and validate_type ctx attrs = function
if attrs.xsi_nil then (check_nil ctx;
Value.vrecord [xsi_nil_qname,Value.vtrue],
Value.nil)
else (empty_record, validate_simple_type_wrapper ctx st_def)
else (empty_record, validate_simple_type st_def (get_string ctx))
| Complex ct_def -> validate_complex_type ctx attrs ct_def
and validate_type_ref ctx attrs x =
validate_type ctx attrs (Lazy.force x)
and validate_complex_type ctx attrs ct =
let content =
if attrs.xsi_nil then (check_nil ctx; Value.nil)
......@@ -409,7 +412,7 @@ and validate_content_type ctx content_type =
| CT_empty ->
Value.nil
| CT_simple st_def ->
validate_simple_type_wrapper ctx st_def
validate_simple_type st_def (get_string ctx)
| CT_model (particle, mixed) ->
let mixold = ctx.ctx_mixed in
let ctx = subctx mixed ctx in
......
......@@ -1066,7 +1066,7 @@ module IType = struct
let get_ct c =
match c.desc with
| ITimes ({ desc = IRecord (o,fields) },content) -> (o,fields,content)
| ITimes ({ desc = IType (t,_) },content) -> (t,content)
| _ -> assert false
......
......@@ -72,13 +72,14 @@ module IType : sig
val link: node -> node -> unit
val ior: node -> node -> node
val iand: node -> node -> node
val times: node -> node -> node
val record: bool -> (node * node option) Ident.label_map -> node
val xml: node -> node -> node
val optional: node -> node
val get_ct: node -> bool * (node * node option) Ident.label_map * node
val get_ct: node -> Types.t * node
(* Regular expression *)
type regexp
......
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