Skip to content

GitLab

Commit 2c40dd58 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-02-24 17:04:46 by afrisch] Clean 

Original author: afrisch
Date: 2005-02-24 17:04:46+00:00
parent 82ba4946
Hide whitespace changes
Inline Side-by-side
typing/typer.ml
View file @ 2c40dd58
......@@ -1567,7 +1567,6 @@ module Schema_converter =
(* TODO: better approx *)
let xsd_any_type = Types.any
(* auxiliary functions *)
let nil_type = itype Sequence.nil_type
......@@ -1589,15 +1588,13 @@ module Schema_converter =
| None -> seq min_regexp (PStar base)
let mk_seq_derecurs base facets =
match facets with
| { length = Some (v, _) } ->
Sequence.repet v (Some v) base
| { minLength = Some (v, _); maxLength = None } ->
Sequence.repet v None base
| { minLength = None; maxLength = Some (v, _) } ->
Sequence.repet 1 (Some v) base
| _ ->
Sequence.repet 1 (Some 1) base
let min,max = match facets with
| { length = Some (v, _) } -> v, Some v
| { minLength = Some (v, _); maxLength = None } -> v, None
| { minLength = None; maxLength = Some (v, _) } -> 1, Some v
| { minLength = Some (a,_); maxLength = Some (b, _) } -> a, Some b
| _ -> 1, Some 1 in
Sequence.repet min max base
let pcdata = PStar (PElem (itype (Types.char Chars.any)))
let mix_regexp regexp =
......@@ -1612,10 +1609,7 @@ module Schema_converter =
in
seq pcdata (seq (aux regexp) pcdata)
(* conversion functions *)
let loop_detect = ref []
let rec cd_type_of_simple_type = function
let rec simple_type = function
| { st_name = Some name }
when Schema_builtin.is name ->
Schema_builtin.cd_type (Schema_builtin.get name)
......@@ -1634,25 +1628,14 @@ module Schema_converter =
(* TODO: apply facets *)
Schema_builtin.cd_type (Schema_builtin.of_st st)
| { st_variety = List item; st_facets = facets } ->
mk_seq_derecurs (cd_type_of_simple_type item) facets
mk_seq_derecurs (simple_type item) facets
| { st_variety = Union members; st_facets = facets } ->
let members = List.map cd_type_of_simple_type members in
let members = List.map simple_type members in
List.fold_left (fun acc x -> Types.cup x acc) Types.empty members
(* and cd_type_of_simple_type_ref r =
if List.memq r !loop_detect then failwith "Loop between simple types"
else
(loop_detect := r :: !loop_detect;
let res =
cd_type_of_simple_type (Schema_common.get_simple_type r)
in
loop_detect := List.tl !loop_detect;
res)
*)
let rec regexp_of_term = function
| Model group -> regexp_of_model_group group
| Elt decl -> PElem (cd_type_of_elt_decl decl)
| Elt decl -> PElem (elt_decl decl)
and regexp_of_model_group = function
| Choice l ->
......@@ -1666,33 +1649,28 @@ module Schema_converter =
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)
and resolve_complex ct =
and complex ct =
try Hashtbl.find complex_memo ct.ct_uid
with Not_found ->
let slot = delayed noloc in
Hashtbl.add complex_memo ct.ct_uid slot;
slot.desc <- compute_complex ct;
slot.desc <- ITimes (attr_uses ct.ct_attrs, content ct.ct_content);
slot
and compute_complex ct =
let content_ast_node = match ct.ct_content with
| CT_empty -> itype Sequence.nil_type
| CT_simple st -> itype (cd_type_of_simple_type st)
| CT_model (particle, mixed) ->
let regexp = regexp_of_particle particle in
let regexp = if mixed then mix_regexp regexp else regexp in
rexp regexp
in
ITimes (cd_type_of_attr_uses ct.ct_attrs, content_ast_node);
and content = function
| CT_empty -> itype Sequence.nil_type
| CT_simple st -> itype (simple_type st)
| CT_model (particle, mixed) ->
let regexp = regexp_of_particle particle in
let regexp = if mixed then mix_regexp regexp else regexp in
rexp regexp
(** @return a closed record *)
and cd_type_of_attr_uses attr_uses =
and attr_uses attr_uses =
(* TODO: produce directly internal types *)
(* (is it better ? we wouln't benefit from hash-consing) *)
let fields =
......@@ -1702,58 +1680,51 @@ module Schema_converter =
match at.attr_use_cstr with
| Some (`Fixed v) ->
itype (Types.constant (Value.inv_const v))
| _ -> itype (cd_type_of_simple_type at.attr_decl.attr_typdef)
| _ -> itype (simple_type at.attr_decl.attr_typdef)
in
let r = if at.attr_required then r else mk (IOptional r) in
(LabelPool.mk at.attr_decl.attr_name, (r,None)))
attr_uses in
mk (IRecord (false, LabelMap.from_list_disj fields))
and cd_type_of_att_decl att =
let r = itype (cd_type_of_simple_type att.attr_typdef) in
and att_decl att =
let r = itype (simple_type att.attr_typdef) in
mk (IRecord (false,
LabelMap.from_list_disj
[(LabelPool.mk att.attr_name, (r,None))]))
and cd_type_of_elt_decl elt =
and elt_decl elt =
let atom_type =
itype (Types.atom (Atoms.atom (Atoms.V.of_qname elt.elt_name)))
in
let content =
match elt.elt_cstr with
| Some (`Fixed v) ->
itype (Types.constant (Value.inv_const v))
| _ ->
(match Lazy.force elt.elt_typdef with
| AnyType -> itype xsd_any_type
| Simple st ->
mk (ITimes
(itype Types.empty_closed_record,
itype (cd_type_of_simple_type st)))
| Complex ct -> resolve_complex ct)
| Some (`Fixed v) -> itype (Types.constant (Value.inv_const v))
| _ -> complex_type_def (Lazy.force elt.elt_typdef)
in
mk (IXml (atom_type, content))
and complex_type_def = function
| AnyType -> itype xsd_any_type
| Simple st ->
itype (Types.times
(Types.cons Types.empty_closed_record)
(Types.cons (simple_type st)))
| Complex ct -> complex ct
let cd_type_of_complex_type ct = mk (IXml (itype Types.any, resolve_complex ct))
let complex_type ct = mk (IXml (itype Types.any, complex ct))
let cd_type_of_model_group g =
rexp (regexp_of_model_group g)
let model_group g = rexp (regexp_of_model_group g)
let typ r =
check_delayed ();
IType.typ_descr r
let typ r = check_delayed (); IType.typ_descr r
(* Schema_converter interface implementation.
* Shadows previous definitions.
*)
let cd_type_of_type_def = function
let type_def = function
| AnyType -> xsd_any_type
| Simple st -> 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)
| Simple st -> simple_type st
| Complex ct -> typ (complex_type ct)
let elt_decl x = typ (elt_decl x)
let att_decl x = typ (att_decl x)
let attr_uses x = typ (attr_uses x)
let model_group x = typ (model_group x)
end
let get_schema_names env = UEnv.fold (fun n _ acc -> n :: acc) env.schemas []
......@@ -1783,27 +1754,27 @@ let load_schema schema_name uri =
List.iter (* Schema types -> CDuce types *)
(fun type_def ->
let name = Schema_common.name_of_type_definition type_def in
let cd_type = Schema_converter.cd_type_of_type_def type_def in
let cd_type = Schema_converter.type_def type_def in
log_schema_component "type" uri name cd_type;
Hashtbl.add !schema_types (uri, name) cd_type)
schema.Schema_types.types;
List.iter (* Schema attributes -> CDuce types *)
(fun att_decl ->
let cd_type = Schema_converter.cd_type_of_att_decl att_decl in
let cd_type = Schema_converter.att_decl att_decl in
let name = Schema_common.name_of_attribute_declaration att_decl in
log_schema_component "attribute" uri name cd_type;
Hashtbl.add !schema_attributes (uri, name) cd_type)
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
let cd_type = Schema_converter.elt_decl elt_decl in
let name = Schema_common.name_of_element_declaration elt_decl in
log_schema_component "element" uri name cd_type;
Hashtbl.add !schema_elements (uri, name) cd_type)
schema.Schema_types.elements;
List.iter (* Schema attribute groups -> CDuce types *)
(fun ag ->
let cd_type = Schema_converter.cd_type_of_attr_uses ag.ag_def
let cd_type = Schema_converter.attr_uses ag.ag_def
in
log_schema_component "attribute group" uri ag.ag_name cd_type;
Hashtbl.add !schema_attribute_groups (uri, ag.ag_name) cd_type)
......@@ -1811,7 +1782,7 @@ let load_schema schema_name uri =
List.iter (* Schema model groups -> CDuce types *)
(fun mg ->
let cd_type =
Schema_converter.cd_type_of_model_group mg.mg_def in
Schema_converter.model_group mg.mg_def in
log_schema_component "model group" uri mg.mg_name cd_type;
Hashtbl.add !schema_model_groups (uri, mg.mg_name) cd_type)
schema.Schema_types.model_groups;
......
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