Commit 2b3cb297 authored by Julien Lopez's avatar Julien Lopez

Transfer printers from tests to code

parent d26512ad
......@@ -74,3 +74,80 @@ type code_item =
| LetDecl of expr * int
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
| Ext(_, i) -> Format.fprintf ppf "Ext(?, %d)" i
| External(_, i) -> Format.fprintf ppf "External(?, %d)" i
| Builtin(s) -> Format.fprintf ppf "Builtin(%s)" s
| Global(i) -> Format.fprintf ppf "Global(%d)" i
| Dummy -> Format.fprintf ppf "Dummy"
let pp_vloc_array ppf a =
print_lst pp_vloc ppf (Array.to_list a)
let pp_binding ppf (id, name) value =
Format.fprintf ppf "((%d,%s),%a)\n"
(Upool.int id)
(Encodings.Utf8.to_string name)
pp_vloc value
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
) ppf
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
|Identity -> Format.fprintf ppf "Id"
and pp_lambda 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
| PolyAbstraction (va, l, b, i, sigma) ->
Format.fprintf ppf "PolyAbstraction(%a,,%a,,%a)" pp_vloc_array va pp_lbranches b pp_lambda_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.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 "))"
| _ -> ()
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
let lambda_to_string = print_to_string pp_lambda
end
......@@ -75,3 +75,7 @@ type code_item =
type code = code_item list
module Print : sig
val lambda_to_string : Lambda.expr -> string
end
......@@ -297,17 +297,17 @@ let rec is_str = function
| Concat (_,_) as v -> eval_lazy_concat v; is_str v
| _ -> false
let rec pp_sigma ppf =
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
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
let rec pp_sigma ppf =
let pp_aux ppf =
print_lst (fun ppf (t1,t2) ->
Format.fprintf ppf "(%a -> %a)"
......@@ -322,6 +322,52 @@ let rec pp_sigma ppf =
|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" (Big_int.int_of_big_int i)
| Char(i) -> Format.fprintf ppf "Char()"
| 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\"" 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
let rec print ppf v =
if is_str v then
(Format.fprintf ppf "\"";
......
......@@ -34,6 +34,9 @@ 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
val print: Format.formatter -> t -> unit
val dump_xml: Format.formatter -> t -> unit
......
......@@ -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%!@." (Printer.typed_to_string texpr);
Format.printf "Computed Typed -> %s%!@." (Typed.Print.typed_to_string texpr);
let lambdaexpr = Compile.compile env texpr in
Printer.lambda_to_string lambdaexpr
Lambda.Print.lambda_to_string lambdaexpr
with
| Compute.Error -> exit 3
| Loc.Exc_located (loc, exn) ->
......@@ -88,9 +88,9 @@ 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" (Printer.lambda_to_string lambdaexpr);
Format.printf "Lambda : %s\n" (Lambda.Print.lambda_to_string lambdaexpr);
let evalexpr = Eval.expr lambdaexpr lsize in
let v = Printer.value_to_string evalexpr in
let v = Value.value_to_string evalexpr in
Format.printf "Eval : %s\n\n" v;
v
with
......
open Value
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 rec pp_const ppf cst =
match cst with
| Types.Integer(i) -> Format.fprintf ppf "Integer(%s)" (Intervals.V.to_string i)
| Types.Atom(a) -> Format.fprintf ppf "Atom(%s)" (Atoms.V.to_string a)
| Types.Char(c) -> Format.fprintf ppf "Char(%d)" (Chars.V.to_int c)
| Types.Pair(c1, c2) -> Format.fprintf ppf "(%a,%a)" pp_const c1 pp_const c2
| Types.String(_, _, s, _) ->
Format.fprintf ppf "\"%s\"" (Encodings.Utf8.to_string s)
| _ -> assert false
let rec pp_typed ppf e =
Format.fprintf ppf "{typ: %a; descr= %a}"
Types.Print.print e.Typed.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.Typed.exp_descr with
| Typed.Forget(e, _) -> Format.fprintf ppf "Forget(%a)" pp_typed e
| Typed.Check(_, e, _) -> Format.fprintf ppf "Check(%a)" pp_typed e
| Typed.TVar(id, name) ->
Format.fprintf ppf "TVar(%s,%s)"
(string_of_int (Upool.int id))
(Encodings.Utf8.to_string name)
| Typed.Var(id, name) ->
Format.fprintf ppf "Var(%s,%s)"
(string_of_int (Upool.int id))
(Encodings.Utf8.to_string name)
| Typed.ExtVar(_, (id, name), _) ->
Format.fprintf ppf "ExtVar(%s,%s)"
(string_of_int (Upool.int id))
(Encodings.Utf8.to_string name)
| Typed.Apply(e1, e2) ->
Format.fprintf ppf "(%a).(%a)" pp_typed e1 pp_typed e2
| Typed.Abstraction(abstr) ->
Format.fprintf ppf "Abstraction(%a)" pp_abst abstr
| Typed.Cst(cst) -> pp_const ppf cst
| Typed.Pair(e1, e2) ->
Format.fprintf ppf "(%a, %a)" pp_typed e1 pp_typed e2
| Typed.String(_, _, s, _) ->
Format.fprintf ppf "\"%s\"" (Encodings.Utf8.to_string s)
| Typed.Match(e, b) ->
Format.fprintf ppf "Match(%a,%a)" pp_typed e pp_branches b
| Typed.Subst(e, s) ->
Format.fprintf ppf "Subst(%a,[%a])" pp_typed e pp_typedsigma s
| Typed.Op(s, i, l) -> Format.fprintf ppf "(%s, %d, " s i; (print_lst pp_typed ppf l); Format.fprintf ppf ")"
| _ -> assert false
and pp_abst ppf abstr =
Format.fprintf ppf "%a,\niface:[%a],\nbody:[%a],typ:%a,fv:[%a]"
pp_fun_name abstr.Typed.fun_name
pp_iface abstr.Typed.fun_iface
pp_branches abstr.Typed.fun_body
Types.Print.print abstr.Typed.fun_typ
pp_fv abstr.Typed.fun_fv
and pp_fun_name ppf = function
|Some (id, name) ->
Format.fprintf ppf "name:(%s,%s)"
(string_of_int (Upool.int id))
(Encodings.Utf8.to_string name)
|None -> Format.fprintf ppf "name:<none>"
and 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
and pp_branches ppf brs =
Format.fprintf ppf "typ:%a, accept:%a, branches:%a"
Types.Print.print brs.Typed.br_typ
Types.Print.print brs.Typed.br_accept
pp_branch brs.Typed.br_branches
and pp_branch ppf brs =
let f ppf br =
Format.fprintf ppf
"\n{used:%b; ghost:%b; br_vars_poly:[%a];br_vars_empty:[%a];\npat:{%a};\nbody:{typ:%a, descr:%a}}"
br.Typed.br_used
br.Typed.br_ghost
Var.Set.print br.Typed.br_vars_poly
pp_fv br.Typed.br_vars_empty
pp_node br.Typed.br_pat
Types.Print.print br.Typed.br_body.Typed.exp_typ
pp_typed br.Typed.br_body
in
print_lst f ppf brs
and pp_node ppf node =
Format.fprintf ppf "id:%d; descr:[%a]; accept:[id:%d; descr:%a]; fv:[%a]"
node.Patterns.id
Patterns.print node.Patterns.descr
(Types.id node.Patterns.accept)
Types.Print.print (Types.descr node.Patterns.accept)
pp_fv node.Patterns.fv
(*
and pp_descr ppf (t, fv, d) =
Format.fprintf ppf "%a; [%a]; %a"
Types.Print.print t
pp_fv fv
pp_pattern d
and pp_pattern ppf = function
| Patterns.Constr(t) -> Format.fprintf ppf "Constr(%a)" Types.Print.print t
| Patterns.Cup(d1, d2) -> Format.fprintf ppf "Cup([%a], [%a])" pp_descr d1 pp_descr d2
| Patterns.Cap(d1, d2) -> Format.fprintf ppf "Cap([%a], [%a])" pp_descr d1 pp_descr d2
| Patterns.Times(n1, n2) -> Format.fprintf ppf "Times({%a}, {%a})" pp_node n1 pp_node n2
| Patterns.Xml(n1, n2) -> Format.fprintf ppf "Xml({%a}, {%a})" pp_node n1 pp_node n2
| Patterns.Record(l, n) -> Format.fprintf ppf "Record(%s, {%a})" (Ns.Label.string_of_tag l) pp_node n
| Patterns.Capture((id, name)) ->
Format.fprintf ppf "Capture(%d,%s)"
(Upool.int id)
(Encodings.Utf8.to_string name)
| Patterns.Constant((id, name), ct) -> Format.fprintf ppf "Constant((%d, %s), %a)"
(Upool.int id)
(Encodings.Utf8.to_string name)
pp_const ct
| Patterns.Dummy -> Format.fprintf ppf "Dummy"
*)
and pp_v ppf (id, name) =
Format.fprintf ppf "(%d,%s)" (Upool.int id) (Encodings.Utf8.to_string name)
and pp_fv ppf fv = print_lst pp_v ppf fv
let pp_vloc ppf = function
| Lambda.Local(i) -> Format.fprintf ppf "Local(%d)" i
| Lambda.Env(i) -> Format.fprintf ppf "Env(%d)" i
| Lambda.Ext(_, i) -> Format.fprintf ppf "Ext(?, %d)" i
| Lambda.External(_, i) -> Format.fprintf ppf "External(?, %d)" i
| Lambda.Builtin(s) -> Format.fprintf ppf "Builtin(%s)" s
| Lambda.Global(i) -> Format.fprintf ppf "Global(%d)" i
| Lambda.Dummy -> Format.fprintf ppf "Dummy"
let pp_vloc_array ppf a =
print_lst pp_vloc ppf (Array.to_list a)
let pp_binding ppf (id, name) value =
Format.fprintf ppf "((%d,%s),%a)\n"
(Upool.int id)
(Encodings.Utf8.to_string name)
pp_vloc value
let pp_env ppf env =
if Ident.Env.is_empty env then Format.fprintf ppf "<empty>\n"
else Ident.Env.iter (pp_binding ppf) env
let rec pp_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
) ppf
in
function
|Value.List ll -> Types.Tallying.CS.pp_sl ppf ll
|Value.Comp(s1,s2) -> Format.fprintf ppf "Comp(%a,%a)" pp_sigma s1 pp_sigma s2
|Value.Sel(x,iface,s) -> Format.fprintf ppf "Sel(%d,%a,%a)" x pp_aux iface pp_sigma s
|Value.Identity -> Format.fprintf ppf "Id"
|Value.Mono -> Format.fprintf ppf "Mono"
and pp_value ppf = function
| Value.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" (Big_int.int_of_big_int i)
| Char(i) -> Format.fprintf ppf "Char()"
| 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\"" s
| Concat(v1, v2) ->
Format.fprintf ppf "Concat(%a, %a)"
pp_value v1
pp_value v2
| Absent -> Format.fprintf ppf "Absent"
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
) ppf
in
function
|Lambda.List ll -> Types.Tallying.CS.pp_sl ppf ll
|Lambda.Comp(s1,s2) -> Format.fprintf ppf "Comp(%a,%a)" pp_lambda_sigma s1 pp_lambda_sigma s2
|Lambda.Sel(x,iface,s) -> Format.fprintf ppf "Sel(%a,%a,%a)" pp_vloc x pp_aux iface pp_lambda_sigma s
|Lambda.Identity -> Format.fprintf ppf "Id"
and pp_lambda ppf =
let open Lambda in 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
| PolyAbstraction (va, l, b, i, sigma) ->
Format.fprintf ppf "PolyAbstraction(%a,,%a,,%a)" pp_vloc_array va pp_lbranches b pp_lambda_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)" 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 "))"
| _ -> ()
and pp_lbranches ppf brs =
let open Lambda in
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
let typed_to_string = print_to_string pp_typed
let print_env = Format.printf "%a" pp_env
let print_value = Format.printf "%a" pp_value
let value_to_string = print_to_string pp_value
let lambda_to_string = print_to_string pp_lambda
val typed_to_string : Typed.texpr -> string
val print_env : Lambda.var_loc Ident.Env.t -> unit
val print_value : Value.t -> unit
val value_to_string : Value.t -> string
val lambda_to_string : Lambda.expr -> string
......@@ -56,36 +56,36 @@ let wrap f s =
let parse_cduce s =
let astexpr = Parser.expr (Stream.of_string s) in
let texpr = fst (Typer.type_expr BIN.env astexpr) in
Format.printf "Cduce Typed %s ====> \n %s\n%!@." s (Printer.typed_to_string texpr);
Format.printf "Cduce Typed %s ====> \n %s\n%!@." s (Typed.Print.typed_to_string texpr);
texpr
let parse_texpr s =
let expr = Parse.ExprParser.of_string_no_file s in
let env, texpr = Compute.to_typed expr in
Format.printf "Computed Typed %s ====> \n %s\n%!@." s (Printer.typed_to_string texpr);
Format.printf "Computed Typed %s ====> \n %s\n%!@." s (Typed.Print.typed_to_string texpr);
texpr
let parse_lexpr f s =
let texpr = wrap f s in
let lambdaexpr,lsize = Compile.compile_expr Compile.empty_toplevel texpr in
Format.printf "Lambda : %s\n" (Printer.lambda_to_string lambdaexpr);
Format.printf "Lambda : %s\n" (Lambda.Print.lambda_to_string lambdaexpr);
lambdaexpr, lsize
let parse_vexpr f s =
let lambdaexpr,lsize = parse_lexpr f s in
let evalexpr = Eval.expr lambdaexpr lsize in
Format.printf "Value : %s\n" (Printer.value_to_string evalexpr);
Format.printf "Value : %s\n" (Value.value_to_string evalexpr);
evalexpr
let run_test_typer msg expected totest _ =
let expected = wrap parse_texpr expected in
let totest = wrap parse_cduce totest in
assert_equal ~msg:msg ~printer:(fun x -> Printer.typed_to_string x) expected totest
assert_equal ~msg:msg ~printer:(fun x -> Typed.Print.typed_to_string x) expected totest
let run_test_compile msg expected totest _ =
let expected,_ = parse_lexpr parse_texpr expected in
let totest,_ = parse_lexpr parse_cduce totest in
assert_equal ~msg:msg ~printer:(fun x -> Printer.lambda_to_string x) expected totest
assert_equal ~msg:msg ~printer:(fun x -> Lambda.Print.lambda_to_string x) expected totest
(* (message, typed expr - expected, cduce expr) *)
let tests_typer_list = [
......
......@@ -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 -> %s%!@." str (Printer.typed_to_string texpr);
Format.printf "Computed Typed %s -> %s%!@." str (Typed.Print.typed_to_string texpr);
let lambdaexpr = Compile.compile env texpr in
Printer.lambda_to_string lambdaexpr
Lambda.Print.lambda_to_string lambdaexpr
with
| Compute.Error -> exit 3
| Loc.Exc_located (loc, exn) ->
......@@ -67,11 +67,11 @@ let run_test_eval 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 -> %s%!@." str (Printer.typed_to_string texpr);
Format.printf "Computed Typed %s -> %s%!@." str (Typed.Print.typed_to_string texpr);
let lambdaexpr,lsize = Compile.compile_expr env texpr in
Format.printf "Lambda : %s\n" (Printer.lambda_to_string lambdaexpr);
Format.printf "Lambda : %s\n" (Lambda.Print.lambda_to_string lambdaexpr);
let evalexpr = Eval.expr lambdaexpr lsize in
Printer.value_to_string evalexpr
Value.value_to_string evalexpr
with
| Compute.Error -> exit 3
| Loc.Exc_located (loc, exn) ->
......
......@@ -90,3 +90,134 @@ and branch = {
mutable br_body : texpr
}
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 rec pp_const ppf cst =
match cst with
| Types.Integer(i) -> Format.fprintf ppf "Integer(%s)" (Intervals.V.to_string i)
| Types.Atom(a) -> Format.fprintf ppf "Atom(%s)" (Atoms.V.to_string a)
| Types.Char(c) -> Format.fprintf ppf "Char(%d)" (Chars.V.to_int c)
| Types.Pair(c1, c2) -> Format.fprintf ppf "(%a,%a)" pp_const c1 pp_const c2
| Types.String(_, _, s, _) ->
Format.fprintf ppf "\"%s\"" (Encodings.Utf8.to_string s)
| _ -> assert false
let rec pp_typed ppf e =
Format.fprintf ppf "{typ: %a; descr= %a}"
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)
| Var(id, 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)
| Apply(e1, e2) ->
Format.fprintf ppf "(%a).(%a)" pp_typed e1 pp_typed 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