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