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

[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
......
This diff is collapsed.
......@@ -18,6 +18,8 @@ val error: loc -> string -> 'a
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 empty_env: t
val get_ns_table : t -> Ns.table
......@@ -64,7 +66,7 @@ val flatten: (Types.t -> bool -> Types.t) -> (Types.t -> bool -> Types.t)
(** {2 Schema stuff} *)
val get_schema: string -> Schema_types.schema (** lookup schema by uri *)
val get_schema_validator: string -> Ns.qname -> Value.t -> Value.t
val get_schema_names: t -> U.t list (** registered schema names *)
(* Operators *)
......
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