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 ...@@ -78,7 +78,7 @@ and compile_aux env tail = function
| Typed.Transform (e,brs) -> Transform | Typed.Transform (e,brs) -> Transform
(compile env false e, compile_branches env false brs) (compile env false e, compile_branches env false brs)
| Typed.Xtrans (e,brs) -> Xtrans (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.RemoveField (e,l) -> RemoveField (compile env tail e,l)
| Typed.Dot (e,l) -> Dot (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) | Typed.Try (e,brs) -> Try (compile env false e, compile_branches env tail brs)
......
...@@ -56,7 +56,7 @@ type expr = ...@@ -56,7 +56,7 @@ type expr =
| Transform of expr * branches | Transform of expr * branches
| Xtrans of expr * branches | Xtrans of expr * branches
| Try 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 | RemoveField of expr * label
| Dot of expr * label | Dot of expr * label
| Ref of expr * Types.Node.t | Ref of expr * Types.Node.t
...@@ -186,10 +186,9 @@ module Put = struct ...@@ -186,10 +186,9 @@ module Put = struct
bits nbits s 12; bits nbits s 12;
expr s e; expr s e;
branches s brs branches s brs
| Validate (e,k,sch,t) -> | Validate (e,sch,t) ->
bits nbits s 13; bits nbits s 13;
expr s e; expr s e;
serialize_schema_component_kind s k;
string s sch; string s sch;
Ns.QName.serialize s t Ns.QName.serialize s t
(* assert false (* TODO:Need to store a pointer to the schema ... *) *) (* assert false (* TODO:Need to store a pointer to the schema ... *) *)
...@@ -313,10 +312,9 @@ module Get = struct ...@@ -313,10 +312,9 @@ module Get = struct
Try (e,brs) Try (e,brs)
| 13 -> | 13 ->
let e = expr s in let e = expr s in
let k = deserialize_schema_component_kind s in
let sch = string s in let sch = string s in
let t = Ns.QName.deserialize s in let t = Ns.QName.deserialize s in
Validate (e,k,sch,t) Validate (e,sch,t)
| 14 -> | 14 ->
let e = expr s in let e = expr s in
let l = LabelPool.deserialize s in let l = LabelPool.deserialize s in
......
...@@ -29,7 +29,7 @@ type expr = ...@@ -29,7 +29,7 @@ type expr =
| Transform of expr * branches | Transform of expr * branches
| Xtrans of expr * branches | Xtrans of expr * branches
| Try 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 | RemoveField of expr * label
| Dot of expr * label | Dot of expr * label
| Ref of expr * Types.Node.t | Ref of expr * Types.Node.t
......
...@@ -251,11 +251,6 @@ let directive ppf tenv cenv = function ...@@ -251,11 +251,6 @@ let directive ppf tenv cenv = function
(if !toplevel then raise End_of_file) (if !toplevel then raise End_of_file)
| `Env -> | `Env ->
dump_env ppf tenv cenv 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 -> | `Print_type t ->
let t = Typer.typ tenv t in let t = Typer.typ tenv t in
Format.fprintf ppf "%a@." Types.Print.print_noname (Types.descr t) Format.fprintf ppf "%a@." Types.Print.print_noname (Types.descr t)
......
...@@ -81,6 +81,10 @@ let deserialize_dep = ...@@ -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 find_obj id =
let base = Encodings.Utf8.to_string (C.value id) ^ ".cdo" in let base = Encodings.Utf8.to_string (C.value id) ^ ".cdo" in
let p = let p =
...@@ -278,6 +282,7 @@ let import_from_string id str dig dep = ignore (load_from_string id str dig dep) ...@@ -278,6 +282,7 @@ let import_from_string id str dig dep = ignore (load_from_string id str dig dep)
let () = let () =
Typer.from_comp_unit := (fun cu -> (load cu).typing); Typer.from_comp_unit := (fun cu -> (load cu).typing);
Typer.has_comp_unit := has_obj;
Compile.from_comp_unit := (fun cu -> (load cu).compile); Compile.from_comp_unit := (fun cu -> (load cu).compile);
Eval.get_global := (fun cu i -> import_and_run cu; (load cu).vals.(i)); 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); 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 = ...@@ -516,6 +516,8 @@ let stub name ty_env c_env values =
let register () = let register () =
Typer.has_ocaml_unit :=
(fun cu -> Mltypes.has_cmi (U.get_str cu));
Librarian.stub_ml := Librarian.stub_ml :=
(fun cu ty_env c_env -> (fun cu ty_env c_env ->
try try
......
...@@ -183,6 +183,11 @@ let unfold ty = ...@@ -183,6 +183,11 @@ let unfold ty =
let unsupported s = let unsupported s =
raise (Error (Printf.sprintf "Unsupport feature (%s) found in .cmi" 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 = let read_cmi name =
Config.load_path := Config.standard_library :: !Librarian.obj_path; Config.load_path := Config.standard_library :: !Librarian.obj_path;
let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in 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 ...@@ -24,3 +24,5 @@ val print_ocaml : Format.formatter -> Types.type_expr -> unit
val find_value: string -> t * int val find_value: string -> t * int
val has_cmi: string -> bool
...@@ -31,7 +31,6 @@ and toplevel_directive = ...@@ -31,7 +31,6 @@ and toplevel_directive =
| `Reinit_ns | `Reinit_ns
| `Help | `Help
| `Dump of pexpr | `Dump of pexpr
| `Print_schema of U.t
| `Print_type of ppat | `Print_type of ppat
| `Debug of debug_directive | `Debug of debug_directive
| `Verbose | `Verbose
...@@ -62,8 +61,7 @@ and pexpr = ...@@ -62,8 +61,7 @@ and pexpr =
| Map of pexpr * branches | Map of pexpr * branches
| Transform of pexpr * branches | Transform of pexpr * branches
| Xtrans of pexpr * branches | Xtrans of pexpr * branches
| Validate of pexpr * Schema_types.component_kind * U.t * U.t | Validate of pexpr * U.t * U.t (* exp, schema name, element name *)
(* exp, schema component kind, schema name, element name *)
| Dot of pexpr * label | Dot of pexpr * label
| RemoveField of pexpr * label | RemoveField of pexpr * label
...@@ -94,8 +92,10 @@ and branches = (ppat * pexpr) list ...@@ -94,8 +92,10 @@ and branches = (ppat * pexpr) list
and ppat = ppat' located and ppat = ppat' located
and ppat' = and ppat' =
| PatVar of (U.t option) * U.t (* optional compilation unit *) | PatVar of (U.t option) * U.t (* optional compilation unit *)
(*
| SchemaVar of (* type/pattern schema variable *) | SchemaVar of (* type/pattern schema variable *)
Schema_types.component_kind * U.t * U.t (* kind, schema, name *) Schema_types.component_kind * U.t * U.t (* kind, schema, name *)
*)
| Cst of pexpr | Cst of pexpr
| NsT of U.t | NsT of U.t
| Recurs of ppat * (Location.loc * U.t * ppat) list | Recurs of ppat * (Location.loc * U.t * ppat) list
......
...@@ -159,8 +159,6 @@ EXTEND ...@@ -159,8 +159,6 @@ EXTEND
| "#"; IDENT "ascii" -> Ulexer.enc := Ulexing.Ascii; [ ] | "#"; IDENT "ascii" -> Ulexer.enc := Ulexing.Ascii; [ ]
| "#"; IDENT "quit" -> [ mk loc (Directive `Quit) ] | "#"; IDENT "quit" -> [ mk loc (Directive `Quit) ]
| "#"; IDENT "env" -> [ mk loc (Directive `Env) ] | "#"; IDENT "env" -> [ mk loc (Directive `Env) ]
| "#"; IDENT "print_schema"; name = IDENT ->
[ mk loc (Directive (`Print_schema (U.mk name))) ]
| "#"; IDENT "print_type"; t = pat -> | "#"; IDENT "print_type"; t = pat ->
[ mk loc (Directive (`Print_type t)) ] [ mk loc (Directive (`Print_type t)) ]
| "#"; IDENT "dump_value"; e = expr -> [ mk loc (Directive (`Dump e)) ] | "#"; IDENT "dump_value"; e = expr -> [ mk loc (Directive (`Dump e)) ]
...@@ -238,8 +236,8 @@ EXTEND ...@@ -238,8 +236,8 @@ EXTEND
exp loc (if_then_else e e1 e2) exp loc (if_then_else e e1 e2)
| "transform"; e = SELF; "with"; b = branches -> | "transform"; e = SELF; "with"; b = branches ->
exp loc (Transform (e,b)) exp loc (Transform (e,b))
| "validate"; e = SELF; "with"; (kind, schema, typ) = schema_ref -> | "validate"; e = SELF; "with"; (schema, typ) = schema_ref ->
exp loc (Validate (e, kind, schema, typ)) exp loc (Validate (e, schema, typ))
| "fun"; (f,a,b) = fun_decl -> | "fun"; (f,a,b) = fun_decl ->
exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b }) exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
| "external"; s = STRING2 -> | "external"; s = STRING2 ->
...@@ -512,19 +510,8 @@ EXTEND ...@@ -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_ref: [
[ schema = IDENT; "#"; typ = [ IDENT | keyword ]; [ schema = IDENT; "."; typ = [ IDENT | keyword ] -> (U.mk schema, U.mk typ)
kind = OPT [ "as"; k = schema_kind -> k] ->
(kind, U.mk schema, U.mk typ)
] ]
]; ];
...@@ -551,13 +538,8 @@ EXTEND ...@@ -551,13 +538,8 @@ EXTEND
| IDENT "_" -> mk loc (Internal Types.any) | IDENT "_" -> mk loc (Internal Types.any)
| "("; a = IDENT; ":="; c = expr; ")" -> | "("; a = IDENT; ":="; c = expr; ")" ->
mk loc (Constant (ident a,c)) 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 -> | "!"; a = IDENT ->
mk loc (Internal (Types.abstract (Types.Abstract.atom a))) 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 -> | cu = OPT [ cu = IDENT; "." -> U.mk cu ]; a = IDENT ->
mk loc (PatVar (cu, U.mk a)) mk loc (PatVar (cu, U.mk a))
| i = INT ; "--"; j = INT -> | i = INT ; "--"; j = INT ->
......
...@@ -141,7 +141,7 @@ let rec eval env = function ...@@ -141,7 +141,7 @@ let rec eval env = function
| Transform (arg,brs) -> eval_transform env brs (eval env arg) | Transform (arg,brs) -> eval_transform env brs (eval env arg)
| Dot (e, l) -> eval_dot l (eval env e) | Dot (e, l) -> eval_dot l (eval env e)
| RemoveField (e, l) -> eval_remove_field 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 | Ref (e,t) -> eval_ref env e t
| Op (op,args) as e -> | Op (op,args) as e ->
let eval_fun = eval_op op in let eval_fun = eval_op op in
...@@ -229,22 +229,10 @@ and eval_branches_new env brs arg = ...@@ -229,22 +229,10 @@ and eval_branches_new env brs arg =
and eval_ref env e t= and eval_ref env e t=
Value.mk_ref (Types.descr t) (eval env e) Value.mk_ref (Types.descr t) (eval env e)
and eval_validate env e kind uri name = and eval_validate env e uri name =
let schema = Typer.get_schema uri in (* TODO: compute the validator when loading the lambda code *)
try let validate = Typer.get_schema_validator uri name in
let validate = try validate (eval env e)
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)
with Schema_common.XSI_validation_error msg -> with Schema_common.XSI_validation_error msg ->
failwith' ("Schema validation failure: " ^ msg) failwith' ("Schema validation failure: " ^ msg)
......
...@@ -712,7 +712,8 @@ let string_of_time_type fields = ...@@ -712,7 +712,8 @@ let string_of_time_type fields =
(** {2 API} *) (** {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 iter f = QTable.iter f builtins
let get name = QTable.find builtins name let get name = QTable.find builtins name
......
...@@ -33,8 +33,6 @@ let foo_qname = Ns.empty, Utf8.mk "" ...@@ -33,8 +33,6 @@ let foo_qname = Ns.empty, Utf8.mk ""
type context = { type context = {
ctx_stream: event Stream.t; ctx_stream: event Stream.t;
ctx_schema: schema;
mutable ctx_mixed: bool; mutable ctx_mixed: bool;
mutable ctx_current: Value.t; mutable ctx_current: Value.t;
} }
...@@ -523,14 +521,13 @@ and validate_model_group ctx model_group = ...@@ -523,14 +521,13 @@ and validate_model_group ctx model_group =
| Sequence particles -> List.iter (validate_particle ctx) particles | Sequence particles -> List.iter (validate_particle ctx) particles
let ctx stream schema = let ctx stream =
{ ctx_stream = stream; { ctx_stream = stream;
ctx_schema = schema;
ctx_mixed = false; ctx_mixed = false;
ctx_current = Value.Absent } ctx_current = Value.Absent }
let validate_element decl schema value = let validate_element decl value =
let ctx = ctx (stream_of_value value) schema in let ctx = ctx (stream_of_value value) in
validate_element ctx decl validate_element ctx decl
let get_str v = let get_str v =
...@@ -539,12 +536,12 @@ let get_str v = ...@@ -539,12 +536,12 @@ let get_str v =
"Only string values could be validate against simple types"; "Only string values could be validate against simple types";
fst (get_string_utf8 v) fst (get_string_utf8 v)
let validate_type def schema value = let validate_type def value =
match def with match def with
| AnyType -> value (* shortcut *) | AnyType -> value (* shortcut *)
| Simple st_def -> validate_simple_type st_def (get_str value) | Simple st_def -> validate_simple_type st_def (get_str value)
| Complex ct_def -> | 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 start_tag = expect_any_start_tag ctx in
let attrs = get_attributes ctx in let attrs = get_attributes ctx in
let (attrs, content) = validate_complex_type ctx attrs ct_def in let (attrs, content) = validate_complex_type ctx attrs ct_def in
...@@ -552,7 +549,7 @@ let validate_type def schema value = ...@@ -552,7 +549,7 @@ let validate_type def schema value =
Value.Xml (Value.Atom (Atoms.V.of_qname start_tag), attrs, content) 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 *) assert false; (* TODO see the .mli *)
(match value with (match value with
| Record _ -> () | Record _ -> ()
...@@ -586,7 +583,7 @@ let validate_attribute decl schema value = ...@@ -586,7 +583,7 @@ let validate_attribute decl schema value =
Value.vrecord fields Value.vrecord fields
*) *)
let validate_attribute_group { ag_def = attr_uses } schema value = let validate_attribute_group { ag_def = attr_uses } value =
let stream = let stream =
match value with match value with
| Record _ -> | Record _ ->
...@@ -600,18 +597,18 @@ let validate_attribute_group { ag_def = attr_uses } schema value = ...@@ -600,18 +597,18 @@ let validate_attribute_group { ag_def = attr_uses } schema value =
error error
"Only record values could be validated against attribute groups" "Only record values could be validated against attribute groups"
in in
let ctx = ctx stream schema in let ctx = ctx stream in
let attrs = get_attributes ctx in let attrs = get_attributes ctx in
validate_attribute_uses attrs attr_uses 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 if not (Value.is_seq value) then
error error
"Only sequence values could be validated against model groups"; "Only sequence values could be validated against model groups";
let stream = stream_of_value (Value.Xml (foo_atom, empty_record, value)) in let stream = stream_of_value (Value.Xml (foo_atom, empty_record, value)) in
Stream.junk stream; Stream.junk stream;
let ctx = ctx stream schema in let ctx = ctx stream in
validate_model_group ctx mg; validate_model_group ctx mg;
get ctx get ctx
......
...@@ -12,7 +12,7 @@ open Schema_types ...@@ -12,7 +12,7 @@ open Schema_types
* that a given XML value has the given type ignoring tag name (CDuce domain: * that a given XML value has the given type ignoring tag name (CDuce domain:
* XML values) * XML values)
*) *)
val validate_type : type_definition -> schema -> Value.t -> Value.t val validate_type : type_definition -> Value.t -> Value.t
(** CDuce domain: records (** CDuce domain: records
* *
...@@ -29,15 +29,15 @@ val validate_type : type_definition -> schema -> Value.t -> Value.t ...@@ -29,15 +29,15 @@ val validate_type : type_definition -> schema -> Value.t -> Value.t
*) *)
(** CDuce domain: XML values *) (** 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 *) (** CDuce domain: records *)
val validate_attribute_group : 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 *) (** CDuce domain: sequences of XML values *)
val validate_model_group : val validate_model_group :
model_group_definition -> schema -> Value.t -> Value.t model_group_definition -> Value.t -> Value.t
(** {2 derived validators} *) (** {2 derived validators} *)
......
...@@ -31,13 +31,13 @@ foreach my $s (@ARGV) { ...@@ -31,13 +31,13 @@ foreach my $s (@ARGV) {
EOF EOF
if ($root) { if ($root) {
print CD <<EOF; print CD <<EOF;
#print_type X # $root;; #print_type X . $root;;
EOF EOF
} }
if (-f "$1.xml") { if (-f "$1.xml") {
print CD <<EOF; print CD <<EOF;
let x = load_xml "$1.xml";; let x = load_xml "$1.xml";;
let y = validate x with X # $root;; let y = validate x with X . $root;;
print_xml y;; print_xml y;;
EOF EOF
} }
......
val nb: unit -> int val nb: unit -> int
val register: ref (int -> string -> Types.Node.t list -> Types.t) val register: ref (int -> string -> Types.Node.t list -> Types.t)
val resolve: string -> Types.Node.t list -> (int * Types.t) val resolve: string -> Types.Node.t list -> (int * Types.t)
...@@ -42,8 +42,7 @@ and texpr' = ...@@ -42,8 +42,7 @@ and texpr' =
| Map of texpr * branches | Map of texpr * branches
| Transform of texpr * branches | Transform of texpr * branches
| Xtrans of texpr * branches | Xtrans of texpr * branches
| Validate of texpr * Schema_types.component_kind * string * Ns.qname | Validate of texpr * string * Ns.qname (* exp, schema uri, element name *)
(* exp, schema component kind, schema uri, element name *)
| RemoveField of texpr * label | RemoveField of texpr * label
| Dot of texpr * label | Dot of texpr * label
......
...@@ -43,13 +43,17 @@ type item = ...@@ -43,13 +43,17 @@ type item =
| Type of Types.t | Type of Types.t
| Val 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) module UEnv = Map.Make(U)
type t = { type t = {
ids : item Env.t; ids : item Env.t;
ns: Ns.table; ns: Ns.table;
cu: Types.CompUnit.t UEnv.t; cu: ext UEnv.t;
schemas: string UEnv.t
}