Commit 1d59613c authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-03-04 01:16:24 by afrisch] More uniform treatment of cduce,ocaml,schema units

Original author: afrisch
Date: 2005-03-04 01:16:26+00:00
parent bbcdbaaa
......@@ -78,7 +78,7 @@ and compile_aux env tail = function
| Typed.Transform (e,brs) -> Transform
(compile env false e, compile_branches env false brs)
| Typed.Xtrans (e,brs) -> Xtrans (compile env false e, compile_branches env false brs)
| Typed.Validate (e,k,sch,t) -> Validate (compile env tail e, k, sch, t)
| Typed.Validate (e,sch,t) -> Validate (compile env tail e, sch, t)
| Typed.RemoveField (e,l) -> RemoveField (compile env tail e,l)
| Typed.Dot (e,l) -> Dot (compile env tail e, l)
| Typed.Try (e,brs) -> Try (compile env false e, compile_branches env tail brs)
......
......@@ -56,7 +56,7 @@ type expr =
| Transform of expr * branches
| Xtrans of expr * branches
| Try of expr * branches
| Validate of expr * schema_component_kind * string * Ns.qname
| Validate of expr * string * Ns.qname
| RemoveField of expr * label
| Dot of expr * label
| Ref of expr * Types.Node.t
......@@ -186,10 +186,9 @@ module Put = struct
bits nbits s 12;
expr s e;
branches s brs
| Validate (e,k,sch,t) ->
| Validate (e,sch,t) ->
bits nbits s 13;
expr s e;
serialize_schema_component_kind s k;
string s sch;
Ns.QName.serialize s t
(* assert false (* TODO:Need to store a pointer to the schema ... *) *)
......@@ -313,10 +312,9 @@ module Get = struct
Try (e,brs)
| 13 ->
let e = expr s in
let k = deserialize_schema_component_kind s in
let sch = string s in
let t = Ns.QName.deserialize s in
Validate (e,k,sch,t)
Validate (e,sch,t)
| 14 ->
let e = expr s in
let l = LabelPool.deserialize s in
......
......@@ -29,7 +29,7 @@ type expr =
| Transform of expr * branches
| Xtrans of expr * branches
| Try of expr * branches
| Validate of expr * schema_component_kind * string * Ns.qname
| Validate of expr * string * Ns.qname
| RemoveField of expr * label
| Dot of expr * label
| Ref of expr * Types.Node.t
......
......@@ -251,11 +251,6 @@ let directive ppf tenv cenv = function
(if !toplevel then raise End_of_file)
| `Env ->
dump_env ppf tenv cenv
| `Print_schema schema ->
let uri = Typer.find_schema schema tenv in
let sch = Typer.get_schema uri in
Schema_common.print_schema ppf sch;
flush_ppf ppf
| `Print_type t ->
let t = Typer.typ tenv t in
Format.fprintf ppf "%a@." Types.Print.print_noname (Types.descr t)
......
......@@ -81,6 +81,10 @@ let deserialize_dep =
*)
let has_obj n =
let base = Encodings.Utf8.to_string n ^ ".cdo" in
List.exists (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path
let find_obj id =
let base = Encodings.Utf8.to_string (C.value id) ^ ".cdo" in
let p =
......@@ -278,6 +282,7 @@ let import_from_string id str dig dep = ignore (load_from_string id str dig dep)
let () =
Typer.from_comp_unit := (fun cu -> (load cu).typing);
Typer.has_comp_unit := has_obj;
Compile.from_comp_unit := (fun cu -> (load cu).compile);
Eval.get_global := (fun cu i -> import_and_run cu; (load cu).vals.(i));
Eval.set_global := (fun cu i v -> import cu; (load cu).vals.(i) <- v);
......
......@@ -516,6 +516,8 @@ let stub name ty_env c_env values =
let register () =
Typer.has_ocaml_unit :=
(fun cu -> Mltypes.has_cmi (U.get_str cu));
Librarian.stub_ml :=
(fun cu ty_env c_env ->
try
......
......@@ -183,6 +183,11 @@ let unfold ty =
let unsupported s =
raise (Error (Printf.sprintf "Unsupport feature (%s) found in .cmi" s))
let has_cmi name =
Config.load_path := Config.standard_library :: !Librarian.obj_path;
try ignore (Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi")); true
with Not_found -> false
let read_cmi name =
Config.load_path := Config.standard_library :: !Librarian.obj_path;
let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
......
......@@ -24,3 +24,5 @@ val print_ocaml : Format.formatter -> Types.type_expr -> unit
val find_value: string -> t * int
val has_cmi: string -> bool
......@@ -31,7 +31,6 @@ and toplevel_directive =
| `Reinit_ns
| `Help
| `Dump of pexpr
| `Print_schema of U.t
| `Print_type of ppat
| `Debug of debug_directive
| `Verbose
......@@ -62,8 +61,7 @@ and pexpr =
| Map of pexpr * branches
| Transform of pexpr * branches
| Xtrans of pexpr * branches
| Validate of pexpr * Schema_types.component_kind * U.t * U.t
(* exp, schema component kind, schema name, element name *)
| Validate of pexpr * U.t * U.t (* exp, schema name, element name *)
| Dot of pexpr * label
| RemoveField of pexpr * label
......@@ -94,8 +92,10 @@ and branches = (ppat * pexpr) list
and ppat = ppat' located
and ppat' =
| PatVar of (U.t option) * U.t (* optional compilation unit *)
(*
| SchemaVar of (* type/pattern schema variable *)
Schema_types.component_kind * U.t * U.t (* kind, schema, name *)
*)
| Cst of pexpr
| NsT of U.t
| Recurs of ppat * (Location.loc * U.t * ppat) list
......
......@@ -159,8 +159,6 @@ EXTEND
| "#"; IDENT "ascii" -> Ulexer.enc := Ulexing.Ascii; [ ]
| "#"; IDENT "quit" -> [ mk loc (Directive `Quit) ]
| "#"; IDENT "env" -> [ mk loc (Directive `Env) ]
| "#"; IDENT "print_schema"; name = IDENT ->
[ mk loc (Directive (`Print_schema (U.mk name))) ]
| "#"; IDENT "print_type"; t = pat ->
[ mk loc (Directive (`Print_type t)) ]
| "#"; IDENT "dump_value"; e = expr -> [ mk loc (Directive (`Dump e)) ]
......@@ -238,8 +236,8 @@ EXTEND
exp loc (if_then_else e e1 e2)
| "transform"; e = SELF; "with"; b = branches ->
exp loc (Transform (e,b))
| "validate"; e = SELF; "with"; (kind, schema, typ) = schema_ref ->
exp loc (Validate (e, kind, schema, typ))
| "validate"; e = SELF; "with"; (schema, typ) = schema_ref ->
exp loc (Validate (e, schema, typ))
| "fun"; (f,a,b) = fun_decl ->
exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
| "external"; s = STRING2 ->
......@@ -512,19 +510,8 @@ EXTEND
]
];
schema_kind : [
[ IDENT "element" -> `Element
| "type" -> `Type
| IDENT "attribute" -> `Attribute
| IDENT "attribute_group" -> `Attribute_group
| IDENT "model_group" -> `Model_group
]
];
schema_ref: [
[ schema = IDENT; "#"; typ = [ IDENT | keyword ];
kind = OPT [ "as"; k = schema_kind -> k] ->
(kind, U.mk schema, U.mk typ)
[ schema = IDENT; "."; typ = [ IDENT | keyword ] -> (U.mk schema, U.mk typ)
]
];
......@@ -551,13 +538,8 @@ EXTEND
| IDENT "_" -> mk loc (Internal Types.any)
| "("; a = IDENT; ":="; c = expr; ")" ->
mk loc (Constant (ident a,c))
| schema = IDENT; "#"; typ = [ IDENT | keyword ];
kind = OPT [ "as"; k = schema_kind -> k] ->
mk loc (SchemaVar (kind, U.mk schema, U.mk typ))
| "!"; a = IDENT ->
mk loc (Internal (Types.abstract (Types.Abstract.atom a)))
(* | a = IDENT ->
mk loc (PatVar (None, U.mk a)) *)
| cu = OPT [ cu = IDENT; "." -> U.mk cu ]; a = IDENT ->
mk loc (PatVar (cu, U.mk a))
| i = INT ; "--"; j = INT ->
......
......@@ -141,7 +141,7 @@ let rec eval env = function
| Transform (arg,brs) -> eval_transform env brs (eval env arg)
| Dot (e, l) -> eval_dot l (eval env e)
| RemoveField (e, l) -> eval_remove_field l (eval env e)
| Validate (e, kind, schema, name) -> eval_validate env e kind schema name
| Validate (e, schema, name) -> eval_validate env e schema name
| Ref (e,t) -> eval_ref env e t
| Op (op,args) as e ->
let eval_fun = eval_op op in
......@@ -229,22 +229,10 @@ and eval_branches_new env brs arg =
and eval_ref env e t=
Value.mk_ref (Types.descr t) (eval env e)
and eval_validate env e kind uri name =
let schema = Typer.get_schema uri in
try
let validate =
match Schema_common.get_component kind name schema with
| Schema_types.Type x -> Schema_validator.validate_type x schema
| Schema_types.Element x -> Schema_validator.validate_element x schema
| Schema_types.Attribute x ->
assert false (* TODO see schema/schema_validator.mli *)
(* Schema_validator.validate_attribute x schema *)
| Schema_types.Attribute_group x ->
Schema_validator.validate_attribute_group x schema
| Schema_types.Model_group x ->
Schema_validator.validate_model_group x schema
in
validate (eval env e)
and eval_validate env e uri name =
(* TODO: compute the validator when loading the lambda code *)
let validate = Typer.get_schema_validator uri name in
try validate (eval env e)
with Schema_common.XSI_validation_error msg ->
failwith' ("Schema validation failure: " ^ msg)
......
......@@ -712,7 +712,8 @@ let string_of_time_type fields =
(** {2 API} *)
let is = QTable.mem builtins
let xsd_any = (xsd,Utf8.mk "anyType")
let is s = QTable.mem builtins s || (Ns.QName.equal s xsd_any)
let iter f = QTable.iter f builtins
let get name = QTable.find builtins name
......
......@@ -33,8 +33,6 @@ let foo_qname = Ns.empty, Utf8.mk ""
type context = {
ctx_stream: event Stream.t;
ctx_schema: schema;
mutable ctx_mixed: bool;
mutable ctx_current: Value.t;
}
......@@ -523,14 +521,13 @@ and validate_model_group ctx model_group =
| Sequence particles -> List.iter (validate_particle ctx) particles
let ctx stream schema =
let ctx stream =
{ ctx_stream = stream;
ctx_schema = schema;
ctx_mixed = false;
ctx_current = Value.Absent }
let validate_element decl schema value =
let ctx = ctx (stream_of_value value) schema in
let validate_element decl value =
let ctx = ctx (stream_of_value value) in
validate_element ctx decl
let get_str v =
......@@ -539,12 +536,12 @@ let get_str v =
"Only string values could be validate against simple types";
fst (get_string_utf8 v)
let validate_type def schema value =
let validate_type def value =
match def with
| AnyType -> value (* shortcut *)
| Simple st_def -> validate_simple_type st_def (get_str value)
| Complex ct_def ->
let ctx = ctx (stream_of_value value) schema in
let ctx = ctx (stream_of_value value) in
let start_tag = expect_any_start_tag ctx in
let attrs = get_attributes ctx in
let (attrs, content) = validate_complex_type ctx attrs ct_def in
......@@ -552,7 +549,7 @@ let validate_type def schema value =
Value.Xml (Value.Atom (Atoms.V.of_qname start_tag), attrs, content)
(*
let validate_attribute decl schema value =
let validate_attribute decl value =
assert false; (* TODO see the .mli *)
(match value with
| Record _ -> ()
......@@ -586,7 +583,7 @@ let validate_attribute decl schema value =
Value.vrecord fields
*)
let validate_attribute_group { ag_def = attr_uses } schema value =
let validate_attribute_group { ag_def = attr_uses } value =
let stream =
match value with
| Record _ ->
......@@ -600,18 +597,18 @@ let validate_attribute_group { ag_def = attr_uses } schema value =
error
"Only record values could be validated against attribute groups"
in
let ctx = ctx stream schema in
let ctx = ctx stream in
let attrs = get_attributes ctx in
validate_attribute_uses attrs attr_uses
let validate_model_group { mg_def = mg } schema value =
let validate_model_group { mg_def = mg } value =
if not (Value.is_seq value) then
error
"Only sequence values could be validated against model groups";
let stream = stream_of_value (Value.Xml (foo_atom, empty_record, value)) in
Stream.junk stream;
let ctx = ctx stream schema in
let ctx = ctx stream in
validate_model_group ctx mg;
get ctx
......
......@@ -12,7 +12,7 @@ open Schema_types
* that a given XML value has the given type ignoring tag name (CDuce domain:
* XML values)
*)
val validate_type : type_definition -> schema -> Value.t -> Value.t
val validate_type : type_definition -> Value.t -> Value.t
(** CDuce domain: records
*
......@@ -29,15 +29,15 @@ val validate_type : type_definition -> schema -> Value.t -> Value.t
*)
(** CDuce domain: XML values *)
val validate_element : element_declaration -> schema -> Value.t -> Value.t
val validate_element : element_declaration -> Value.t -> Value.t
(** CDuce domain: records *)
val validate_attribute_group :
attribute_group_definition -> schema -> Value.t -> Value.t
attribute_group_definition -> Value.t -> Value.t
(** CDuce domain: sequences of XML values *)
val validate_model_group :
model_group_definition -> schema -> Value.t -> Value.t
model_group_definition -> Value.t -> Value.t
(** {2 derived validators} *)
......
......@@ -31,13 +31,13 @@ foreach my $s (@ARGV) {
EOF
if ($root) {
print CD <<EOF;
#print_type X # $root;;
#print_type X . $root;;
EOF
}
if (-f "$1.xml") {
print CD <<EOF;
let x = load_xml "$1.xml";;
let y = validate x with X # $root;;
let y = validate x with X . $root;;
print_xml y;;
EOF
}
......
val nb: unit -> int
val register: ref (int -> string -> Types.Node.t list -> Types.t)
val resolve: string -> Types.Node.t list -> (int * Types.t)
......@@ -42,8 +42,7 @@ and texpr' =
| Map of texpr * branches
| Transform of texpr * branches
| Xtrans of texpr * branches
| Validate of texpr * Schema_types.component_kind * string * Ns.qname
(* exp, schema component kind, schema uri, element name *)
| Validate of texpr * string * Ns.qname (* exp, schema uri, element name *)
| RemoveField of texpr * label
| Dot of texpr * label
......
......@@ -43,13 +43,17 @@ type item =
| Type of Types.t
| Val of Types.t
type ext =
| ECDuce of Types.CompUnit.t (* CDuce unit *)
| EOCaml of string (* OCaml module *)
| ESchema of string (* XML Schema *)
module UEnv = Map.Make(U)
type t = {
ids : item Env.t;
ns: Ns.table;
cu: Types.CompUnit.t UEnv.t;
schemas: string UEnv.t
cu: ext UEnv.t;
}
let hash _ = failwith "Typer.hash"
......@@ -62,18 +66,13 @@ let check _ = failwith "Typer.check"
let load_schema_fwd = ref (fun x uri -> assert false)
let enter_schema ?prefix x uri env =
let sch,reg = !load_schema_fwd x uri in
(* Set the namespace prefix before registration for better pretty
printing *)
let env =
let sch = !load_schema_fwd x uri in
{ env with
schemas = UEnv.add x uri env.schemas;
cu = UEnv.add x (ESchema uri) env.cu;
ns = (match prefix with
| Some p ->
Ns.add_prefix p sch.Schema_types.targetNamespace env.ns
| None -> env.ns) } in
reg ();
env
| None -> env.ns) }
(* TODO: filter out builtin defs ? *)
......@@ -86,7 +85,9 @@ let serialize s env =
Ns.serialize_table s env.ns;
let schs =
UEnv.fold (fun name uri accu -> (name,uri)::accu) env.schemas [] in
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
let deserialize_item s = match Serialize.Get.bits 1 s with
......@@ -101,7 +102,7 @@ let deserialize s =
Serialize.Get.list
(Serialize.Get.pair U.deserialize Serialize.Get.string) s in
let env =
{ ids = ids; ns = ns; cu = UEnv.empty; schemas = UEnv.empty } in
{ ids = ids; ns = ns; cu = UEnv.empty } in
List.fold_left (fun env (name,uri) -> enter_schema name uri env) env schs
......@@ -109,22 +110,30 @@ let empty_env = {
ids = Env.empty;
ns = Ns.empty_table;
cu = UEnv.empty;
schemas = UEnv.empty
}
let from_comp_unit = ref (fun cu -> assert false)
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 enter_cu x cu env =
{ env with cu = UEnv.add x cu env.cu }
{ env with cu = UEnv.add x (ECDuce cu) env.cu }
let find_cu x env =
let find_cu loc x env =
try UEnv.find x env.cu
with Not_found -> Types.CompUnit.mk x
with Not_found ->
if !has_comp_unit x then (ECDuce (Types.CompUnit.mk x))
else if !has_ocaml_unit x then (EOCaml (U.get_str x))
else error loc ("Cannot find external unit " ^ (U.to_string x))
let find_schema x env =
try UEnv.find x env.schemas
with Not_found -> raise (Error (Printf.sprintf "%s: no such schema" (U.get_str x)))
try
(match UEnv.find x env.cu with
| ESchema s -> s
| _ -> raise Not_found)
with Not_found ->
raise (Error (Printf.sprintf "%s: no such schema" (U.to_string x)))
let enter_type id t env =
{ env with ids = Env.add id (Type t) env.ids }
......@@ -136,10 +145,6 @@ let find_type id env =
| Type t -> t
| Val _ -> raise Not_found
let find_type_global loc cu id env =
let cu = find_cu cu env in
let env = !from_comp_unit cu in
find_type id env
let enter_value id t env =
{ env with ids = Env.add id (Val t) env.ids }
......@@ -153,12 +158,9 @@ let find_value id env =
match Env.find id env.ids with
| Val t -> t
| _ -> raise Not_found
let find_value_global cu id env =
let env = !from_comp_unit cu in
find_value id env
let is_cu id env =
try ignore (!from_comp_unit (find_cu id env)); true
with _ -> false
let find_value_global loc cu id env =
try find_value id (!from_comp_unit cu)
with Not_found -> raise_loc loc (UnboundExtId (cu,id))
let value_name_ok id env =
try match Env.find id env.ids with
......@@ -239,54 +241,23 @@ let rec const env loc = function
(* Schema *)
let is_registered_schema env s = UEnv.mem s env.schemas
(* uri -> schema binding *)
let schemas = State.ref "Typer.schemas" (Hashtbl.create 3)
let schemas = Hashtbl.create 3
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)
(*
let get_schema uri =
try Hashtbl.find !schemas uri
with Not_found -> assert false
*)
let find_schema_descr_uri kind uri (name : Ns.qname) =
let find_schema_descr uri (name : Ns.qname) =
try
let elt () = Hashtbl.find !schema_elements (uri, name) in
let typ () = Hashtbl.find !schema_types (uri, name) in
let att () = Hashtbl.find !schema_attributes (uri, name) in
let att_group () = Hashtbl.find !schema_attribute_groups (uri, name) in
let mod_group () = Hashtbl.find !schema_model_groups (uri, name) in
let rec do_try n = function
| [] -> raise Not_found
| f :: rem -> (try f () with Not_found -> do_try n rem)
in
match kind with
| 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 ->
(* policy for unqualified schema component resolution. This order should
* be consistent with Schema_component.get_component *)
do_try "component" [ elt; typ; att; att_group; mod_group ]
let sch = snd (Hashtbl.find schemas uri) in
fst (Env.find (Ident.ident name) sch)
with Not_found ->
raise (Error (Printf.sprintf "No %s named '%s' found in schema '%s'"
(Schema_common.string_of_component_kind kind) (Ns.QName.to_string name) uri))
raise (Error (Printf.sprintf "No component named '%s' found in schema '%s'"
(Ns.QName.to_string name) uri))
let find_schema_descr env kind schema name =
let uri = find_schema schema env in
find_schema_descr_uri kind uri name
let find_type_global loc cu id env =
match find_cu loc cu env with
| ECDuce cu -> find_type id (!from_comp_unit cu)
| EOCaml _ -> error loc "OCaml units don't export types" (* TODO *)
| ESchema s -> find_schema_descr s (Ident.value id)
module IType = struct
......@@ -796,10 +767,12 @@ module IType = struct
let rec derecurs env p = match p.descr with
| PatVar (cu,v) -> derecurs_var env p.loc cu v
(*
| SchemaVar (kind, schema_name, component_name) ->
let name = qname env.penv_tenv p.loc component_name in
itype (find_schema_descr env.penv_tenv kind schema_name name)
*)
| Recurs (p,b) -> derecurs (derecurs_def env b) p
| Internal t -> itype t
......@@ -1040,17 +1013,16 @@ let rec expr env loc = function
let (fv1,e1) = expr env loc e1 and (fv2,e2) = expr env loc e2 in
exp loc (Fv.cup fv1 fv2) (Typed.Xml (e1,e2))
| Dot (LocatedExpr (_,Var cu), id) when not (has_value cu env) ->