Skip to content

GitLab

Commit 12d96cde authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-03-13 14:54:00 by afrisch] Clean 

Original author: afrisch
Date: 2005-03-13 14:54:00+00:00
parent 6788640d
Hide whitespace changes
Inline Side-by-side
Makefile.distrib
View file @ 12d96cde
......@@ -131,9 +131,7 @@ SCHEMA_OBJS = \
schema/schema_builtin.cmo \
schema/schema_validator.cmo \
schema/schema_parser.cmo \
NEW_SCHEMA_OBJS = \
schema/schema_components.cmo schema/schema_import.cmo \
schema/schema_converter.cmo
OBJECTS = \
driver/config.cmo \
......@@ -154,13 +152,14 @@ OBJECTS = \
runtime/value.cmo \
\
parser/location.cmo parser/url.cmo \
$(SCHEMA_OBJS) \
\
\
parser/ulexer.cmo parser/ast.cmo parser/parser.cmo \
\
types/externals.cmo \
typing/typed.cmo typing/typer.cmo \
\
$(SCHEMA_OBJS) \
\
runtime/load_xml.cmo runtime/run_dispatch.cmo \
runtime/explain.cmo \
runtime/print_xml.cmo runtime/eval.cmo \
......@@ -222,8 +221,9 @@ OBJECTS += $(CQL_OBJECTS_RUN)
OBJECTS += driver/run.cmo
CDUCE = $(OBJECTS) driver/start.cmo
ALL_OBJECTS = $(OBJECTS) $(NEW_SCHEMA_OBJS) \
driver/start.cmo driver/examples.cmo driver/webiface.cmo driver/evaluator.cmo \
ALL_OBJECTS = $(OBJECTS) \
driver/start.cmo driver/examples.cmo \
driver/webiface.cmo driver/evaluator.cmo \
tools/validate.cmo \
$(ML_INTERFACE_OBJS) parser/cduce_curl.cmo \
parser/cduce_netclient.cmo \
......@@ -239,11 +239,6 @@ cduce: $(CDUCE:.cmo=.$(EXTENSION))
@echo "Build $@"
$(HIDE)$(LINK) $(INCLUDES) -o $@ $^ $(EXTRA_LINK_OPTS)
test_schema: $(OBJECTS:.cmo=.$(EXTENSION)) $(NEW_SCHEMA_OBJS:.cmo=.$(EXTENSION))
@echo "Build $@"
$(HIDE)$(LINK) $(INCLUDES) -o $@ $^ $(EXTRA_LINK_OPTS)
cduce_packed.ml: $(CDUCE:.cmo=.ml)
rm -f cduce_packed.ml
ocaml tools/pack.ml $^ > cduce_packed.ml
......
depend
View file @ 12d96cde
......@@ -96,10 +96,10 @@ schema/schema_types.cmo: types/atoms.cmi misc/encodings.cmi misc/ns.cmi \
runtime/value.cmi schema/schema_types.cmi
schema/schema_types.cmx: types/atoms.cmx misc/encodings.cmx misc/ns.cmx \
runtime/value.cmx schema/schema_types.cmi
schema/schema_xml.cmo: misc/encodings.cmi parser/location.cmi misc/ns.cmi \
schema/schema_pcre.cmi schema/schema_xml.cmi
schema/schema_xml.cmx: misc/encodings.cmx parser/location.cmx misc/ns.cmx \
schema/schema_pcre.cmx schema/schema_xml.cmi
schema/schema_xml.cmo: misc/encodings.cmi misc/ns.cmi schema/schema_pcre.cmi \
schema/schema_xml.cmi
schema/schema_xml.cmx: misc/encodings.cmx misc/ns.cmx schema/schema_pcre.cmx \
schema/schema_xml.cmi
schema/schema_common.cmo: types/atoms.cmi misc/encodings.cmi types/ident.cmo \
misc/ns.cmi schema/schema_pcre.cmi schema/schema_types.cmi \
schema/schema_xml.cmi types/types.cmi runtime/value.cmi \
......@@ -155,21 +155,23 @@ typing/typed.cmo: types/ident.cmo parser/location.cmi misc/ns.cmi \
typing/typed.cmx: types/ident.cmx parser/location.cmx misc/ns.cmx \
types/patterns.cmx types/types.cmx
typing/typer.cmo: parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \
types/chars.cmi misc/encodings.cmi types/externals.cmi misc/html.cmi \
types/ident.cmo parser/location.cmi misc/ns.cmi types/patterns.cmi \
schema/schema_builtin.cmi schema/schema_common.cmi \
schema/schema_parser.cmi schema/schema_types.cmi \
schema/schema_validator.cmi schema/schema_xml.cmi types/sequence.cmi \
misc/serialize.cmi typing/typed.cmo types/types.cmi runtime/value.cmi \
typing/typer.cmi
types/chars.cmi types/externals.cmi misc/html.cmi types/ident.cmo \
parser/location.cmi misc/ns.cmi types/patterns.cmi types/sequence.cmi \
misc/serialize.cmi typing/typed.cmo types/types.cmi typing/typer.cmi
typing/typer.cmx: parser/ast.cmx types/atoms.cmx types/builtin_defs.cmx \
types/chars.cmx misc/encodings.cmx types/externals.cmx misc/html.cmx \
types/ident.cmx parser/location.cmx misc/ns.cmx types/patterns.cmx \
schema/schema_builtin.cmx schema/schema_common.cmx \
schema/schema_parser.cmx schema/schema_types.cmx \
types/chars.cmx types/externals.cmx misc/html.cmx types/ident.cmx \
parser/location.cmx misc/ns.cmx types/patterns.cmx types/sequence.cmx \
misc/serialize.cmx typing/typed.cmx types/types.cmx typing/typer.cmi
schema/schema_converter.cmo: types/atoms.cmi types/builtin_defs.cmi \
types/ident.cmo misc/ns.cmi schema/schema_builtin.cmi \
schema/schema_common.cmi schema/schema_parser.cmi schema/schema_types.cmi \
schema/schema_validator.cmi schema/schema_xml.cmi types/sequence.cmi \
typing/typer.cmi types/types.cmi runtime/value.cmi
schema/schema_converter.cmx: types/atoms.cmx types/builtin_defs.cmx \
types/ident.cmx misc/ns.cmx schema/schema_builtin.cmx \
schema/schema_common.cmx schema/schema_parser.cmx schema/schema_types.cmx \
schema/schema_validator.cmx schema/schema_xml.cmx types/sequence.cmx \
misc/serialize.cmx typing/typed.cmx types/types.cmx runtime/value.cmx \
typing/typer.cmi
typing/typer.cmx types/types.cmx runtime/value.cmx
runtime/load_xml.cmo: types/atoms.cmi misc/encodings.cmi types/ident.cmo \
parser/location.cmi misc/ns.cmi parser/url.cmi runtime/value.cmi \
runtime/load_xml.cmi
......@@ -189,13 +191,11 @@ runtime/explain.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/patterns.cmx runtime/run_dispatch.cmx \
types/types.cmx runtime/value.cmx runtime/explain.cmi
runtime/print_xml.cmo: types/atoms.cmi misc/encodings.cmi types/ident.cmo \
types/intervals.cmi parser/location.cmi misc/ns.cmi \
schema/schema_builtin.cmi types/sequence.cmi runtime/value.cmi \
runtime/print_xml.cmi
types/intervals.cmi misc/ns.cmi schema/schema_builtin.cmi \
types/sequence.cmi runtime/value.cmi runtime/print_xml.cmi
runtime/print_xml.cmx: types/atoms.cmx misc/encodings.cmx types/ident.cmx \
types/intervals.cmx parser/location.cmx misc/ns.cmx \
schema/schema_builtin.cmx types/sequence.cmx runtime/value.cmx \
runtime/print_xml.cmi
types/intervals.cmx misc/ns.cmx schema/schema_builtin.cmx \
types/sequence.cmx runtime/value.cmx runtime/print_xml.cmi
runtime/eval.cmo: runtime/explain.cmi types/ident.cmo compile/lambda.cmi \
misc/ns.cmi types/patterns.cmi runtime/run_dispatch.cmi \
schema/schema_common.cmi typing/typer.cmi types/types.cmi \
......@@ -270,18 +270,16 @@ ocamliface/mlstub.cmx: types/atoms.cmx types/builtin_defs.cmx \
driver/librarian.cmx parser/location.cmx ocamliface/mltypes.cmx \
misc/ns.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \
ocamliface/mlstub.cmi
parser/cduce_curl.cmo: driver/config.cmi parser/url.cmi
parser/cduce_curl.cmx: driver/config.cmx parser/url.cmx
runtime/cduce_pxp.cmo: driver/config.cmi runtime/load_xml.cmi \
parser/location.cmi schema/schema_xml.cmi parser/url.cmi \
runtime/cduce_pxp.cmi
runtime/cduce_pxp.cmx: driver/config.cmx runtime/load_xml.cmx \
parser/location.cmx schema/schema_xml.cmx parser/url.cmx \
runtime/cduce_pxp.cmi
parser/cduce_netclient.cmo: driver/config.cmi parser/location.cmi \
parser/url.cmi
parser/cduce_netclient.cmx: driver/config.cmx parser/location.cmx \
parser/url.cmx
runtime/cduce_expat.cmo: driver/config.cmi runtime/load_xml.cmi \
parser/location.cmi parser/url.cmi runtime/cduce_expat.cmi
parser/location.cmi schema/schema_xml.cmi parser/url.cmi \
runtime/cduce_expat.cmi
runtime/cduce_expat.cmx: driver/config.cmx runtime/load_xml.cmx \
parser/location.cmx parser/url.cmx runtime/cduce_expat.cmi
parser/location.cmx schema/schema_xml.cmx parser/url.cmx \
runtime/cduce_expat.cmi
query/query_aggregates.cmo: types/builtin_defs.cmi types/intervals.cmi \
compile/operators.cmi types/sequence.cmi runtime/value.cmi
query/query_aggregates.cmx: types/builtin_defs.cmx types/intervals.cmx \
......@@ -329,11 +327,17 @@ parser/cduce_netclient.cmo: driver/config.cmi parser/location.cmi \
parser/cduce_netclient.cmx: driver/config.cmx parser/location.cmx \
parser/url.cmx
runtime/cduce_expat.cmo: driver/config.cmi runtime/load_xml.cmi \
parser/location.cmi parser/url.cmi runtime/cduce_expat.cmi
parser/location.cmi schema/schema_xml.cmi parser/url.cmi \
runtime/cduce_expat.cmi
runtime/cduce_expat.cmx: driver/config.cmx runtime/load_xml.cmx \
parser/location.cmx parser/url.cmx runtime/cduce_expat.cmi
schema/schema_types.cmi: types/atoms.cmi misc/encodings.cmi misc/ns.cmi \
runtime/value.cmi
parser/location.cmx schema/schema_xml.cmx parser/url.cmx \
runtime/cduce_expat.cmi
runtime/cduce_pxp.cmo: driver/config.cmi runtime/load_xml.cmi \
parser/location.cmi schema/schema_xml.cmi parser/url.cmi \
runtime/cduce_pxp.cmi
runtime/cduce_pxp.cmx: driver/config.cmx runtime/load_xml.cmx \
parser/location.cmx schema/schema_xml.cmx parser/url.cmx \
runtime/cduce_pxp.cmi
misc/pool.cmi: misc/custom.cmo
misc/encodings.cmi: misc/custom.cmo misc/serialize.cmi
misc/bool.cmi: misc/custom.cmo
......
schema/schema_converter.ml 0 → 100644
View file @ 12d96cde
open Ident
open Schema_types
open Schema_common
open Schema_validator
open Encodings
open Typer.IType
let xsd = Schema_xml.xsd
let is_xsd (ns,l) local =
(Ns.equal ns xsd) && (String.compare (Utf8.get_str l) local = 0)
let complex_memo = Hashtbl.create 213
let rexp re = rexp (simplify_regexp re)
(* TODO: better approx *)
let xsd_any_type = Types.any
let nil_type = itype Sequence.nil_type
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)
in
seq min_regexp (aux eps (max-min))
| None -> seq min_regexp (star base)
let mk_seq_derecurs base facets =
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 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 rec simple_type = function
| { st_name = Some name }
when Schema_builtin.is name ->
Schema_builtin.cd_type (Schema_builtin.get name)
| { st_variety = Atomic st } ->
(* TODO: apply facets *)
Schema_builtin.cd_type (Schema_builtin.of_st st)
| { st_variety = List item; st_facets = facets } ->
mk_seq_derecurs (simple_type item) facets
| { st_variety = Union members; st_facets = facets } ->
let members = List.map simple_type members in
List.fold_left (fun acc x -> Types.cup x acc) Types.empty members
let rec regexp_of_term = function
| Model group -> regexp_of_model_group group
| Elt decl -> elem (elt_decl decl)
| Wildcard w -> elem (wildcard w)
and wildcard w =
itype (Builtin_defs.any_xml_with_tag w.wild_first)
and regexp_of_model_group = function
| Choice l ->
List.fold_left
(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))
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 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
Hashtbl.add complex_memo ct.ct_uid r;
link slot (content ct.ct_content);
r
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))
else c
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
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 =
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
xml atom_type content
and complex_type_def nil = function
| AnyType ->
itype (Types.times
(Types.cons Types.empty_open_record)
(Types.cons xsd_any_type))
| Simple st ->
let nonnil =
Types.times
(Types.cons Types.empty_closed_record)
(Types.cons (simple_type st))
in
let t =
if nil then
Types.cup nonnil
(Types.times
(Types.cons (Types.record' (false,xsi_nil_field_map)))
(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)
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
let load_schema schema_name uri =
let log_schema_component kind name cd_type =
if not (Schema_builtin.is name) then begin
Types.Print.register_global (Types.CompUnit.mk schema_name)
name cd_type;
Format.fprintf Format.std_formatter "Registering schema %s: %a@." kind
Ns.QName.print name;
end
in
let env = ref Env.empty in
let defs kind name cd_type v lst =
List.iter
(fun def ->
let name = name def in
let cd_type = cd_type def in
log_schema_component kind name cd_type;
env := Env.add (Ident.ident name) (cd_type, v def) !env
) 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
validate_model_group schema.model_groups;
defs "type" name_of_type_definition type_def validate_type schema.types;
defs "element" (fun e -> e.elt_name) elt_decl
validate_element schema.elements;
!env
let () = Typer.load_schema := load_schema
typing/typer.ml
View file @ 12d96cde
(* TODO:
- check whether it is worth using recursive hash-consing internally
*)
open Location
open Ast
open Ident
......@@ -27,15 +23,12 @@ exception WrongLabel of Types.descr * label
exception UnboundId of id * bool
exception UnboundExtId of Types.CompUnit.t * id
exception Error of string
exception Warning of string * Types.t
let raise_loc loc exn = raise (Location (loc,`Full,exn))
let raise_loc_str loc ofs exn = raise (Location (loc,`Char ofs,exn))
let error loc msg = raise_loc loc (Error msg)
type item =
| Type of Types.t
| Val of Types.t
......@@ -53,17 +46,17 @@ type t = {
cu: ext UEnv.t;
}
let hash _ = failwith "Typer.hash"
let compare _ _ = failwith "Typer.compare"
let dump ppf _ = failwith "Typer.dump"
let equal _ _ = failwith "Typer.equal"
let check _ = failwith "Typer.check"
let load_schema = ref (fun _ _ -> assert false)
let from_comp_unit = ref (fun _ -> assert false)
let has_comp_unit = ref (fun _ -> assert false)
let has_ocaml_unit = ref (fun _ -> false)
let has_static_external = ref (fun _ -> assert false)
let load_schema_fwd = ref (fun x uri -> assert false)
let schemas = Hashtbl.create 13
let type_schema env x uri =
!load_schema_fwd x uri;
if not (Hashtbl.mem schemas uri) then
Hashtbl.add schemas uri (!load_schema x uri);
{ env with cu = UEnv.add x (ESchema uri) env.cu }
(* TODO: filter out builtin defs ? *)
......@@ -76,10 +69,12 @@ let serialize s env =
Ns.serialize_table s env.ns;
let schs =
UEnv.fold (fun name cu accu ->
match cu with ESchema uri -> (name,uri)::accu | _ -> accu)
UEnv.fold
(fun name cu accu ->
match cu with ESchema uri -> (name,uri)::accu | _ -> accu)
env.cu [] in
Serialize.Put.list (Serialize.Put.pair U.serialize Serialize.Put.string) s schs
Serialize.Put.list
(Serialize.Put.pair U.serialize Serialize.Put.string) s schs
let deserialize_item s = match Serialize.Get.bits 1 s with
| 0 -> Type (Types.deserialize s)
......@@ -87,7 +82,8 @@ let deserialize_item s = match Serialize.Get.bits 1 s with
| _ -> assert false
let deserialize s =
let ids = Serialize.Get.env Id.deserialize deserialize_item Env.add Env.empty s in
let ids =
Serialize.Get.env Id.deserialize deserialize_item Env.add Env.empty s in
let ns = Ns.deserialize_table s in
let schs =
Serialize.Get.list
......@@ -103,12 +99,6 @@ let empty_env = {
cu = UEnv.empty;
}
let from_comp_unit = ref (fun (cu : Types.CompUnit.t) -> assert false)
let has_comp_unit = ref (fun cu -> assert false)
let has_ocaml_unit = ref (fun cu -> false)
let has_static_external = ref (fun _ -> assert false)
let enter_cu x cu env =
{ env with cu = UEnv.add x (ECDuce cu) env.cu }
......@@ -232,14 +222,16 @@ let rec const env loc = function
the internal form *)
(* Schema *)
(* uri -> schema binding *)
let schemas = Hashtbl.create 13
let get_schema_names env =
UEnv.fold
(fun n cu acc -> match cu with ESchema _ -> n :: acc | _ -> acc) env.cu []
let find_schema_component uri name =
Env.find (Ident.ident name) (Hashtbl.find schemas uri)
let get_schema_validator uri name =
snd (find_schema_component uri name)
let find_schema_descr uri (name : Ns.qname) =
try fst (find_schema_component uri name)
with Not_found ->
......@@ -624,6 +616,11 @@ module IType = struct
if (p1.desc == iempty.desc) || (p2.desc == iempty.desc) then iempty
else mk (IAnd (p1,p2))
let times x y = mk (ITimes (x,y))
let xml x y = mk (IXml (x,y))
let record o m = mk (IRecord (o,m))
let optional x = mk (IOptional x)
type regexp =
| PElem of node
| PGuard of node
......@@ -640,6 +637,8 @@ module IType = struct
let eps = PSeq []
let emp = PAlt []
let star x = PStar x
let elem x = PElem x
let seq r1 r2 =
let r1 = match r1 with PSeq l -> l | x -> [ x ] in
......@@ -731,6 +730,19 @@ module IType = struct
ior q_empty x
let pcdata = star (PElem (itype (Types.char Chars.any)))
let mix regexp =
let rec aux = function
| PSeq [] -> eps
| PElem re -> PElem re
| PGuard re -> assert false
| PSeq (r::rl) -> seq (aux r) (seq pcdata (aux (PSeq rl)))
| PAlt rl -> PAlt (List.map aux rl)
| PStar re -> star (seq pcdata (aux re))
| PWeakStar re -> assert false
in
seq pcdata (seq (aux regexp) pcdata)
let cst_nil = Types.Atom Sequence.nil_atom
let capture_all vars p =
IdSet.fold (fun p x -> iand p (mk (ICapture x))) p vars
......@@ -1029,7 +1041,8 @@ module IType = struct
with exn -> clean_on_err (); raise exn
let typ_descr d =
let get_type d =
check_delayed ();
try internalize d; typ d
with exn -> clean_on_err (); raise exn
......@@ -1047,6 +1060,16 @@ module IType = struct
try pat_node d
with Patterns.Error s -> raise_loc_generic t.loc s
with exn -> clean_on_err (); raise exn
let delayed () = delayed noloc
let link a b = a.desc <- ILink b
let get_ct c =
match c.desc with
| ITimes ({ desc = IRecord (o,fields) },content) -> (o,fields,content)
| _ -> assert false
end
let typ = IType.typ
......@@ -1766,274 +1789,6 @@ let type_let_funs env funs =
report_unused_branches ();
let env = enter_values typs env in
(env,funs,typs)
(* Schema stuff from now on ... *)
(** convertion from XML Schema types (including global elements and
attributes) to CDuce Types.descr *)
module Schema_converter =
struct
open Printf
open Schema_types
open Schema_common
open Encodings
open IType
let xsd = Schema_xml.xsd
let is_xsd (ns,l) local =
(Ns.equal ns xsd) && (String.compare (Utf8.get_str l) local = 0)
let complex_memo = Hashtbl.create 213
let rexp re = rexp (simplify_regexp re)
(* TODO: better approx *)
let xsd_any_type = Types.any
let nil_type = itype Sequence.nil_type
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)
in
seq min_regexp (aux eps (max-min))
| None -> seq min_regexp (PStar base)
let mk_seq_derecurs base facets =
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 xsi_nil_field_map =
LabelMap.singleton xsi_nil_label (Types.cons Builtin_defs.true_type)
let xsi_nil_field_map' =
LabelMap.singleton