Commit c15314b2 authored by Pietro Abate's avatar Pietro Abate

Refactor all print functions

- from Module.xxx_to_string to Module.Print.string_of_xxxx
- from Module.print_xxx to Module.Print.pp_xx
parent 18ae0d03
......@@ -145,7 +145,7 @@ CLEAN_DIRS = $(DIRS) tools tests
OBJECTS = \
driver/cduce_config.cmo misc/stats.cmo misc/custom.cmo misc/encodings.cmo \
misc/upool.cmo misc/pretty.cmo misc/ns.cmo misc/imap.cmo misc/html.cmo \
misc/upool.cmo misc/pretty.cmo misc/ns.cmo misc/imap.cmo misc/html.cmo misc/utils.cmo \
\
types/compunit.cmo types/sortedList.cmo misc/bool.cmo types/ident.cmo \
types/intervals.cmo types/chars.cmo types/atoms.cmo types/normal.cmo \
......@@ -181,8 +181,6 @@ schema/schema_types.ml: schema/schema_types.mli
cp $^ $@
compile/auto_pat.ml: compile/auto_pat.mli
cp $^ $@
compile/lambda.ml: compile/lambda.mli
cp $^ $@
ML_INTERFACE_OBJS = \
ocamliface/caml_cduce.cmo \
......
......@@ -77,23 +77,6 @@ type code = code_item list
module Print = struct
let print_to_string f x =
let b = Buffer.create 1024 in
let ppf = Format.formatter_of_buffer b in
f ppf x;
Format.pp_print_flush ppf ();
Buffer.contents b
let print_lst f ppf l =
let rec aux ppf = function
|[] -> Format.fprintf ppf "@."
|[h] -> Format.fprintf ppf "%a" f h
|h::t -> Format.fprintf ppf "%a,%a" f h aux t
in
match l with
|[] -> Format.fprintf ppf ""
|_ -> Format.fprintf ppf "%a" aux l
let pp_vloc ppf = function
| Local(i) -> Format.fprintf ppf "Local(%d)" i
| Env(i) -> Format.fprintf ppf "Env(%d)" i
......@@ -104,7 +87,7 @@ module Print = struct
| Dummy -> Format.fprintf ppf "Dummy"
let pp_vloc_array ppf a =
print_lst pp_vloc ppf (Array.to_list a)
Utils.pp_list pp_vloc ppf (Array.to_list a)
let pp_binding ppf (id, name) value =
Format.fprintf ppf "((%d,%s),%a)\n"
......@@ -114,10 +97,10 @@ module Print = struct
let rec pp_lambda_sigma ppf =
let pp_aux ppf =
print_lst (fun ppf (t1,t2) ->
Format.fprintf ppf "(%a -> %a)"
Types.Print.print t1
Types.Print.print t2
Utils.pp_list (fun ppf (t1,t2) ->
Format.fprintf ppf "(%a -> %a)"
Types.Print.print t1
Types.Print.print t2
) ppf
in
function
......@@ -135,11 +118,11 @@ module Print = struct
| 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.pp_value v
| 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
| 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, (" str; print_lst pp_lambda ppf le; Format.fprintf ppf "))"
| Op(str, le) -> Format.fprintf ppf "Op(%s, (%a))" str (Utils.pp_list pp_lambda) le
| _ -> ()
and pp_lbranches ppf brs =
......@@ -148,6 +131,6 @@ module Print = struct
and pp_patrhs ppf arr =
Array.iter (function | Auto_pat.Match(i, e) -> Format.fprintf ppf "(%d, %a)" i pp_lambda e | _ -> ()) arr
let lambda_to_string = print_to_string pp_lambda
let string_of_lambda = Utils.string_of_formatter pp_lambda
end
......@@ -77,5 +77,6 @@ type code_item =
type code = code_item list
module Print : sig
val lambda_to_string : expr -> string
val string_of_lambda : expr -> string
val pp_lambda : Format.formatter -> expr -> unit
end
......@@ -67,7 +67,7 @@ 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 pp_value v;
Format.fprintf Format.str_formatter "%d : %a@." i Value.Print.pp_value v;
Format.flush_str_formatter ()
) l
in
......
......@@ -308,165 +308,148 @@ let rec is_str = function
| Concat (_,_) as v -> eval_lazy_concat v; is_str v
| _ -> false
let print_lst f ppf l =
let rec aux ppf = function
|[] -> Format.fprintf ppf "@."
|[h] -> Format.fprintf ppf "%a" f h
|h::t -> Format.fprintf ppf "%a,%a" f h aux t
in
match l with
|[] -> Format.fprintf ppf ""
|_ -> Format.fprintf ppf "%a" aux l
let rec pp_sigma ppf =
let pp_aux ppf =
print_lst (fun ppf (t1,t2) ->
Format.fprintf ppf "(%a -> %a)"
module Print = struct
let rec pp_sigma ppf =
let pp_aux ppf =
Utils.pp_list (fun ppf (t1,t2) ->
Format.fprintf ppf "(%a -> %a)"
Types.Print.print t1
Types.Print.print t2
) ppf
in
function
|List ll -> Types.Tallying.CS.pp_sl ppf ll
|Comp(s1,s2) -> Format.fprintf ppf "Comp(%a,%a)" pp_sigma s1 pp_sigma s2
|Sel(x,iface,s) -> Format.fprintf ppf "Sel(%d,%a,%a)" x pp_aux iface pp_sigma s
|Identity -> Format.fprintf ppf "Id"
|Mono -> Format.fprintf ppf "Mono"
let pp_iface ppf l =
let f ppf (t1,t2) =
Format.fprintf ppf "(%a,%a)"
Types.Print.print t1
Types.Print.print t2
) ppf
in
function
|List ll -> Types.Tallying.CS.pp_sl ppf ll
|Comp(s1,s2) -> Format.fprintf ppf "Comp(%a,%a)" pp_sigma s1 pp_sigma s2
|Sel(x,iface,s) -> Format.fprintf ppf "Sel(%d,%a,%a)" x pp_aux iface pp_sigma s
|Identity -> Format.fprintf ppf "Id"
|Mono -> Format.fprintf ppf "Mono"
let pp_iface ppf l =
let f ppf (t1,t2) =
Format.fprintf ppf "(%a,%a)"
Types.Print.print t1
Types.Print.print t2
in
print_lst f ppf l
(* For debugging *)
let rec pp_value ppf = function
| Pair(v1, v2, sigma) ->
Format.fprintf ppf "(%a,%a,%a)"
pp_value v1
pp_value v2
pp_sigma sigma
| Xml(_,_,_,sigma) -> Format.fprintf ppf "Xml(%a)" pp_sigma sigma
| XmlNs(_,_,_,_,sigma) -> Format.fprintf ppf "XmlNs(%a)" pp_sigma sigma
| Record(_,sigma) -> Format.fprintf ppf "Record(%a)" pp_sigma sigma
| Atom(a) -> Format.fprintf ppf "Atom(%a)" Atoms.V.print a
| Integer(i) -> Format.fprintf ppf "%d" (Intervals.V.get_int i)
| Char(i) -> Format.fprintf ppf "'%c'" (Chars.V.to_char i)
| Abstraction(None, _, sigma) ->
Format.fprintf ppf "Abstraction(None,%a)" pp_sigma sigma
| Abstraction(Some t, _, sigma) ->
Format.fprintf ppf "Abstraction(%a,%a)"
pp_iface t
pp_sigma sigma
| Abstract((name, _)) -> Format.fprintf ppf "Abstract(%s)" name
| String_latin1(_,_,s,_) -> Format.fprintf ppf "\"%s\"" s
| String_utf8(_,_,s,_) -> Format.fprintf ppf "\"%s\"" (Encodings.Utf8.get_str s)
| Concat(v1, v2) ->
Format.fprintf ppf "Concat(%a, %a)"
pp_value v1
pp_value v2
| Absent -> Format.fprintf ppf "Absent"
let print_to_string f x =
let b = Buffer.create 1024 in
let ppf = Format.formatter_of_buffer b in
f ppf x;
Format.pp_print_flush ppf ();
Buffer.contents b
let print_value = Format.printf "%a" pp_value
let value_to_string = print_to_string pp_value
in
Utils.pp_list f ppf l
let rec pp_value ppf = function
| Pair(v1, v2, sigma) ->
Format.fprintf ppf "(%a,%a,%a)"
pp_value v1
pp_value v2
pp_sigma sigma
| Xml(_,_,_,sigma) -> Format.fprintf ppf "Xml(%a)" pp_sigma sigma
| XmlNs(_,_,_,_,sigma) -> Format.fprintf ppf "XmlNs(%a)" pp_sigma sigma
| Record(_,sigma) -> Format.fprintf ppf "Record(%a)" pp_sigma sigma
| Atom(a) -> Format.fprintf ppf "Atom(%a)" Atoms.V.print a
| Integer(i) -> Format.fprintf ppf "%d" (Intervals.V.get_int i)
| Char(i) -> Format.fprintf ppf "'%c'" (Chars.V.to_char i)
| Abstraction(None, _, sigma) ->
Format.fprintf ppf "Abstraction(None,%a)" pp_sigma sigma
| Abstraction(Some t, _, sigma) ->
Format.fprintf ppf "Abstraction(%a,%a)"
pp_iface t
pp_sigma sigma
| Abstract((name, _)) -> Format.fprintf ppf "Abstract(%s)" name
| String_latin1(_,_,s,_) -> Format.fprintf ppf "\"%s\"" s
| String_utf8(_,_,s,_) -> Format.fprintf ppf "\"%s\"" (Encodings.Utf8.get_str s)
| Concat(v1, v2) ->
Format.fprintf ppf "Concat(%a, %a)"
pp_value v1
pp_value v2
| Absent -> Format.fprintf ppf "Absent"
let string_of_value = Utils.string_of_formatter pp_value
end
let rec print ppf v =
if is_str v then
(Format.fprintf ppf "\"";
ignore (print_quoted_str ppf v);
ignore (pp_quoted_str ppf v);
Format.fprintf ppf "\"")
else if is_seq v then Format.fprintf ppf "[ @[<hv>%a@]]" print_seq v
else if is_seq v then Format.fprintf ppf "[ @[<hv>%a@]]" pp_seq v
else match v with
| Pair (x,y,sigma) -> Format.fprintf ppf "(%a,%a,%a)" print x print y pp_sigma sigma
| Xml (x,y,z,sigma) | XmlNs (x,y,z,_,sigma) -> print_xml ppf x y z (* sigma *)
| Record (l,sigma) -> Format.fprintf ppf "@[{%a },%a@]" print_record (Imap.elements l) pp_sigma sigma
| Atom a -> Atoms.V.print_quote ppf a
| Pair (x,y,sigma) -> Format.fprintf ppf "(%a,%a,%a)" print x print y Print.pp_sigma sigma
| Xml (x,y,z,sigma) | XmlNs (x,y,z,_,sigma) -> pp_xml ppf x y z (* sigma *)
| Record (l,sigma) -> Format.fprintf ppf "@[{%a },%a@]" pp_record (Imap.elements l) Print.pp_sigma sigma
| Atom a -> Atoms.V.print ppf a
| Integer i -> Intervals.V.print ppf i
| Char c -> Chars.V.print ppf c
| Abstraction _ -> Format.fprintf ppf "<fun>"
| String_latin1 (i,j,s,q) ->
Format.fprintf ppf "<string_latin1:%i-%i,%S,%a>" i j s print q
Format.fprintf ppf "<string_latin1:%i-%i,%S,%a>" i j s print q
| String_utf8 (i,j,s,q) ->
Format.fprintf ppf "<string_utf8:%i-%i,%S,%a>"
(Utf8.get_idx i) (Utf8.get_idx j) (Utf8.get_str s) print q
Format.fprintf ppf "<string_utf8:%i-%i,%S,%a>"
(Utf8.get_idx i) (Utf8.get_idx j) (Utf8.get_str s) print q
| Concat (x,y) ->
Format.fprintf ppf "<concat:%a;%a>" print x print y
Format.fprintf ppf "<concat:%a;%a>" print x print y
| Abstract ("float",o) ->
Format.fprintf ppf "%f" (Obj.magic o : float)
Format.fprintf ppf "%f" (Obj.magic o : float)
| Abstract ("cdata",o) ->
let s = Utf8.get_str (Obj.magic o : Utf8.t) in
Format.fprintf ppf "'%s'" s
(* Format.fprintf ppf "%s" (Utf8.get_str (Obj.magic o :
* Encodings.Utf8.t)) *)
| Abstract (s,_) ->
Format.fprintf ppf "<abstract=%s>" s
Format.fprintf ppf "<abstract=%s>" s
| Absent ->
Format.fprintf ppf "<[absent]>"
and print_quoted_str ppf = function
Format.fprintf ppf "<[absent]>"
and pp_quoted_str ppf = function
| Pair (Char c, q,_) ->
Chars.V.print_in_string ppf c;
print_quoted_str ppf q
pp_quoted_str ppf q
| String_latin1 (i,j,s, q) ->
for k = i to j - 1 do
Chars.V.print_in_string ppf (Chars.V.mk_char s.[k])
Chars.V.print_in_string ppf (Chars.V.mk_char s.[k])
done;
print_quoted_str ppf q
pp_quoted_str ppf q
| String_utf8 (i,j,s, q) ->
(* Format.fprintf ppf "UTF8:{"; *)
let rec aux i =
if Utf8.equal_index i j then q
else
let (c,i) =Utf8.next s i in
Chars.V.print_in_string ppf (Chars.V.mk_int c);
aux i
if Utf8.equal_index i j then q
else
let (c,i) =Utf8.next s i in
Chars.V.print_in_string ppf (Chars.V.mk_int c);
aux i
in
let q = aux i in
(* Format.fprintf ppf "}"; *)
print_quoted_str ppf q
pp_quoted_str ppf q
| q -> q
and print_seq ppf = function
and pp_seq ppf = function
| (Pair(Char _, _,_)|String_latin1 (_,_,_,_)|String_utf8 (_,_,_,_)) as s ->
Format.fprintf ppf "'";
let q = print_quoted_str ppf s in
let q = pp_quoted_str ppf s in
Format.fprintf ppf "'@ ";
print_seq ppf q
pp_seq ppf q
| Pair (x,y,_) ->
Format.fprintf ppf "@[%a@]@ " print x;
print_seq ppf y
pp_seq ppf y
| _ -> ()
and print_xml ppf tag attr content =
and pp_xml ppf tag attr content =
if is_seq content then
Format.fprintf ppf "@[<hv2><%a%a>[@ %a@]]"
print_tag tag
print_attr attr
print_seq content
pp_tag tag
pp_attr attr
pp_seq content
else
Format.fprintf ppf "@[<hv2><%a%a>@ %a@]"
print_tag tag
print_attr attr
pp_tag tag
pp_attr attr
print content
and print_tag ppf = function
and pp_tag ppf = function
| Atom tag -> Atoms.V.print ppf tag
| tag -> Format.fprintf ppf "(%a)" print tag
and print_attr ppf = function
| Record (attr,_) -> print_record ppf (Imap.elements attr)
and pp_attr ppf = function
| Record (attr,_) -> pp_record ppf (Imap.elements attr)
| attr -> Format.fprintf ppf "(%a)" print attr
and print_record ppf = function
and pp_record ppf = function
| [] -> ()
| f :: rem -> Format.fprintf ppf "@ %a" print_field f; print_record ppf rem
and print_field ppf (l,v) =
| f :: rem -> Format.fprintf ppf "@ %a" pp_field f; pp_record ppf rem
and pp_field ppf (l,v) =
Format.fprintf ppf "%a=%a" Label.print_attr (Label.from_int l) print v
let dump_xml ppf v =
......@@ -480,7 +463,7 @@ let dump_xml ppf v =
| Record (x,sigma) ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<record>@,%a@,</record>@]"
(fun ppf x -> print_record ppf (Imap.elements x)) x
(fun ppf x -> pp_record ppf (Imap.elements x)) x
| Atom a ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<atom>@,%a@,</atom>@]"
......
......@@ -34,9 +34,11 @@ val raise': t -> 'a (* "raise" for CDuce exceptions *)
val failwith': string -> 'a (* "failwith" for CDuce exceptions *)
val tagged_tuple: string -> t list -> t
val pp_value : Format.formatter -> t -> unit
val print_value : t -> unit
val value_to_string : t -> string
module Print : sig
val pp_value : Format.formatter -> t -> unit
val string_of_value : t -> string
end
val print: Format.formatter -> t -> unit
val dump_xml: Format.formatter -> t -> unit
......
......@@ -3,7 +3,7 @@ ROOTDIR ?= ../..
SRCDIR ?= src
EXTDIR ?= $(SRCDIR)/externals
INEXTFILES = misc/custom.ml misc/encodings.ml misc/upool.ml misc/ns.ml\
INEXTFILES = misc/utils.ml misc/custom.ml misc/encodings.ml misc/upool.ml misc/ns.ml\
types/sortedList.ml types/ident.ml misc/html.ml types/sequence.ml\
types/patterns.ml parser/cduce_loc.mli parser/cduce_loc.ml typing/typed.ml\
types/builtin_defs.ml parser/ast.ml parser/parser.ml parser/ulexer.ml typing/typepat.mli typing/typepat.ml\
......
......@@ -7,9 +7,9 @@ let run_test_compile msg expected totest =
try
let expr = Parse.ExprParser.of_string_no_file str in
let env, texpr = Compute.to_typed expr in
Format.printf "Computed Typed -> %s%!@." (Typed.Print.typed_to_string texpr);
Format.printf "Computed Typed -> %a%!@." Typed.Print.pp_typed texpr;
let lambdaexpr = Compile.compile env texpr in
Lambda.Print.lambda_to_string lambdaexpr
Lambda.Print.string_of_lambda lambdaexpr
with
| Compute.Error -> exit 3
| Loc.Exc_located (loc, exn) ->
......@@ -88,11 +88,10 @@ let run_test_eval str =
let env, texpr = Compute.to_typed expr in
let lambdaexpr,lsize = Compile.compile_expr env texpr in
Format.printf "Input : %s\n" str;
Format.printf "Lambda : %s\n" (Lambda.Print.lambda_to_string lambdaexpr);
Format.printf "Lambda : %s\n" (Lambda.Print.string_of_lambda lambdaexpr);
let evalexpr = Eval.expr lambdaexpr lsize in
let v = Value.value_to_string evalexpr in
Format.printf "Eval : %s\n\n" v;
v
Format.printf "Eval : %a\n\n" Value.Print.pp_value evalexpr;
Value.Print.string_of_value evalexpr
with
| Compute.Error -> exit 3
| Loc.Exc_located (loc, exn) ->
......
......@@ -151,7 +151,7 @@ let parse_cduce ?(verbose=false) s =
with exn -> catch_exn Format.err_formatter exn
in
if verbose then
Format.printf "Cduce Typed %s ====> \n %s\n%!@." s (Typed.Print.typed_to_string texpr);
Format.printf "Cduce Typed %s ====> \n %a\n%!@." s Typed.Print.pp_typed texpr;
texpr
(* Typed AST -> Typed *)
......@@ -159,7 +159,7 @@ let parse_texpr ?(verbose=false) s =
let expr = Parse.ExprParser.of_string_no_file s in
let env, texpr = Compute.to_typed expr in
if verbose then
Format.printf "Computed Typed %s ====> \n %s\n%!@." s (Typed.Print.typed_to_string texpr);
Format.printf "Computed Typed %s ====> \n %a\n%!@." s Typed.Print.pp_typed texpr;
texpr
(* --> Lambda *)
......@@ -169,7 +169,7 @@ let parse_lexpr ?(verbose=false) texpr =
with exn -> catch_exn Format.err_formatter exn
in
if verbose then
Format.printf "Lambda : %s\n%!@." (Lambda.Print.lambda_to_string lambdaexpr);
Format.printf "Lambda : %s\n%!@." (Lambda.Print.string_of_lambda lambdaexpr);
lambdaexpr, lsize
(* --> Value *)
......@@ -179,7 +179,7 @@ let parse_vexpr ?(verbose=false) (lambdaexpr,lsize) =
with exn -> catch_exn Format.err_formatter exn
in
if verbose then
Format.printf "Value : %s\n%!@." (Value.value_to_string evalexpr);
Format.printf "Value : %s\n%!@." (Value.Print.string_of_value evalexpr);
evalexpr
(* Cduce program -> Lambda *)
......
......@@ -4,12 +4,12 @@ open Testlib
let run_test_typer msg expected totest _ =
let expected = parse_texpr expected in
let totest = parse_cduce totest in
assert_equal ~msg:msg ~printer:(fun x -> Typed.Print.typed_to_string x) expected totest
assert_equal ~msg:msg ~printer:(fun x -> Typed.Print.string_of_typed x) expected totest
let run_test_compile msg expected totest _ =
let expected,_ = parse_texpr_lexpr expected in
let totest,_ = parse_cduce_lexpr totest in
assert_equal ~msg:msg ~printer:(fun x -> Lambda.Print.lambda_to_string x) expected totest
assert_equal ~msg:msg ~printer:(fun x -> Lambda.Print.string_of_lambda x) expected totest
(* (message, typed expr - expected, cduce expr) *)
let tests_typer_list = [
......
......@@ -6,7 +6,7 @@ open Testlib
let run_test_compile msg expected totest _ =
let expected,_ = parse_texpr_lexpr expected in
let totest,_ = parse_cduce_lexpr totest in
assert_equal ~msg:msg ~printer:(fun x -> Lambda.Print.lambda_to_string x) expected totest
assert_equal ~msg:msg ~printer:(fun x -> Lambda.Print.string_of_lambda x) expected totest
let tests_poly_abstr = [
"Test CDuce.lambda.const_abstr failed",
......@@ -52,7 +52,7 @@ let tests_compile = "CDuce compile tests (Typed -> Lambda )" >:::
let run_test_eval msg expected totest _ =
let expected = parse_texpr_vexpr expected in
let totest = parse_cduce_vexpr totest in
assert_equal ~msg:msg ~printer:(fun x -> x) (Value.value_to_string expected) (Value.value_to_string totest)
assert_equal ~msg:msg ~printer:(fun x -> x) (Value.Print.string_of_value expected) (Value.Print.string_of_value totest)
let tests_eval = "CDuce evaluation tests (Typed -> Lambda -> Value )" >:::
List.map (fun (m,e,f) -> f >:: run_test_eval m e f) tests_poly_abstr
......
......@@ -260,9 +260,6 @@ struct
}
type t = s
let print_lst ppf =
List.iter (fun f -> f ppf; Format.fprintf ppf " |")
let dump ppf d =
Format.fprintf ppf "<types atoms(%a) ints(%a) chars(%a) times(%a) arrow(%a) record(%a) xml(%a) abstract(%a) absent(%b)>\n%a"
BoolAtoms.dump d.atoms
......@@ -2562,21 +2559,11 @@ struct
let node_name = Printf.sprintf "X_%i" !id in
incr id;
MemoHash.add memo v node_name;
let print_lst f ppf l =
let rec aux ppf = function
|[] -> Format.fprintf ppf "@."
|[h] -> Format.fprintf ppf "%a" f h
|h::t -> Format.fprintf ppf "%a ;%a" f h aux t
in
match l with
|[] -> Format.fprintf ppf "[]"
|_ -> Format.fprintf ppf "[%a]" aux l
in
match v.def with
|`Type d -> Format.fprintf ppf "`Type(%a)" Print.print d
|`Variable d -> Format.fprintf ppf "`Var(%a)" Var.print d
|`Cup vl -> Format.fprintf ppf "`Cup(%a)" (print_lst aux) vl
|`Cap vl -> Format.fprintf ppf "`Cap(%a)" (print_lst aux) vl
|`Cup vl -> Format.fprintf ppf "`Cup([%a])" (Utils.pp_list aux) vl
|`Cap vl -> Format.fprintf ppf "`Cap(%a)" (Utils.pp_list aux) vl
|`Times (v1,v2) -> Format.fprintf ppf "`Times(%a,%a)" aux v1 aux v2
|`Arrow (v1,v2) -> Format.fprintf ppf "`Arrow(%a,%a)" aux v1 aux v2
|`Xml (v1,v2) -> Format.fprintf ppf "`Xml(%a,%a)" aux v1 aux v2
......@@ -2724,16 +2711,6 @@ module Tallying = struct
module CS = struct
let print_lst f ppf l =
let rec aux ppf = function
|[] -> Format.fprintf ppf "@."
|[h] -> Format.fprintf ppf "%a" f h
|h::t -> Format.fprintf ppf "%a ,%a" f h aux t
in
match l with
|[] -> Format.fprintf ppf "{}"
|_ -> Format.fprintf ppf "{ %a }" aux l
(* we require that types are semantically equivalent and not structurally
* equivalent *)
let semantic_compare t1 t2 =
......@@ -2779,9 +2756,10 @@ module Tallying = struct
with Not_found -> false
) map1
let print ppf map = print_lst (fun ppf (v, (i,s)) ->
Format.fprintf ppf "%a <= %a <= %a" Print.print i
Var.print v Print.print s) ppf (VarMap.bindings map)
let pp ppf map =
Utils.pp_list (fun ppf (v, (i,s)) ->
Format.fprintf ppf "%a <= %a <= %a" Print.print i Var.print v Print.print s
) ppf (VarMap.bindings map)
let compare map1 map2 =
VarMap.compare (fun (i1,s1) (i2,s2) ->
......@@ -2803,8 +2781,8 @@ module Tallying = struct
let compare = Var.compare
end)
let print ppf e =
print_lst (fun ppf -> fun (v,t) ->
let pp ppf e =
Utils.pp_list (fun ppf -> fun (v,t) ->
Format.fprintf ppf "%a = %a@," Var.print v Print.print t
) ppf (bindings e)
......@@ -2817,7 +2795,7 @@ module Tallying = struct
let compare = E.compare semantic_compare
end)
let print ppf s = print_lst E.print ppf (elements s)
let pp ppf s = Utils.pp_list E.pp ppf (elements s)
end
(* Set of constraint sets *)
......@@ -2843,9 +2821,9 @@ module Tallying = struct
in
loop m l []
let singleton m = add m empty
let singleton m = add m empty
let print ppf s = print_lst M.print ppf s
let pp ppf s = Utils.pp_list M.pp ppf s
let fold f l a = List.fold_left (fun e a -> f a e) a l
......@@ -2926,7 +2904,7 @@ module Tallying = struct
let compare = E.compare compare
let equal = E.equal equal
let hash _= 1
let dump = E.print
let dump = E.pp
let check _ = ()
end)
......@@ -2936,10 +2914,10 @@ module Tallying = struct
|Pos (v,s) -> S.singleton (M.singleton v (empty,s))
|Neg (s,v) -> S.singleton (M.singleton v (s,any))
let pp_s = S.print
let pp_m = M.print
let pp_e = E.print
let pp_sl ppf ll = print_lst E.print ppf ll
let pp_s = S.pp
let pp_m = M.pp
let pp_e = E.pp
let pp_sl ppf ll = Utils.pp_list E.pp ppf ll
let sat = S.singleton M.empty
let unsat = S.empty
......
......@@ -371,17 +371,17 @@ module Tallying : sig
val empty : t
val add : key -> descr*descr -> t -> t
val singleton : key -> descr*descr -> t
val print : Format.formatter -> t -> unit
val pp : Format.formatter -> t -> unit
val merge : t -> t -> t
end
module E : sig
include Map.S with type key = Var.var
val print : Format.formatter -> descr t -> unit
val pp : Format.formatter -> descr t -> unit
end
module ES : sig
include Set.S with type elt = descr E.t
val print : Format.formatter -> t -> unit
val pp : Format.formatter -> t -> unit
end
module S : sig
type t = M.t list
......@@ -392,7 +392,7 @@ module Tallying : sig
val elements : t -> M.t list
val fold : (M.t -> 'b -> 'b) -> M.t list -> 'b -> 'b
(*include Set.S with type elt = descr M.t*)
val print : Format.formatter -> t -> unit
val pp : Format.formatter -> t -> unit
end
type s = S.t
......
......@@ -91,22 +91,6 @@ and branch = {
}
module Print = struct
let print_to_string f x =
let b = Buffer.create 1024 in
let ppf = Format.formatter_of_buffer b in
f ppf x;
Format.pp_print_flush ppf ();
Buffer.contents b
let print_lst ?(sep=",") f ppf l =
let rec aux ppf = function
|[] -> Format.fprintf ppf "@."
|[h] -> Format.fprintf ppf "%a" f h
|h::t -> Format.fprintf ppf "%a%s%a" f h sep aux t
in
match l with
|[] -> Format.fprintf ppf ""
|_ -> Format.fprintf ppf "%a" aux l
let rec pp_const ppf cst =
match cst with
......@@ -122,44 +106,37 @@ module Print = struct
Types.Print.print e.exp_typ
pp_typed_aux e
and pp_typedsigma ppf =
let rec aux ppf s = Types.Tallying.CS.E.iter
(fun k v -> Format.fprintf ppf "(%a,%a)" Var.print k Types.Print.print v) s
in
function
| s :: rest -> Format.fprintf ppf "[%a,%a]" aux s pp_typedsigma rest
| [] -> ()
and pp_typed_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
| TVar(id, name) ->
Format.fprintf ppf "TVar(%s,%s)"
(string_of_int (Upool.int id))
(Encodings.Utf8.to_string name)
Format.fprintf ppf "TVar(%s,%s)"
(string_of_int (Upool.int id))
(Encodings.Utf8.to_string name)
| Var(id, name) ->
Format.fprintf ppf "Var(%s,%s)"
(string_of_int (Upool.int id))
(Encodings.Utf8.to_string name)
Format.fprintf ppf "Var(%s,%s)"
(string_of_int (Upool.int id))
(Encodings.Utf8.to_string name)
| ExtVar(_, (id, name), _) ->
Format.fprintf ppf "ExtVar(%s,%s)"
(string_of_int (Upool.int id))
(Encodings.Utf8.to_string name)
Format.fprintf ppf "ExtVar(%s,%s)"
(string_of_int (Upool.int id))
(Encodings.Utf8.to_string name)