[r2003-06-30 21:35:52 by cvscast] Review internal pretting printing of namespaces -- Alain

Original author: cvscast
Date: 2003-06-30 21:35:53+00:00

driver/cduce.ml

@@ -33,19 +33,18 @@ let print_value ppf v =
   Location.protect ppf (fun ppf -> Value.print ppf v)
 
 let dump_env ppf =
-  Format.fprintf ppf "Global types:";
-  Typer.dump_global_types ppf;
-  Format.fprintf ppf ".@.";
+  Format.fprintf ppf "Types:%t.@." Typer.dump_global_types;
+  Format.fprintf ppf "Namespace prefixes:@\n%t" Typer.dump_global_ns;
+  Format.fprintf ppf "Namespace prefixes used for pretty-printing:%t@."
+    Ns.InternalPrinter.dump;
+  Format.fprintf ppf "Values:@\n";
   Env.iter 
     (fun x v ->
        let t = Env.find x !typing_env in
        Format.fprintf ppf "@[val %a : @[%a = %a@]@]@."
 	 U.print (Id.value x) print_norm t print_value v
     )
-    !eval_env;
-  Format.fprintf ppf "Namespaces:@.";
-  Ns.dump_prefix_table ppf
-
+    !eval_env
 
 let rec print_exn ppf = function
   | Location (loc, w, exn) ->
@@ -174,7 +173,7 @@ let rec phrases ppf phs = match phs with
       Typer.register_schema name schema;
       phrases ppf rest
   | { descr = Ast.Namespace (pr,ns) } :: rest ->
-      Typer.register_ns_prefix pr ns;
+      Typer.register_global_ns pr ns;
       phrases ppf rest
   | { descr = Ast.EvalStatement e } :: rest ->
       let (fv,e) = Typer.expr e in

misc/ns.ml

+(* TODO:
+   special treatment of prefixes xml and xmlns *)
+
 module U = Encodings.Utf8
 let empty_str = U.mk ""
 
@@ -30,6 +33,13 @@ let add_prefix pr ns table =
   if (U.get_str pr <> "") then Hashtbl.add !global_hints ns pr;
   Table.add pr ns table
 
+let dump_table ppf table =
+  Table.iter
+    (fun pr ns ->
+       Format.fprintf ppf "%a=>\"%a\"@." U.print pr U.print (value ns)
+    ) table
+       
+
 type qname = t * U.t
 
 exception UnknownPrefix of U.t
@@ -64,50 +74,6 @@ let process_start_tag table tag attrs =
   aux table [] attrs
 
 
-
-(* TODO: harmonize pretty-printing of values and of XML documents *)
-
-  let prefixes_to_ns = State.ref "Ns.prefixes" (Hashtbl.create 63)
-  let ns_to_prefixes = State.ref "Ns.prefixes" (Hashtbl.create 63)
-
-  let register_prefix p ns =
-    if (Hashtbl.mem !prefixes_to_ns p) || 
-       (Hashtbl.mem !ns_to_prefixes ns) 
-    then ()
-    else ( Hashtbl.add !ns_to_prefixes ns p;
-	   Hashtbl.add !prefixes_to_ns p ns )
-
-  let counter = State.ref "Ns.prefixes" 0
-
-  let rec fresh_prefix () =
-    incr counter;
-    let s = U.mk (Printf.sprintf "ns%i" !counter) in
-    if (Hashtbl.mem !prefixes_to_ns s) then fresh_prefix () else s
-
-  let prefix ns =
-    try Hashtbl.find !ns_to_prefixes ns
-    with Not_found ->
-      let p = fresh_prefix () in
-      register_prefix p ns;
-      p
-
-  let dump_prefix_table ppf =
-    Hashtbl.iter
-      (fun ns p ->
-	 Format.fprintf ppf "%a=>%a@." U.print p U.print (value ns))
-      !ns_to_prefixes
-
-  let _ = register_prefix empty_str empty
-
-
-let print_prefix ppf ns =
-  if ns == empty then () else
-    Format.fprintf ppf "%a:" U.print (prefix ns)
-
-let print_qname ppf (ns,x)  = 
-  Format.fprintf ppf "%a%a" print_prefix ns U.print x
-
-
 module Printer = struct
 (* TODO: detect the case when there is no unqualified tag.
    In this case, it is possible to use a default namespace for
@@ -205,3 +171,29 @@ module Printer = struct
             else pr ^ ":" ^ (U.get_str l)
 	| _ -> assert false
 end
+
+
+module InternalPrinter =
+struct
+  let p = ref (Printer.printer empty_table)
+
+  let set_table t = 
+    p := Printer.printer t
+
+  let ns ns =
+    U.to_string (value ns)
+
+  let tag x =
+    Printer.register_tag !p x;
+    Printer.tag !p x
+
+  let attr x =
+    Printer.register_attr !p x;
+    Printer.attr !p x
+
+  let dump ppf =
+    List.iter
+      (fun (pr, ns) ->
+	 Format.fprintf ppf "%a=>\"%a\"@." U.print pr U.print (value ns)
+      )	(Printer.prefixes !p)
+end

misc/ns.mli

@@ -10,19 +10,20 @@ val compare: t -> t -> int
 val hash: t -> int
 val equal: t -> t -> bool
 
-type table  (* prefix => namespace *)
-val empty_table: table   
-  (* Contains only xml -> "http://www.w3.org/XML/1998/namespace" *)
-
 type qname = t * Utf8.t
 
+type table  (* prefix => namespace *)
+val empty_table: table  (* Contains only xml *)
 val add_prefix: Utf8.t -> t -> table -> table
+val dump_table: Format.formatter -> table -> unit
 
 val process_start_tag:
   table -> string -> (string * string) list -> 
     table * qname * (qname * Utf8.t) list
 
+(*
 val print_qname: Format.formatter -> qname -> unit 
+*)
 
 val map_tag: table -> Utf8.t -> qname
 val map_attr: table -> Utf8.t -> qname
@@ -44,7 +45,20 @@ end
     
 
 (***)
+
+module InternalPrinter : sig
+  val set_table: table -> unit
+
+  val ns: t -> string
+  val tag: qname -> string
+  val attr: qname -> string
+
+  val dump: Format.formatter -> unit
+end
+
+(*
 val register_prefix : Utf8.t -> t -> unit
 val prefix : t -> Utf8.t
 
 val dump_prefix_table : Format.formatter -> unit
+*)

parser/parser.ml

@@ -111,7 +111,6 @@ EXTEND
         let schema = Schema_parser.parse_schema schema_doc in
         [ mk loc (SchemaDecl (name, schema))]
     | (name,ns) = namespace_binding ->
-	Ns.register_prefix name ns;
 	[ mk loc (Namespace (name, ns)) ]
     | (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
 	let e = exp loc (NamespaceIn (name, ns, e2)) in

types/atoms.ml

@@ -23,13 +23,13 @@ let mk_ascii s = mk Ns.empty (Utf8.mk s)
 
 let value (ns,x) = (ns, Symbol.value x)
 
-let vprint ppf ((ns,x) : v) = 
-  Ns.print_qname ppf (ns, Symbol.value x)
+let vprint ppf (ns,x) = 
+  Format.fprintf ppf "%s" (Ns.InternalPrinter.tag (ns, Symbol.value x))
 
 let print_any_in_ns ppf ns =
-  let ns = Ns.prefix ns in
-  if Utf8.get_str ns = "" then Format.fprintf ppf ".:*"
-  else Format.fprintf ppf "%a:*" Utf8.print ns
+  let ns = Ns.InternalPrinter.ns ns in
+  if ns = "" then Format.fprintf ppf ".:*"
+  else Format.fprintf ppf "%s:*" ns
 
 let print_v ppf a = 
   Format.fprintf ppf "`%a" vprint a

types/ident.ml

@@ -14,12 +14,8 @@ module Label = struct
   type t = Ns.qname
   let equal (ns1,l1) (ns2,l2) = (Ns.equal ns1 ns2) && (U.equal l1 l2)
   let hash (ns,l) = Ns.hash ns + 17 * U.hash l
-  let print = Ns.print_qname
-  let to_string x =
-    let b = Buffer.create 32 in
-    let ppf = Format.formatter_of_buffer b in
-    print ppf x;
-    Buffer.contents b
+  let to_string x = Ns.InternalPrinter.attr x
+  let print ppf x = Format.fprintf ppf "%s" (to_string x)
 end
 
 module LabelPool = Pool.Make(Label)

typing/typer.ml

@@ -572,7 +572,7 @@ and pat_node s : Patterns.node =
     Patterns.define x (pat (descr s));
     x
 
-let register_global_types glb b =
+let register_types glb b =
   List.iter 
     (fun (v,p) ->
        if TypeEnv.mem v glb.tenv_names
@@ -596,12 +596,15 @@ let register_global_types glb b =
   List.iter (fun (v,t) -> Types.Print.register_global v t) b;
   glb
 
-let register_ns_prefix glb p ns =
+let register_ns glb p ns =
   { glb with tenv_nspref = Ns.add_prefix p ns glb.tenv_nspref }
 
-let dump_global_types ppf glb =
+let dump_types ppf glb =
   TypeEnv.iter (fun v _ -> Format.fprintf ppf " %a" U.print v) glb.tenv_names
 
+let dump_ns ppf glb =
+  Ns.dump_table ppf glb.tenv_nspref
+
 let do_typ loc r = 
   let s = compile_slot r in
   flush_defs ();
@@ -735,7 +738,7 @@ let rec expr glb loc = function
       and (fv2,b) = branches glb b in
       exp loc (Fv.cup fv1 fv2) (Typed.Try (e, b))
   | NamespaceIn (pr,ns,e) ->
-      let glb = register_ns_prefix glb pr ns in
+      let glb = register_ns glb pr ns in
       expr glb loc e
 
 	      
@@ -790,10 +793,11 @@ let typ t = typ !glb t
 let expr e = expr !glb e
 let let_decl p e = let_decl !glb p e
 
-let register_global_types l = glb := register_global_types !glb l
-let dump_global_types ppf = dump_global_types ppf !glb
+let register_global_types l = glb := register_types !glb l
+let dump_global_types ppf = dump_types ppf !glb
 
-let register_ns_prefix p ns = glb := register_ns_prefix !glb p ns
+let register_global_ns p ns = glb := register_ns !glb p ns
+let dump_global_ns ppf = dump_ns ppf !glb
 
 (* III. Type-checks *)
 

typing/typer.mli

@@ -14,9 +14,9 @@ type tenv
 val get_ns_table : tenv -> Ns.table
 
 val register_global_types : (U.t * Ast.ppat) list -> unit
+val register_global_ns : U.t -> Ns.t -> unit
 val dump_global_types: Format.formatter -> unit
-
-val register_ns_prefix : U.t -> Ns.t -> unit
+val dump_global_ns: Format.formatter -> unit
 
 val typ : Ast.ppat -> Typed.ttyp
 val pat : Ast.ppat -> Typed.tpat