Commit 36e1499d authored by Pietro Abate's avatar Pietro Abate

Minor change to pretty printing functions

parent 29929a5d
......@@ -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 = {
......
......@@ -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
......
......@@ -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
......@@ -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
......@@ -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 "@."
......
......@@ -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')
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......@@ -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
......
......@@ -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
......@@ -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 =
......
......@@ -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 *)
......
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