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

Original author: afrisch
Date: 2005-07-07 13:57:18+00:00

compile/compile.ml

@@ -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)
 
 

compile/compile.mli

@@ -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 -> 

driver/cduce.ml

@@ -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;

driver/librarian.ml

@@ -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);

driver/librarian.mli

@@ -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
 

driver/run.ml

@@ -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 

parser/ast.ml

@@ -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

parser/parser.ml

@@ -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

schema/schema_converter.ml

@@ -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 () = 

typing/typer.ml

@@ -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 *)