Minor change to pretty printing functions

compile/compile.ml

@@ -12,6 +12,22 @@ type env = {
   global_size: int
 }
 
+let pp_vars ppf vars =
+  Ident.pp_env Lambda.Print.pp_vloc ppf vars
+
+let pp_gamma ppf gamma =
+  Ident.pp_idmap Types.Print.pp_node ppf gamma
+
+let pp_xi ppf xi =
+  Ident.pp_idmap Var.Set.pp ppf xi
+
+let pp_env ppf env = 
+  Format.fprintf ppf "{vars=%a,sigma=%a,gamma=%a,xi=%a}"
+  pp_vars env.vars
+  Lambda.Print.pp_sigma env.sigma
+  pp_gamma env.gamma
+  pp_xi env.xi
+
 let global_size env = env.global_size
 
 let mk cu = { 

compile/compile.mli

@@ -8,6 +8,7 @@ val global_size: env -> int
 
 val empty : Compunit.t -> env
 val empty_toplevel : env
+val pp_env : Format.formatter -> env -> unit
 
 val find : id -> env -> var_loc
 val find_slot : id -> env -> int

compile/lambda.ml

@@ -95,7 +95,7 @@ module Print = struct
       (Encodings.Utf8.to_string name)
       pp_vloc value
 
-  let rec pp_lambda_sigma ppf =
+  let rec pp_sigma ppf =
     let pp_aux ppf =
       Utils.pp_list (fun ppf (t1,t2) ->
         Format.fprintf ppf "(%a -> %a)"
@@ -105,32 +105,32 @@ module Print = struct
     in
     function
       |List ll -> Types.Tallying.CS.pp_sl ppf ll
-      |Comp(s1,s2) -> Format.fprintf ppf "Comp(%a,%a)" pp_lambda_sigma s1 pp_lambda_sigma s2
-      |Sel(x,iface,s) -> Format.fprintf ppf "Sel(%a,%a,%a)" pp_vloc x pp_aux iface pp_lambda_sigma s
+      |Comp(s1,s2) -> Format.fprintf ppf "Comp(%a,%a)" pp_sigma s1 pp_sigma s2
+      |Sel(x,iface,s) -> Format.fprintf ppf "Sel(%a,%a,%a)" pp_vloc x pp_aux iface pp_sigma s
       |Identity -> Format.fprintf ppf "Id"
 
-  and pp_lambda ppf = function
+  and pp ppf = function
     | Var v -> Format.fprintf ppf "Var(%a)" pp_vloc v
-    | TVar (v,sigma) -> Format.fprintf ppf "TVar(%a,%a)" pp_vloc v pp_lambda_sigma sigma
-    | Apply (e1,e2) -> Format.fprintf ppf "Apply(%a,%a)" pp_lambda e1 pp_lambda e2
+    | TVar (v,sigma) -> Format.fprintf ppf "TVar(%a,%a)" pp_vloc v pp_sigma sigma
+    | Apply (e1,e2) -> Format.fprintf ppf "Apply(%a,%a)" pp e1 pp e2
     | PolyAbstraction (va, l, b, i, sigma) ->
-      Format.fprintf ppf "PolyAbstraction(%a,,%a,,%a)" pp_vloc_array va pp_lbranches b pp_lambda_sigma sigma
+      Format.fprintf ppf "PolyAbstraction(%a,,%a,,%a)" pp_vloc_array va pp_lbranches b pp_sigma sigma
     | Abstraction (va, l, b, i) ->
       Format.fprintf ppf "Abstraction(%a,,%a,,)" pp_vloc_array va pp_lbranches b
     | Check(_) -> Format.fprintf ppf "Check"
-    | Const(v) -> Format.fprintf ppf "Const(%a)" Value.Print.pp_value v
-    | Pair(e1, e2) -> Format.fprintf ppf "Pair(%a, %a)" pp_lambda e1 pp_lambda e2
+    | Const(v) -> Format.fprintf ppf "Const(%a)" Value.Print.pp v
+    | Pair(e1, e2) -> Format.fprintf ppf "Pair(%a, %a)" pp e1 pp e2
     | String(_) -> Format.fprintf ppf "String"
-    | Match(e, brs) -> Format.fprintf ppf "Match(%a, %a)" pp_lambda e pp_lbranches brs
-    | Op(str, le) -> Format.fprintf ppf "Op(%s, (%a))" str (Utils.pp_list pp_lambda) le
+    | Match(e, brs) -> Format.fprintf ppf "Match(%a, %a)" pp e pp_lbranches brs
+    | Op(str, le) -> Format.fprintf ppf "Op(%s, (%a))" str (Utils.pp_list pp) le
     | _ -> ()
 
   and pp_lbranches ppf brs =
     Format.fprintf ppf "{accept_chars=%b; brs_disp=<disp>; brs_rhs=[| %a |]; brs_stack_pos=%d}" brs.brs_accept_chars pp_patrhs brs.brs_rhs brs.brs_stack_pos
 
   and pp_patrhs ppf arr =
-    Array.iter (function | Auto_pat.Match(i, e) -> Format.fprintf ppf "(%d, %a)" i pp_lambda e | _ -> ()) arr
+    Array.iter (function | Auto_pat.Match(i, e) -> Format.fprintf ppf "(%d, %a)" i pp e | _ -> ()) arr
 
-  let string_of_lambda = Utils.string_of_formatter pp_lambda
+  let string_of_lambda = Utils.string_of_formatter pp
 
 end

compile/lambda.mli

@@ -77,6 +77,8 @@ type code_item =
 type code = code_item list
 
 module Print : sig
-  val pp_lambda : Format.formatter -> expr -> unit
+  val pp : Format.formatter -> expr -> unit
+  val pp_sigma : Format.formatter -> sigma -> unit
+  val pp_vloc : Format.formatter -> var_loc -> unit
   val string_of_lambda : expr -> string
 end

driver/cduce.ml

@@ -62,7 +62,9 @@ let dump_env ppf tenv cenv =
     Ns.InternalPrinter.dump;
   Format.fprintf ppf "Values:@.";
   Typer.iter_values tenv
-    (fun x t -> dump_value ppf x t (get_global_value cenv x))
+    (fun x t -> dump_value ppf x t (get_global_value cenv x));
+  Format.fprintf ppf "TEnv:%a@." Typer.pp_env tenv;
+  Format.fprintf ppf "CEnv:%a@." Compile.pp_env cenv
 
 let directive_help ppf =
   Format.fprintf ppf
@@ -248,13 +250,14 @@ let debug ppf tenv cenv = function
 	 | Not_found ->  Format.fprintf ppf "Empty@.")
   | `Typed e ->
       Format.fprintf ppf "[DEBUG:typed]@.";
-      let r, _ = Typer.type_expr tenv e in
-      Format.fprintf ppf "%a@." Typed.Print.pp_typed r
+      let r, env = Typer.type_expr tenv e in
+      Format.fprintf ppf "%a@." Typed.Print.pp r;
+      Format.fprintf ppf "%a@." Typer.pp_env tenv
   | `Lambda e ->
       Format.fprintf ppf "[DEBUG:lambda]@.";
       let r, _ = Typer.type_expr tenv e in
       let lambdaexpr,lsize = Compile.compile_expr cenv r in
-      Format.fprintf ppf "%a@." Lambda.Print.pp_lambda lambdaexpr
+      Format.fprintf ppf "%a@." Lambda.Print.pp lambdaexpr
 
 let flush_ppf ppf = Format.fprintf ppf "@."
 

runtime/eval.ml

@@ -63,17 +63,17 @@ let eval_var env locals = function
 let tag_op_resolved = Obj.tag (Obj.repr (OpResolved ((fun _ -> assert false), [])))
 let tag_const = Obj.tag (Obj.repr (Const (Obj.magic 0)))
 
-let pp_lambda_env ppf env locals =
+let pp_lambda_env ppf (env,locals) =
   let aux a =
     let l = Array.to_list a in
     let sl = List.mapi (fun i v ->
-      Format.fprintf Format.str_formatter "%d : %a@." i Value.Print.pp_value v;
+      Format.fprintf Format.str_formatter "%d : %a" i Value.Print.pp v;
       Format.flush_str_formatter ()
       ) l
     in
     String.concat "," sl
   in
-  Format.fprintf ppf "env = {%s}; locals = {%s}" (aux env) (aux locals)
+  Format.fprintf ppf "{env = {%s}; locals = {%s}}" (aux env) (aux locals)
 
 let apply_sigma sigma = function
   |Value.Pair(v1,v2,sigma') -> Value.Pair(v1,v2,Value.comp sigma sigma')

runtime/value.ml

@@ -325,11 +325,11 @@ module Print = struct
     in
     Utils.pp_list f ppf l
 
-  let rec pp_value ppf = function
+  let rec pp ppf = function
     | Pair(v1, v2, sigma) ->
         Format.fprintf ppf "(%a,%a,%a)"
-        pp_value v1
-        pp_value v2
+        pp v1
+        pp v2
         pp_sigma sigma
     | Xml(_,_,_,sigma) -> Format.fprintf ppf "Xml(%a)" pp_sigma sigma
     | XmlNs(_,_,_,_,sigma) -> Format.fprintf ppf "XmlNs(%a)" pp_sigma sigma
@@ -348,12 +348,12 @@ module Print = struct
     | String_utf8(_,_,s,_) -> Format.fprintf ppf "\"%s\"" (Encodings.Utf8.get_str s)
     | Concat(v1, v2, sigma) ->
         Format.fprintf ppf "Concat(%a, %a, %a)"
-        pp_value v1
-        pp_value v2
+        pp v1
+        pp v2
         pp_sigma sigma
     | Absent -> Format.fprintf ppf "Absent"
 
-  let string_of_value = Utils.string_of_formatter pp_value
+  let string_of_value = Utils.string_of_formatter pp
 
 end
 

runtime/value.mli

@@ -34,7 +34,8 @@ val failwith': string -> 'a   (* "failwith" for CDuce exceptions *)
 val tagged_tuple: string -> t list -> t
 
 module Print : sig
-  val pp_value : Format.formatter -> t -> unit
+  val pp : Format.formatter -> t -> unit
+  val pp_sigma : Format.formatter -> sigma -> unit
   val string_of_value : t -> string
 end
 

types/ident.ml

@@ -20,3 +20,11 @@ module LabelMap = LabelSet.Map
 
 type label = Ns.Label.t
 type 'a label_map = 'a LabelMap.map
+
+let pp_env f ppf env =
+  let f ppf (e,v) = Format.fprintf ppf "%a:%a" print e f v in
+  Utils.pp_list ~delim:("<",">") ~sep:";" f ppf (Env.bindings env)
+
+let pp_idmap f ppf map =
+  let f ppf (e,v) = Format.fprintf ppf "%a:%a" print e f v in
+  Utils.pp_list ~delim:("<",">") ~sep:";" f ppf (IdMap.get map)

types/types.ml

@@ -2199,7 +2199,7 @@ struct
     | [ h ] -> (pr_e pri) ppf h
     | _ ->
       opar ppf ~level:pri_op pri;
-      loop l;
+      loop (List.rev l);
       cpar ppf ~level:pri_op pri
 
 

typing/typed.ml

@@ -101,15 +101,16 @@ module Print = struct
       | Types.String(_, _, s, _) -> Format.fprintf ppf "\"%s\"" (Encodings.Utf8.to_string s)
       | _ -> assert false
 
-  let rec pp_typed ppf e =
+  let rec pp ppf e =
     Format.fprintf ppf "{typ: %a; descr= %a}"
       Types.Print.pp_type e.exp_typ
-      pp_typed_aux e
+      pp_aux e
 
-  and pp_typed_aux ppf e =
+  and pp_aux ppf e =
     match e.exp_descr with
-      | Forget(e, _) -> Format.fprintf ppf "Forget(%a)" pp_typed e
-      | Check(_, e, _) -> Format.fprintf ppf "Check(%a)" pp_typed e
+      | Subst(e,sl) -> Format.fprintf ppf "%a @@ %a" pp e Types.Tallying.CS.pp_sl sl
+      | Forget(e, _) -> Format.fprintf ppf "Forget(%a)" pp e
+      | Check(_, e, _) -> Format.fprintf ppf "Check(%a)" pp e
       | TVar(id, name) ->
           Format.fprintf ppf "TVar(%s,%s)"
             (string_of_int (Upool.int id))
@@ -123,20 +124,18 @@ module Print = struct
             (string_of_int (Upool.int id))
             (Encodings.Utf8.to_string name)
       | Apply(e1, e2) ->
-          Format.fprintf ppf "(%a).(%a)" pp_typed e1 pp_typed e2
+          Format.fprintf ppf "(%a).(%a)" pp e1 pp e2
       | Abstraction(abstr) ->
           Format.fprintf ppf "Abstraction(%a)" pp_abst abstr
       | Cst(cst) -> pp_const ppf cst
       | Pair(e1, e2) ->
-          Format.fprintf ppf "(%a, %a)" pp_typed e1 pp_typed e2
+          Format.fprintf ppf "(%a, %a)" pp e1 pp e2
       | String(_, _, s, _) ->
           Format.fprintf ppf "\"%s\"" (Encodings.Utf8.to_string s)
       | Match(e, b) ->
-          Format.fprintf ppf "Match(%a,%a)" pp_typed e pp_branches b
-      | Subst(e, s) ->
-          Format.fprintf ppf "Subst(%a,[%a])" pp_typed e Types.Tallying.CS.pp_sl s
+          Format.fprintf ppf "Match(%a,%a)" pp e pp_branches b
       | Op(s, i, l) ->
-          Format.fprintf ppf "(%s, %d, %a)" s i (Utils.pp_list pp_typed) l
+          Format.fprintf ppf "(%s, %d, %a)" s i (Utils.pp_list pp) l
       | _ -> assert false
 
   and pp_abst ppf abstr =
@@ -178,7 +177,7 @@ module Print = struct
 	pp_fv br.br_vars_empty
 	Patterns.pp_node br.br_pat
 	Types.Print.pp_type br.br_body.exp_typ
-	pp_typed br.br_body
+	pp br.br_body
     in
     Utils.pp_list f ppf brs
 
@@ -191,5 +190,5 @@ module Print = struct
     let pp_aux ppf (x,s) = Format.fprintf ppf "%a : %a" Ident.print x  Var.Set.pp s in
     Utils.pp_list ~sep:";" pp_aux ppf (Ident.IdMap.get m)
 
-  let string_of_typed = Utils.string_of_formatter pp_typed
+  let string_of_typed = Utils.string_of_formatter pp
 end

typing/typer.ml

@@ -56,6 +56,24 @@ type t = {
   keep_ns: bool
 }
 
+let pp_env ppf env =
+  (*
+  let pp_item ppf = function
+    |Type t | Val t -> Types.Print.pp_type ppf t
+    |ECDuce _ -> Format.fprintf ppf "ECDuce"
+    |ESchema _ -> Format.fprintf ppf "ESchema"
+    |ENamespace _ -> Format.fprintf ppf "ENamespace"
+    |_ -> ()
+  in
+  *)
+  Format.printf "{gamma=%a; delta=%a}"
+  (Ident.pp_idmap Types.Print.pp_node) env.gamma
+  Var.Set.pp env.delta
+  (*
+  (Ident.pp_env pp_item) env.ids
+  *)
+;;
+
 (* Namespaces *)
 
 let set_ns_table_for_printer env =

typing/typer.mli

@@ -13,6 +13,7 @@ exception Error of string
 exception Warning of string * Types.t
 
 val empty_env: t
+val pp_env : Format.formatter -> t -> unit
 
 val register_types : string -> t -> unit
   (* Register types of the environment for the pretty-printer *)