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

Minor change to pretty printing functions

parent 29929a5d
...@@ -12,6 +12,22 @@ type env = { ...@@ -12,6 +12,22 @@ type env = {
global_size: int 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 global_size env = env.global_size
let mk cu = { let mk cu = {
......
...@@ -8,6 +8,7 @@ val global_size: env -> int ...@@ -8,6 +8,7 @@ val global_size: env -> int
val empty : Compunit.t -> env val empty : Compunit.t -> env
val empty_toplevel : env val empty_toplevel : env
val pp_env : Format.formatter -> env -> unit
val find : id -> env -> var_loc val find : id -> env -> var_loc
val find_slot : id -> env -> int val find_slot : id -> env -> int
......
...@@ -95,7 +95,7 @@ module Print = struct ...@@ -95,7 +95,7 @@ module Print = struct
(Encodings.Utf8.to_string name) (Encodings.Utf8.to_string name)
pp_vloc value pp_vloc value
let rec pp_lambda_sigma ppf = let rec pp_sigma ppf =
let pp_aux ppf = let pp_aux ppf =
Utils.pp_list (fun ppf (t1,t2) -> Utils.pp_list (fun ppf (t1,t2) ->
Format.fprintf ppf "(%a -> %a)" Format.fprintf ppf "(%a -> %a)"
...@@ -105,32 +105,32 @@ module Print = struct ...@@ -105,32 +105,32 @@ module Print = struct
in in
function function
|List ll -> Types.Tallying.CS.pp_sl ppf ll |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 |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_lambda_sigma s |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" |Identity -> Format.fprintf ppf "Id"
and pp_lambda ppf = function and pp ppf = function
| Var v -> Format.fprintf ppf "Var(%a)" pp_vloc v | 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 | 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_lambda e1 pp_lambda e2 | Apply (e1,e2) -> Format.fprintf ppf "Apply(%a,%a)" pp e1 pp e2
| PolyAbstraction (va, l, b, i, sigma) -> | 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) -> | Abstraction (va, l, b, i) ->
Format.fprintf ppf "Abstraction(%a,,%a,,)" pp_vloc_array va pp_lbranches b Format.fprintf ppf "Abstraction(%a,,%a,,)" pp_vloc_array va pp_lbranches b
| Check(_) -> Format.fprintf ppf "Check" | Check(_) -> Format.fprintf ppf "Check"
| Const(v) -> Format.fprintf ppf "Const(%a)" Value.Print.pp_value v | Const(v) -> Format.fprintf ppf "Const(%a)" Value.Print.pp v
| Pair(e1, e2) -> Format.fprintf ppf "Pair(%a, %a)" pp_lambda e1 pp_lambda e2 | Pair(e1, e2) -> Format.fprintf ppf "Pair(%a, %a)" pp e1 pp e2
| String(_) -> Format.fprintf ppf "String" | String(_) -> Format.fprintf ppf "String"
| Match(e, brs) -> Format.fprintf ppf "Match(%a, %a)" pp_lambda e pp_lbranches brs | 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_lambda) le | Op(str, le) -> Format.fprintf ppf "Op(%s, (%a))" str (Utils.pp_list pp) le
| _ -> () | _ -> ()
and pp_lbranches ppf brs = 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 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 = 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 end
...@@ -77,6 +77,8 @@ type code_item = ...@@ -77,6 +77,8 @@ type code_item =
type code = code_item list type code = code_item list
module Print : sig 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 val string_of_lambda : expr -> string
end end
...@@ -62,7 +62,9 @@ let dump_env ppf tenv cenv = ...@@ -62,7 +62,9 @@ let dump_env ppf tenv cenv =
Ns.InternalPrinter.dump; Ns.InternalPrinter.dump;
Format.fprintf ppf "Values:@."; Format.fprintf ppf "Values:@.";
Typer.iter_values tenv 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 = let directive_help ppf =
Format.fprintf ppf Format.fprintf ppf
...@@ -248,13 +250,14 @@ let debug ppf tenv cenv = function ...@@ -248,13 +250,14 @@ let debug ppf tenv cenv = function
| Not_found -> Format.fprintf ppf "Empty@.") | Not_found -> Format.fprintf ppf "Empty@.")
| `Typed e -> | `Typed e ->
Format.fprintf ppf "[DEBUG:typed]@."; Format.fprintf ppf "[DEBUG:typed]@.";
let r, _ = Typer.type_expr tenv e in let r, env = Typer.type_expr tenv e in
Format.fprintf ppf "%a@." Typed.Print.pp_typed r Format.fprintf ppf "%a@." Typed.Print.pp r;
Format.fprintf ppf "%a@." Typer.pp_env tenv
| `Lambda e -> | `Lambda e ->
Format.fprintf ppf "[DEBUG:lambda]@."; Format.fprintf ppf "[DEBUG:lambda]@.";
let r, _ = Typer.type_expr tenv e in let r, _ = Typer.type_expr tenv e in
let lambdaexpr,lsize = Compile.compile_expr cenv r 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 "@." let flush_ppf ppf = Format.fprintf ppf "@."
......
...@@ -63,17 +63,17 @@ let eval_var env locals = function ...@@ -63,17 +63,17 @@ let eval_var env locals = function
let tag_op_resolved = Obj.tag (Obj.repr (OpResolved ((fun _ -> assert false), []))) let tag_op_resolved = Obj.tag (Obj.repr (OpResolved ((fun _ -> assert false), [])))
let tag_const = Obj.tag (Obj.repr (Const (Obj.magic 0))) 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 aux a =
let l = Array.to_list a in let l = Array.to_list a in
let sl = List.mapi (fun i v -> 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 () Format.flush_str_formatter ()
) l ) l
in in
String.concat "," sl String.concat "," sl
in 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 let apply_sigma sigma = function
|Value.Pair(v1,v2,sigma') -> Value.Pair(v1,v2,Value.comp sigma sigma') |Value.Pair(v1,v2,sigma') -> Value.Pair(v1,v2,Value.comp sigma sigma')
......
...@@ -325,11 +325,11 @@ module Print = struct ...@@ -325,11 +325,11 @@ module Print = struct
in in
Utils.pp_list f ppf l Utils.pp_list f ppf l
let rec pp_value ppf = function let rec pp ppf = function
| Pair(v1, v2, sigma) -> | Pair(v1, v2, sigma) ->
Format.fprintf ppf "(%a,%a,%a)" Format.fprintf ppf "(%a,%a,%a)"
pp_value v1 pp v1
pp_value v2 pp v2
pp_sigma sigma pp_sigma sigma
| Xml(_,_,_,sigma) -> Format.fprintf ppf "Xml(%a)" pp_sigma sigma | Xml(_,_,_,sigma) -> Format.fprintf ppf "Xml(%a)" pp_sigma sigma
| XmlNs(_,_,_,_,sigma) -> Format.fprintf ppf "XmlNs(%a)" pp_sigma sigma | XmlNs(_,_,_,_,sigma) -> Format.fprintf ppf "XmlNs(%a)" pp_sigma sigma
...@@ -348,12 +348,12 @@ module Print = struct ...@@ -348,12 +348,12 @@ module Print = struct
| String_utf8(_,_,s,_) -> Format.fprintf ppf "\"%s\"" (Encodings.Utf8.get_str s) | String_utf8(_,_,s,_) -> Format.fprintf ppf "\"%s\"" (Encodings.Utf8.get_str s)
| Concat(v1, v2, sigma) -> | Concat(v1, v2, sigma) ->
Format.fprintf ppf "Concat(%a, %a, %a)" Format.fprintf ppf "Concat(%a, %a, %a)"
pp_value v1 pp v1
pp_value v2 pp v2
pp_sigma sigma pp_sigma sigma
| Absent -> Format.fprintf ppf "Absent" | 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 end
......
...@@ -34,7 +34,8 @@ val failwith': string -> 'a (* "failwith" for CDuce exceptions *) ...@@ -34,7 +34,8 @@ val failwith': string -> 'a (* "failwith" for CDuce exceptions *)
val tagged_tuple: string -> t list -> t val tagged_tuple: string -> t list -> t
module Print : sig 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 val string_of_value : t -> string
end end
......
...@@ -20,3 +20,11 @@ module LabelMap = LabelSet.Map ...@@ -20,3 +20,11 @@ module LabelMap = LabelSet.Map
type label = Ns.Label.t type label = Ns.Label.t
type 'a label_map = 'a LabelMap.map 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 ...@@ -2199,7 +2199,7 @@ struct
| [ h ] -> (pr_e pri) ppf h | [ h ] -> (pr_e pri) ppf h
| _ -> | _ ->
opar ppf ~level:pri_op pri; opar ppf ~level:pri_op pri;
loop l; loop (List.rev l);
cpar ppf ~level:pri_op pri cpar ppf ~level:pri_op pri
......
...@@ -101,15 +101,16 @@ module Print = struct ...@@ -101,15 +101,16 @@ module Print = struct
| Types.String(_, _, s, _) -> Format.fprintf ppf "\"%s\"" (Encodings.Utf8.to_string s) | Types.String(_, _, s, _) -> Format.fprintf ppf "\"%s\"" (Encodings.Utf8.to_string s)
| _ -> assert false | _ -> assert false
let rec pp_typed ppf e = let rec pp ppf e =
Format.fprintf ppf "{typ: %a; descr= %a}" Format.fprintf ppf "{typ: %a; descr= %a}"
Types.Print.pp_type e.exp_typ 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 match e.exp_descr with
| Forget(e, _) -> Format.fprintf ppf "Forget(%a)" pp_typed e | Subst(e,sl) -> Format.fprintf ppf "%a @@ %a" pp e Types.Tallying.CS.pp_sl sl
| Check(_, e, _) -> Format.fprintf ppf "Check(%a)" pp_typed e | Forget(e, _) -> Format.fprintf ppf "Forget(%a)" pp e
| Check(_, e, _) -> Format.fprintf ppf "Check(%a)" pp e
| TVar(id, name) -> | TVar(id, name) ->
Format.fprintf ppf "TVar(%s,%s)" Format.fprintf ppf "TVar(%s,%s)"
(string_of_int (Upool.int id)) (string_of_int (Upool.int id))
...@@ -123,20 +124,18 @@ module Print = struct ...@@ -123,20 +124,18 @@ module Print = struct
(string_of_int (Upool.int id)) (string_of_int (Upool.int id))
(Encodings.Utf8.to_string name) (Encodings.Utf8.to_string name)
| Apply(e1, e2) -> | 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) -> | Abstraction(abstr) ->
Format.fprintf ppf "Abstraction(%a)" pp_abst abstr Format.fprintf ppf "Abstraction(%a)" pp_abst abstr
| Cst(cst) -> pp_const ppf cst | Cst(cst) -> pp_const ppf cst
| Pair(e1, e2) -> | 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, _) -> | String(_, _, s, _) ->
Format.fprintf ppf "\"%s\"" (Encodings.Utf8.to_string s) Format.fprintf ppf "\"%s\"" (Encodings.Utf8.to_string s)
| Match(e, b) -> | Match(e, b) ->
Format.fprintf ppf "Match(%a,%a)" pp_typed e pp_branches b Format.fprintf ppf "Match(%a,%a)" pp e pp_branches b
| Subst(e, s) ->
Format.fprintf ppf "Subst(%a,[%a])" pp_typed e Types.Tallying.CS.pp_sl s
| Op(s, i, l) -> | 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 | _ -> assert false
and pp_abst ppf abstr = and pp_abst ppf abstr =
...@@ -178,7 +177,7 @@ module Print = struct ...@@ -178,7 +177,7 @@ module Print = struct
pp_fv br.br_vars_empty pp_fv br.br_vars_empty
Patterns.pp_node br.br_pat Patterns.pp_node br.br_pat
Types.Print.pp_type br.br_body.exp_typ Types.Print.pp_type br.br_body.exp_typ
pp_typed br.br_body pp br.br_body
in in
Utils.pp_list f ppf brs Utils.pp_list f ppf brs
...@@ -191,5 +190,5 @@ module Print = struct ...@@ -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 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) 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 end
...@@ -56,6 +56,24 @@ type t = { ...@@ -56,6 +56,24 @@ type t = {
keep_ns: bool 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 *) (* Namespaces *)
let set_ns_table_for_printer env = let set_ns_table_for_printer env =
......
...@@ -13,6 +13,7 @@ exception Error of string ...@@ -13,6 +13,7 @@ exception Error of string
exception Warning of string * Types.t exception Warning of string * Types.t
val empty_env: t val empty_env: t
val pp_env : Format.formatter -> t -> unit
val register_types : string -> t -> unit val register_types : string -> t -> unit
(* Register types of the environment for the pretty-printer *) (* 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