Skip to content

GitLab

Commit 1b67f651 authored by Pietro Abate's avatar Pietro Abate
Browse files

[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
parent a5d9af9b
Hide whitespace changes
Inline Side-by-side
Showing with 81 additions and 77 deletions
driver/cduce.ml
View file @ 1b67f651
......@@ -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
View file @ 1b67f651
(* 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
View file @ 1b67f651
......@@ -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
View file @ 1b67f651
......@@ -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
View file @ 1b67f651
......@@ -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
View file @ 1b67f651
......@@ -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
View file @ 1b67f651
......@@ -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
View file @ 1b67f651
......@@ -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
......
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