Commit 73e03a54 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-07-07 13:57:17 by afrisch] Export namespaces, schemas, ...

Original author: afrisch
Date: 2005-07-07 13:57:18+00:00
parent 80304e58
......@@ -216,23 +216,20 @@ let type_defs (tenv,cenv,codes) typs =
let tenv = Typer.type_defs tenv typs in
(tenv,cenv,codes)
let namespace (tenv,cenv,codes) pr ns =
let tenv = Typer.type_ns tenv pr ns in
let namespace (tenv,cenv,codes) loc pr ns =
let tenv = Typer.type_ns tenv loc pr ns in
(tenv,cenv,codes)
let keep_ns (tenv,cenv,codes) k =
let tenv = Typer.type_keep_ns tenv k in
(tenv,cenv,codes)
let schema (tenv,cenv,codes) x sch =
let tenv = Typer.type_schema tenv x sch in
let schema (tenv,cenv,codes) loc x sch =
let tenv = Typer.type_schema tenv loc x sch in
(tenv,cenv,codes)
let find_cu (tenv,_,_) cu =
Typer.find_cu cu tenv
let using (tenv,cenv,codes) x cu =
let tenv = Typer.enter_cu x cu tenv in
let using (tenv,cenv,codes) loc x cu =
let tenv = Typer.type_using tenv loc x cu in
(tenv,cenv,codes)
let rec collect_funs accu = function
......@@ -244,7 +241,7 @@ let rec collect_types accu = function
collect_types ((loc,x,t) :: accu) rest
| rest -> (accu,rest)
let rec phrases ~run ~show ~loading ~directive =
let rec phrases ~run ~show ~directive =
let rec loop accu phs =
match phs with
| { descr = Ast.FunDecl _ } :: _ ->
......@@ -253,16 +250,14 @@ let rec phrases ~run ~show ~loading ~directive =
| { descr = Ast.TypeDecl (_,_) } :: _ ->
let (typs,rest) = collect_types [] phs in
loop (type_defs accu typs) rest
| { descr = Ast.SchemaDecl (name, uri) } :: rest ->
loop (schema accu name uri) rest
| { descr = Ast.Namespace (pr,ns) } :: rest ->
loop (namespace accu pr ns) rest
| { descr = Ast.SchemaDecl (name, uri); loc = loc } :: rest ->
loop (schema accu loc name uri) rest
| { descr = Ast.Namespace (pr,ns); loc = loc } :: rest ->
loop (namespace accu loc pr ns) rest
| { descr = Ast.KeepNs b } :: rest ->
loop (keep_ns accu b) rest
| { descr = Ast.Using (x,cu) } :: rest ->
let cu = find_cu accu cu in
loading cu;
loop (using accu x cu) rest
| { descr = Ast.Using (x,cu); loc = loc } :: rest ->
loop (using accu loc x cu) rest
| { descr = Ast.EvalStatement e } :: rest ->
loop (eval ~run ~show accu e) rest
| { descr = Ast.LetDecl (p,e) } :: rest ->
......@@ -278,9 +273,8 @@ let rec phrases ~run ~show ~loading ~directive =
let comp_unit ?(run=false)
?(show=fun _ _ _ -> ())
?(loading=fun _ -> ())
?(directive=fun _ _ _ -> ()) tenv cenv phs =
let (tenv,cenv,codes) = phrases ~run ~show ~loading ~directive (tenv,cenv,[]) phs in
let (tenv,cenv,codes) = phrases ~run ~show ~directive (tenv,cenv,[]) phs in
(tenv,cenv,List.rev codes)
......
......@@ -17,7 +17,6 @@ val compile_eval_expr : env -> Typed.texpr -> Value.t
val comp_unit:
?run:bool ->
?show:(id option -> Types.t -> Value.t option -> unit) ->
?loading:(Compunit.t -> unit) ->
?directive:(Typer.t -> env -> Ast.toplevel_directive -> unit) ->
Typer.t -> env -> Ast.pmodule_item list ->
......
......@@ -60,8 +60,6 @@ let dump_env ppf tenv cenv =
Format.fprintf ppf "Namespace prefixes:@\n%a" Typer.dump_ns tenv;
Format.fprintf ppf "Namespace prefixes used for pretty-printing:@.%t"
Ns.InternalPrinter.dump;
Format.fprintf ppf "Schemas: %s@."
(String.concat " " (List.map U.get_str (Typer.get_schema_names tenv)));
Format.fprintf ppf "Values:@.";
Typer.iter_values tenv
(fun x t -> dump_value ppf x t (get_global_value cenv x))
......@@ -271,7 +269,6 @@ let phrases ppf phs =
let (tenv,cenv,_) =
Compile.comp_unit
~run:true ~show:(show ppf)
~loading:Librarian.run
~directive:(directive ppf)
!typing_env !compile_env phs in
typing_env := tenv;
......
......@@ -7,6 +7,8 @@ exception InvalidObject of string
exception CannotOpen of string
exception NoImplementation of U.t
let run_loaded = ref false
type t = {
name: U.t;
descr: Compunit.t;
......@@ -217,7 +219,10 @@ let get_builtins () =
let () =
Typer.from_comp_unit := (fun d -> (from_descr d).typing);
Typer.load_comp_unit := (fun name ->
if has_obj name then (load name).descr
if has_obj name then
let cu = load name in
if !run_loaded then run cu;
cu.descr
else raise Not_found);
Typer.has_static_external := Hashtbl.mem static_externals;
Compile.from_comp_unit := (fun d -> (from_descr d).compile);
......
......@@ -6,6 +6,7 @@ exception CannotOpen of string
exception NoImplementation of U.t
val name: Compunit.t -> U.t
val run_loaded: bool ref
val obj_path: string list ref
......
......@@ -124,6 +124,7 @@ let toploop () =
Sys.set_signal Sys.sigquit (Sys.Signal_handle (fun _ -> quit ()));
Sys.catch_break true;
Cduce.toplevel := true;
Librarian.run_loaded := true;
Location.push_source `Stream;
let read i =
if !bol then
......
......@@ -3,6 +3,8 @@
open Location
open Ident
type ns_expr = [ `Uri of Ns.Uri.t | `Path of U.t list ]
type pprog = pmodule_item list
and pmodule_item = pmodule_item' located
......@@ -11,7 +13,7 @@ and pmodule_item' =
| SchemaDecl of U.t * string
| LetDecl of ppat * pexpr
| FunDecl of pexpr
| Namespace of U.t * Ns.Uri.t
| Namespace of U.t * ns_expr
| KeepNs of bool
| Using of U.t * U.t
| EvalStatement of pexpr
......@@ -61,15 +63,16 @@ and pexpr =
| Map of pexpr * branches
| Transform of pexpr * branches
| Xtrans of pexpr * branches
| Validate of pexpr * U.t * U.t (* exp, schema name, element name *)
| Dot of pexpr * label * ppat list
| Validate of pexpr * U.t list
| Dot of pexpr * label
| TyArgs of pexpr * ppat list
| RemoveField of pexpr * label
(* Exceptions *)
| Try of pexpr * branches
(* Other *)
| NamespaceIn of U.t * Ns.Uri.t * pexpr
| NamespaceIn of U.t * ns_expr * pexpr
| KeepNsIn of bool * pexpr
| Forget of pexpr * ppat
| Check of pexpr * ppat
......@@ -93,7 +96,7 @@ and branches = (ppat * pexpr) list
and ppat = ppat' located
and ppat' =
| PatVar of (U.t option) * U.t (* optional compilation unit *)
| PatVar of U.t list
| Cst of pexpr
| NsT of U.t
| Recurs of ppat * (Location.loc * U.t * ppat) list
......
......@@ -117,8 +117,8 @@ let logical_not e = if_then_else e cst_false cst_true
let apply_op2_noloc op e1 e2 = Apply (Apply (Var (ident op), e1), e2)
let apply_op2 loc op e1 e2 = exp loc (apply_op2_noloc op e1 e2)
let set_ref e1 e2 = Apply (Dot (e1, U.mk "set", []), e2)
let get_ref e = Apply (Dot (e, U.mk "get", []), cst_nil)
let set_ref e1 e2 = Apply (Dot (e1, U.mk "set"), e2)
let get_ref e = Apply (Dot (e, U.mk "get"), cst_nil)
let let_in e1 p e2 = Match (e1, [p,e2])
let seq e1 e2 = let_in e1 pat_nil e2
let concat e1 e2 = apply_op2_noloc "@" e1 e2
......@@ -243,7 +243,7 @@ EXTEND
| "transform"; e = SELF; "with"; b = branches ->
exp loc (Transform (e,b))
| "validate"; e = SELF; "with"; (schema, typ) = schema_ref ->
exp loc (Validate (e, schema, typ))
exp loc (Validate (e, [schema;typ]))
| "select"; e = SELF; "from";
l = LIST1 [ x = pat ; "in"; e = expr -> (x,e)] SEP "," ;
cond = [ "where"; c = LIST1 [ expr ] SEP "and" -> c
......@@ -302,7 +302,7 @@ EXTEND
let any = mk loc (Internal Types.any) in
let att = mk loc (Record
(true, [(label a,
(mk loc (PatVar (None,id_dummy)),
(mk loc (PatVar [id_dummy]),
None))])) in
let p = mk loc (XmlT (tag, multi_prod loc [att;any])) in
let t = (p, Pair (Var id_dummy,cst_nil)) in
......@@ -318,11 +318,11 @@ EXTEND
set_ref
(Var stk)
(concat (get_ref (Var stk)) (Pair (Var id_dummy,cst_nil))) in
let capt = mk loc (And (mk loc (PatVar (None,U.mk "$$$")),p)) in
let capt = mk loc (And (mk loc (PatVar [U.mk "$$$"]),p)) in
let xt = Xtrans (e,[capt,assign]) in
let rf = Ref (cst_nil, mk loc (Regexp (Star(Elem p)))) in
let body =
let_in rf (mk loc (PatVar (None,stk)))
let_in rf (mk loc (PatVar [stk]))
(let_in xt (mk loc (Internal Types.any)) (get_ref (Var stk)))
in
exp loc body
......@@ -335,10 +335,10 @@ EXTEND
| "no_appl"
[ e = expr; "."; l = [IDENT | keyword ];
tyargs = [ "with"; "{"; pl = LIST0 pat; "}" -> pl | -> [] ]
->
exp loc (Dot (e, label l,tyargs))
[ e = expr; "with"; "{"; tyargs = LIST0 pat; "}" ->
exp loc (TyArgs (e, tyargs))
| e = expr; "."; l = [IDENT | keyword ] ->
exp loc (Dot (e,label l))
]
| [
"("; l = LIST1 expr SEP ","; ")" -> exp loc (tuple l)
......@@ -397,19 +397,24 @@ EXTEND
[ name =
[ name = [ IDENT | keyword ]; "=" -> ident name
| -> U.mk "" ];
uri = STRING2 ->
let ns = Ns.Uri.mk (ident uri) in
`Prefix (name,ns)
ns = ns_expr -> `Prefix (name,ns)
| IDENT "on" -> `Keep true
| IDENT "off" -> `Keep false ]
] -> r ]
];
ns_expr: [
[ uri = STRING2 -> `Uri (Ns.Uri.mk (ident uri))
| ids = LIST1 [ IDENT | keyword ] SEP "." ->
let ids = List.map (fun x -> ident x) ids in
`Path ids ]
];
let_binding: [
[ "let"; is_fun_decl; OPT "fun"; (f,a,b) = fun_decl ->
let f = match f with Some x -> x | None -> assert false in
let p = mk loc (PatVar (None, snd f)) in
let p = mk loc (PatVar [snd f]) in
let abst = { fun_name = Some f; fun_iface = a; fun_body = b } in
let e = exp loc (Abstraction abst) in
(true,p,e)
......@@ -581,8 +586,9 @@ EXTEND
mk loc (Constant (ident a,c))
| "!"; a = IDENT ->
mk loc (Internal (Types.abstract (Types.Abstract.atom a)))
| cu = OPT [ cu = IDENT; "." -> U.mk cu ]; a = [ IDENT | keyword ] ->
mk loc (PatVar (cu, ident a))
| ids = LIST1 [ IDENT | keyword ] SEP "." ->
let ids = List.map (fun x -> ident x) ids in
mk loc (PatVar ids)
| i = INT ; "--"; j = INT ->
let i = Intervals.V.mk i
and j = Intervals.V.mk j in
......@@ -643,7 +649,7 @@ EXTEND
[ [ r = LIST0 [ l = [IDENT | keyword ]; f = opt_field_pat; OPT ";" ->
let (o,x,y) =
match f with
| None -> (false, mknoloc (PatVar (None,ident l)), None)
| None -> (false, mknoloc (PatVar [ident l]), None)
| Some z -> z
in
let x = if o then mk loc (Optional x) else x in
......
......@@ -168,13 +168,13 @@ let attr_group ag = attr_uses ag.ag_def
let load_schema schema_name uri =
let schema_name = Utf8.get_str schema_name in
let log_schema_component kind name cd_type =
if not (Schema_builtin.is name) then begin
Types.Print.register_global schema_name name cd_type;
Format.fprintf Format.std_formatter "Registering schema %s: %a@." kind
Ns.QName.print name;
(* Format.fprintf Format.std_formatter "Registering schema %s: %a@." kind
Ns.QName.print name; *)
end
in
let env = ref Env.empty in
......@@ -196,7 +196,7 @@ let load_schema schema_name uri =
(fun x -> VType x) schema.types;
defs "element" (fun e -> Atoms.V.value e.elt_name) elt_decl
(fun x -> VElem x) schema.elements;
Obj.magic !env
schema.targetNamespace, !env
let () =
......
......@@ -29,74 +29,116 @@ 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 schema = {
sch_uri: string;
sch_ns: Ns.Uri.t;
sch_comps: (Types.t * Schema_validator.t) Ident.Env.t;
}
type item =
(* These are really exported by CDuce units: *)
| Type of Types.t
| Val of Types.t
type ext =
| ECDuce of Compunit.t (* CDuce unit *)
| EOCaml of string (* OCaml module *)
| ESchema of string (* XML Schema *)
module UEnv = Map.Make(U)
| ECDuce of Compunit.t
| ESchema of schema
| ENamespace of Ns.Uri.t
(* These are only used internally: *)
| EVal of Compunit.t * id * Types.t
| EOCaml of string
| EOCamlComponent of string
| ESchemaComponent of (Types.t * Schema_validator.t)
type t = {
ids : item Env.t;
ns: Ns.table;
cu: ext UEnv.t;
keep_ns: bool
}
(* Namespaces *)
let set_ns_table_for_printer env =
Ns.InternalPrinter.set_table env.ns
let get_ns_table tenv = tenv.ns
let type_keep_ns env k =
{ env with keep_ns = k }
let protect_error_ns loc f x =
try f x
with Ns.UnknownPrefix ns ->
raise_loc_generic loc
("Undefined namespace prefix " ^ (U.to_string ns))
let qname env loc t =
protect_error_ns loc (Ns.map_tag env.ns) t
let ident env loc t =
protect_error_ns loc (Ns.map_attr env.ns) t
let has_value id env =
try match Env.find (Ident.ident (Ns.map_attr env.ns id)) env.ids with
| Val t -> true
| _ -> false
with Not_found | Ns.UnknownPrefix _ -> false
let parse_atom env loc t = Atoms.V.mk (qname env loc t)
let parse_ns env loc ns =
protect_error_ns loc (Ns.map_prefix env.ns) ns
let parse_label env loc t =
Label.mk (protect_error_ns loc (Ns.map_attr env.ns) t)
let parse_record env loc f r =
let r = List.map (fun (l,x) -> (parse_label env loc l, f x)) r in
LabelMap.from_list (fun _ _ -> raise_loc_generic loc "Duplicated record field") r
let load_schema = ref (fun _ _ -> assert false)
let from_comp_unit = ref (fun _ -> assert false)
let load_comp_unit = ref (fun _ -> assert false)
let has_ocaml_unit = ref (fun _ -> false)
let has_static_external = ref (fun _ -> assert false)
let schemas = Hashtbl.create 13
let type_schema env 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 }
let type_schema env loc name uri =
let x = ident env loc name in
let (ns,sch) = !load_schema (U.to_string name) uri in
let sch = { sch_uri = uri; sch_comps = sch; sch_ns = ns } in
{ env with ids = Env.add x (ESchema sch) env.ids }
let empty_env = {
ids = Env.empty;
ns = Ns.def_table;
cu = UEnv.empty;
keep_ns = false
}
let enter_cu x cu env =
{ env with cu = UEnv.add x (ECDuce cu) env.cu }
let find_cu loc x env =
try UEnv.find x env.cu
with Not_found ->
try ECDuce (!load_comp_unit x)
with Not_found ->
if !has_ocaml_unit x then (EOCaml (U.get_str x))
else error loc ("Cannot find external unit " ^ (U.to_string x))
let enter_id x i env =
{ env with ids = Env.add x i env.ids }
let find_schema x env =
let type_using env loc x cu =
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 }
let cu = !load_comp_unit cu in
enter_id (ident env loc x) (ECDuce cu) env
with Not_found ->
error loc ("Cannot find external unit " ^ (U.to_string cu))
let enter_type id t env = enter_id id (Type t) env
let enter_types l env =
{ env with ids =
List.fold_left (fun accu (id,t) -> Env.add id (Type t) accu) env.ids l }
let find_type id env =
match Env.find id env.ids with
| Type t -> t
| Val _ -> raise Not_found
let find_id env0 env loc head x =
let id = ident env0 loc x in
try Env.find id env.ids
with Not_found when head ->
try ECDuce (!load_comp_unit x)
with Not_found ->
if !has_ocaml_unit x then (EOCaml (U.get_str x))
else error loc "Cannot resolve this identifier"
let enter_value id t env =
{ env with ids = Env.add id (Val t) env.ids }
......@@ -106,14 +148,12 @@ let enter_values l env =
let enter_values_dummy l env =
{ env with ids =
List.fold_left (fun accu id -> Env.add id (Val Types.empty) accu) env.ids l }
let find_value id env =
match Env.find id env.ids with
| Val t -> t
| _ -> raise Not_found
let find_value_global loc cu id env =
(*
let find_value_global loc cu id =
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
| Val t -> true
......@@ -132,48 +172,6 @@ let register_types cu env =
| _ -> ()) env.ids
(* Namespaces *)
let set_ns_table_for_printer env =
Ns.InternalPrinter.set_table env.ns
let get_ns_table tenv = tenv.ns
let type_ns env p ns =
{ env with ns = Ns.add_prefix p ns env.ns }
let type_keep_ns env k =
{ env with keep_ns = k }
let protect_error_ns loc f x =
try f x
with Ns.UnknownPrefix ns ->
raise_loc_generic loc
("Undefined namespace prefix " ^ (U.to_string ns))
let qname env loc t =
protect_error_ns loc (Ns.map_tag env.ns) t
let ident env loc t =
protect_error_ns loc (Ns.map_attr env.ns) t
let has_value id env =
try match Env.find (Ident.ident (Ns.map_attr env.ns id)) env.ids with
| Val t -> true
| _ -> false
with Not_found | Ns.UnknownPrefix _ -> false
let parse_atom env loc t = Atoms.V.mk (qname env loc t)
let parse_ns env loc ns =
protect_error_ns loc (Ns.map_prefix env.ns) ns
let parse_label env loc t =
Label.mk (protect_error_ns loc (Ns.map_attr env.ns) t)
let parse_record env loc f r =
let r = List.map (fun (l,x) -> (parse_label env loc l, f x)) r in
LabelMap.from_list (fun _ _ -> raise_loc_generic loc "Duplicated record field") r
let rec const env loc = function
| LocatedExpr (loc,e) -> const env loc e
......@@ -191,26 +189,85 @@ let rec const env loc = function
the internal form *)
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 find_schema_descr uri (name : Ns.QName.t) =
try find_schema_component uri name
let find_schema_component sch name =
try ESchemaComponent (Env.find name sch.sch_comps)
with Not_found ->
raise (Error (Printf.sprintf "No component named '%s' found in schema '%s'"
(Ns.QName.to_string name) uri))
(Ns.QName.to_string name) sch.sch_uri))
let navig loc env0 (env,comp) id =
match comp with
| ECDuce cu ->
let env = !from_comp_unit cu in
let c =
try find_id env0 env loc false id
with Not_found -> error loc "Unbound identifier" in
let c = match c with
| Val t -> EVal (cu,ident env0 loc id,t)
| c -> c in
env,c
| EOCaml cu ->
let s = cu ^ "." ^ (U.get_str id) in
(match (U.get_str id).[0] with
| 'A'..'Z' -> env,EOCaml s
| _ -> env,EOCamlComponent s)
| ESchema sch ->
env,find_schema_component sch (ident env0 loc id)
| _ -> error loc "Invalid dot access"
let rec find_global env loc ids =
match ids with
| id::rest ->
let comp = find_id env env loc true id in
snd (List.fold_left (navig loc env) (env,comp) rest)
| _ -> assert false
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 *)