[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.mli

@@ -17,8 +17,6 @@ val empty_env: t
 val register_types : string -> t -> unit
   (* Register types of the environment for the pretty-printer *)
 
-val enter_cu : U.t -> Compunit.t -> t -> t 
-val find_cu  : U.t -> t -> Compunit.t
 
 val find_value: id -> t -> Types.t
 val enter_type: id -> Types.t -> t -> t
@@ -32,9 +30,9 @@ val dump_ns: Format.formatter -> t -> unit
 val set_ns_table_for_printer: t -> unit
 
 
-val type_schema: t -> U.t -> string -> t
-
-val type_ns : t -> U.t -> Ns.Uri.t -> t
+val type_using: t -> Location.loc -> U.t -> U.t -> t
+val type_schema: t -> Location.loc -> U.t -> string -> t
+val type_ns : t -> Location.loc -> U.t -> Ast.ns_expr -> t
 
 val type_keep_ns : t -> bool -> t
 
@@ -50,8 +48,6 @@ val type_let_funs: t -> Ast.pexpr list ->
   (* Assume that all the expressions are Abstractions *)
 
 
-val get_schema_names: t -> U.t list  (** registered schema names *)
-
 (* Operators *)
 
 type type_fun = Types.t -> bool -> Types.t
@@ -70,4 +66,4 @@ val has_static_external: (string -> bool) ref
 
 
 val load_schema: 
-  (U.t -> string -> (Types.t * Schema_validator.t) Ident.Env.t) ref
+  (string -> string -> Ns.Uri.t * (Types.t * Schema_validator.t) Ident.Env.t) ref