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

[r2003-10-24 09:36:47 by szach] - added support for schema {attribute,module} groups

- ported to new schema representation

Original author: szach
Date: 2003-10-24 09:36:47+00:00
parent 0d2d96f8
......@@ -178,6 +178,10 @@ let schemas = State.ref "Typer.schemas" StringSet.empty
let schema_types = State.ref "Typer.schema_types" (Hashtbl.create 51)
let schema_elements = State.ref "Typer.schema_elements" (Hashtbl.create 51)
let schema_attributes = State.ref "Typer.schema_attributes" (Hashtbl.create 51)
let schema_attribute_groups =
State.ref "Typer.schema_attribute_groups" (Hashtbl.create 51)
let schema_model_groups =
State.ref "Typer.schema_model_groups" (Hashtbl.create 51)
(* Eliminate Recursion, propagate Sequence Capture Variables *)
......@@ -501,9 +505,11 @@ and derecurs_def env b =
env
and derecurs_schema env kind schema item =
let elt () = fst (Hashtbl.find !schema_elements (schema, item)) in
let elt () = Hashtbl.find !schema_elements (schema, item) in
let typ () = Hashtbl.find !schema_types (schema, item) in
let att () = Hashtbl.find !schema_attributes (schema, item) in
let att_group () = Hashtbl.find !schema_attribute_groups (schema, item) in
let mod_group () = Hashtbl.find !schema_model_groups (schema, item) in
let rec do_try n = function
| [] ->
let s = Printf.sprintf
......@@ -511,10 +517,12 @@ and derecurs_schema env kind schema item =
failwith s
| f :: rem -> (try f () with Not_found -> do_try n rem) in
match kind with
| `Element -> do_try "element" [ elt ]
| `Type -> do_try "type" [ typ ]
| `Attribute -> do_try "atttribute" [ att ]
| `Any -> do_try "item" [ elt; typ; att ]
| Some `Element -> do_try "element" [ elt ]
| Some `Type -> do_try "type" [ typ ]
| Some `Attribute -> do_try "atttribute" [ att ]
| Some `Attribute_group -> do_try "attribute group" [ att_group ]
| Some `Model_group -> do_try "model group" [ mod_group ]
| None -> do_try "item" [ elt; typ; att; att_group; mod_group ]
let rec fv_slot s =
......@@ -1094,7 +1102,7 @@ and type_check' loc env e constr precise = match e with
| Validate (e, schema_name, elt_name) ->
ignore (type_check env e Types.any false);
let t = fst (Hashtbl.find !schema_elements (schema_name, elt_name)) in
let t = Hashtbl.find !schema_elements (schema_name, elt_name) in
verify loc t constr
| Ref (e,t) ->
......@@ -1287,8 +1295,6 @@ let type_let_funs env funs =
(* Schema stuff from now on ... *)
let debug = true
(** convertion from XML Schema types (including global elements and
attributes) to CDuce Types.descr *)
module Schema_converter =
......@@ -1299,18 +1305,82 @@ module Schema_converter =
(* auxiliary functions *)
(* build a regexp Elem from a Types.descr *)
let mk_re_elt descr = PElem descr
let nil_type = PType Sequence.nil_type
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 ->
PSeq (re, repeat_regexp re (Intervals.V.pred n))
| _ -> assert false
in
let min = match min with Some min -> min | _ -> Intervals.V.one in
let min_regexp = repeat_regexp base min in
match max with
| Some max ->
assert (max >= min);
let rec aux acc = function
| z when Intervals.V.is_zero z -> acc
| n ->
aux (PAlt (PEpsilon, (PSeq (base, acc)))) (Intervals.V.pred n)
in
PSeq (min_regexp, aux PEpsilon (Intervals.V.sub max min))
| None -> PSeq (min_regexp, PStar base)
(* given a base derecurs create a derecurs value representing a sequence
* type according to length constraints members of facets *)
let mk_seq_derecurs ~base facets =
match facets with
| { length = Some (v, _) } ->
PRegexp (mk_len_regexp ~min:v ~max:v base, nil_type)
| { minLength = Some (v, _); maxLength = None } ->
PRegexp (mk_len_regexp ~min:v base, nil_type)
| { minLength = None; maxLength = Some (v, _) } ->
PRegexp (mk_len_regexp ~max:v base, nil_type)
| _ -> PRegexp (base, nil_type)
(* conversion functions *)
let cd_type_of_simple_type = function
| SBuilt_in name -> PType (Schema_builtin.cd_type_of_builtin name)
| SUser_defined (_, _, _, _) -> assert false (* TODO *)
let rec cd_type_of_simple_type = function
| Primitive name | Derived (Some name, _, _, _)
when Schema_builtin.is_builtin name ->
PType (Schema_builtin.cd_type_of_builtin name)
| Primitive _ -> assert false (* all primitives are built-in *)
| Derived (_, _, { enumeration = Some values }, _) -> (* enumeration *)
PType (Types.choice_of_list
(List.map (fun c -> Types.constant (Value.inv_const c))
(Value.ValueSet.elements values)))
| Derived (_, _, ({ maxInclusive = Some _ } as facets), _)(* boundaries *)
| Derived (_, _, ({ maxExclusive = Some _ } as facets), _)
| Derived (_, _, ({ minInclusive = Some _ } as facets), _)
| Derived (_, _, ({ minExclusive = Some _ } as facets), _) ->
PType (Types.interval (Schema_common.get_interval facets))
| Derived (_, Atomic (Primitive "xsd:string"), facets, _) (* length *)
| Derived (_, Atomic (Primitive "xsd:anyURI"), facets, _) ->
mk_seq_derecurs ~base:(PElem (PType Builtin_defs.char)) facets
| Derived (_, Atomic (Primitive "xsd:hexBinary"), facets, _)
| Derived (_, Atomic (Primitive "xsd:base64Binary"), facets, _) ->
mk_seq_derecurs ~base:(PElem (PType Builtin_defs.char_latin1)) facets
| Derived (_, Atomic (Primitive name), _, _) ->
(* no other interesting facet *)
PType (Schema_builtin.cd_type_of_builtin name)
| Derived (_, Atomic _, facets, _) -> assert false
| Derived (_, List item, facets, _) ->
mk_seq_derecurs ~base:(PElem (cd_type_of_simple_type item)) facets
| Derived (_, Union items, facets, _) ->
(match List.map cd_type_of_simple_type items with
| [] -> assert false (* vacuum union *)
| [t] -> t (* useless union *)
| hd::tl -> List.fold_left (fun acc x -> POr (x, acc)) hd tl)
let complex_memo = Hashtbl.create 213
let element_memo = Hashtbl.create 213
let rec regexp_of_term = function
| Model group -> regexp_of_model_group group
| Elt decl -> PElem (cd_type_of_elt_decl !decl)
and regexp_of_model_group = function
| All [] | Choice [] | Sequence [] -> PEpsilon
| Choice (hd :: tl) ->
List.fold_left
......@@ -1320,99 +1390,91 @@ module Schema_converter =
List.fold_left
(fun acc particle -> PSeq (acc, regexp_of_particle particle))
(regexp_of_particle hd) tl
| Elt decl -> mk_re_elt (cd_type_of_elt_decl !decl)
and regexp_of_content_type = function
| CT_empty -> PEpsilon
| CT_simple st -> mk_re_elt (cd_type_of_simple_type st)
| CT_simple st -> PElem (cd_type_of_simple_type st)
| CT_model (particle, mixed) ->
assert (not mixed); (* TODO mixed support *)
regexp_of_particle particle
and regexp_of_particle =
(* given a regexp re and a (non negative) integer n create a regexp
matching exactly n times re *)
let rec repeat_regexp re = function
| 0 -> PEpsilon
| n when n > 0 -> PSeq (re, repeat_regexp re (n - 1))
| _ -> assert false
in
fun (min, max, term) ->
let term_regexp = regexp_of_term term in
let min_regexp = repeat_regexp term_regexp min in
match max with
| Some max ->
assert (max >= min);
let rec aux acc = function
| 0 -> acc
| n ->
aux
(PAlt (PEpsilon, (PSeq (term_regexp, acc))))
(n - 1)
in
PSeq (min_regexp, aux PEpsilon (max - min))
| None -> PSeq (min_regexp, PStar term_regexp)
and regexp_of_particle (min, max, term) =
mk_len_regexp ?min:(Some min) ?max (regexp_of_term term)
(** @return a pair composed by a type for the attributes (a record) and a
type for the content model (a sequence) *)
and cd_type_of_complex_type' = function
| CBuilt_in name -> assert false
| CUser_defined (id, name, _, _, attr_uses, content) ->
try PAlias (Hashtbl.find complex_memo id)
with Not_found ->
let slot = mk_derecurs_slot noloc in
Hashtbl.add complex_memo id slot;
let content_re = regexp_of_content_type content in
let content_ast_node = PRegexp (content_re, PType Sequence.nil_type) in
slot.pdescr <-
PTimes (cd_type_of_attr_uses attr_uses, content_ast_node);
PAlias slot
and cd_type_of_complex_type' (id, name, _, _, attr_uses, content) =
try
PAlias (Hashtbl.find complex_memo id)
with Not_found ->
let slot = mk_derecurs_slot noloc in
Hashtbl.add complex_memo id slot;
let content_re = regexp_of_content_type content in
let content_ast_node = PRegexp (content_re, PType Sequence.nil_type) in
slot.pdescr <-
PTimes (cd_type_of_attr_uses attr_uses, content_ast_node);
PAlias slot
(* TODO if constraint is Fixed we can give a more precise CDuce type *)
(** @return a closed record *)
and cd_type_of_attr_uses attr_uses =
let fields =
List.map
(fun (required, (name, st, _), _) ->
let r = cd_type_of_simple_type st in
let r = if required then r else POptional r in
(LabelPool.mk (Ns.empty, U.mk name), r) (* TODO: NS *)
) attr_uses in
(fun (required, (name, st, _), constr) ->
let r =
match constr with
| Some (`Fixed v) -> PType (Types.constant (Value.inv_const v))
| _ -> cd_type_of_simple_type st
in
let r = if required then r else POptional r in
(LabelPool.mk (Ns.empty, U.mk name), r)) (* TODO: NS *)
attr_uses in
PRecord (false, LabelMap.from_list_disj fields)
and cd_type_of_att_decl (name, st, _) =
let r = cd_type_of_simple_type st in
PRecord (false, LabelMap.from_list_disj [(LabelPool.mk (Ns.empty, U.mk name), r)])
PRecord (false,
LabelMap.from_list_disj [(LabelPool.mk (Ns.empty, U.mk name), r)])
(* TODO: NS *)
and cd_type_of_elt_decl (name, typ, _) =
let atom_type = PType (Types.atom (Atoms.atom (Atoms.V.mk Ns.empty (U.mk name)))) in
let content = match !typ with
| S st ->
PTimes (PType Types.empty_closed_record, cd_type_of_simple_type st)
| C ct -> cd_type_of_complex_type' ct
and cd_type_of_elt_decl (_, name, typ, constr) =
let atom_type =
PType (Types.atom (Atoms.atom (Atoms.V.mk Ns.empty (U.mk name))))
in
let content =
match constr with
| Some (`Fixed v) -> PType (Types.constant (Value.inv_const v))
| _ ->
(match !typ with
| AnyType -> PType (Schema_builtin.cd_type_of_builtin "xsd:anyType")
| Simple st ->
PTimes
(PType Types.empty_closed_record, cd_type_of_simple_type st)
| Complex ct -> cd_type_of_complex_type' ct)
in
PXml (atom_type, content)
let typ r = Types.descr (do_typ noloc r)
let cd_type_of_complex_type ct =
PXml (PType Types.any, cd_type_of_complex_type' ct)
let cd_type_of_complex_type = function
| CBuilt_in name -> Schema_builtin.cd_type_of_builtin name
| ct -> typ (PXml (PType Types.any, cd_type_of_complex_type' ct))
let cd_type_of_model_group g = PRegexp (regexp_of_model_group g, nil_type)
let cd_type_of_type_def = function
| S st -> typ (cd_type_of_simple_type st)
| C ct -> cd_type_of_complex_type ct
let typ r = Types.descr (do_typ noloc r)
(* Schema_converter interface implementation.
* Shadows previous definitions.
*)
let cd_type_of_type_def = function
| AnyType -> Schema_builtin.cd_type_of_builtin "xsd:anyType"
| Simple st -> typ (cd_type_of_simple_type st)
| Complex ct -> typ (cd_type_of_complex_type ct)
let cd_type_of_elt_decl x = typ (cd_type_of_elt_decl x)
let cd_type_of_att_decl x = typ (cd_type_of_att_decl x)
let cd_type_of_attr_uses x = typ (cd_type_of_attr_uses x)
let cd_type_of_model_group x = typ (cd_type_of_model_group x)
end
let get_schema_validator (schema_name, elt_name) =
snd (Hashtbl.find !schema_elements (schema_name, elt_name))
let debug = true
let register_schema schema_name schema =
if StringSet.mem schema_name !schemas then
......@@ -1423,28 +1485,34 @@ let register_schema schema_name schema =
(fun type_def ->
let cd_type = Schema_converter.cd_type_of_type_def type_def in
Hashtbl.add !schema_types
(schema_name, Schema_types.name_of_type_def type_def)
(schema_name, Schema_common.name_of_type_definition type_def)
cd_type)
schema.Schema_types.type_defs;
schema.Schema_types.types;
List.iter (* Schema attributes -> CDuce types *)
(fun (att_name, _, _) as att_decl ->
let cd_type = Schema_converter.cd_type_of_att_decl att_decl in
Hashtbl.add !schema_attributes (schema_name, att_name) cd_type)
schema.Schema_types.att_decls;
List.iter (* Schema elements -> CDuce types * validators *)
schema.Schema_types.attributes;
List.iter (* Schema elements -> CDuce types *)
(fun elt_decl ->
let cd_type = Schema_converter.cd_type_of_elt_decl elt_decl in
if debug then
(Types.Print.print Format.std_formatter cd_type;
Format.fprintf Format.std_formatter "\n";
Format.pp_print_flush Format.std_formatter ());
let validator = Schema_validator.validator_of_elt_decl elt_decl in
Hashtbl.add !schema_elements
(schema_name, Schema_types.name_of_elt_decl elt_decl)
(cd_type, validator))
schema.Schema_types.elt_decls
(schema_name, Schema_common.name_of_element_declaration elt_decl)
cd_type)
schema.Schema_types.elements;
List.iter (* Schema attribute groups -> CDuce types *)
(fun (name, uses) ->
let cd_type = Schema_converter.cd_type_of_attr_uses uses in
Hashtbl.add !schema_attribute_groups (schema_name, name) cd_type)
schema.Schema_types.attribute_groups;
List.iter (* Schema model groups -> CDuce types *)
(fun (name, group) ->
let cd_type = Schema_converter.cd_type_of_model_group group in
Hashtbl.add !schema_model_groups (schema_name, name) cd_type)
schema.Schema_types.model_groups;
end
(* DEBUGGING ONLY *)
let get_schema_type x = fst (Hashtbl.find !schema_elements x)
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