Commit 63a58341 authored by Pietro Abate's avatar Pietro Abate

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

Original author: afrisch
Date: 2005-03-13 14:54:00+00:00
parent 1dff15fb
......@@ -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
......
......@@ -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
......
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
This diff is collapsed.
open Ident
type t
val serialize: t Serialize.Put.f
val deserialize: t Serialize.Get.f
exception NonExhaustive of Types.descr
exception Constraint of Types.descr * Types.descr
exception ShouldHave of Types.descr * string
......@@ -8,16 +12,8 @@ exception UnboundId of id * bool
exception UnboundExtId of Types.CompUnit.t * id
exception ShouldHave2 of Types.descr * string * Types.descr
exception Error of string
exception Warning of string * Types.t
include Custom.T
val from_comp_unit: (Types.CompUnit.t -> t) ref
val has_comp_unit: (U.t -> bool) ref
val has_ocaml_unit: (U.t -> bool) ref
val has_static_external: (string -> bool) ref
val empty_env: t
val register_types : Types.CompUnit.t -> t -> unit
......@@ -63,3 +59,44 @@ type type_fun = Types.t -> bool -> Types.t
val register_op: string -> int -> (type_fun list -> type_fun) -> unit
val flatten: type_fun -> type_fun
module IType : sig
type node
val get_type: node -> Types.t
val itype: Types.t -> node
val delayed: unit -> node
val link: node -> node -> unit
val ior: 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
(* Regular expression *)
type regexp
val rexp: regexp -> node
val simplify_regexp: regexp -> regexp
val eps: regexp
val emp: regexp
val seq: regexp -> regexp -> regexp
val alt: regexp -> regexp -> regexp
val star: regexp -> regexp
val mix: regexp -> regexp
val elem: node -> regexp
end
(* Foward definitions *)
val from_comp_unit: (Types.CompUnit.t -> t) ref
val has_comp_unit: (U.t -> bool) ref
val has_ocaml_unit: (U.t -> bool) ref
val has_static_external: (string -> bool) ref
val load_schema:
(U.t -> string -> (Types.t * (Value.t -> Value.t)) Ident.Env.t) ref
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