Transfer printers from tests to code

compile/lambda.ml

@@ -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

compile/lambda.mli

@@ -75,3 +75,7 @@ type code_item =
 
 
 type code = code_item list
+
+module Print : sig
+  val lambda_to_string : Lambda.expr -> string
+end

runtime/value.ml

@@ -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 "\"";

runtime/value.mli

@@ -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
 

tests/lambda/src/lambdaTests.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%!@." (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

tests/lambda/src/printer.ml

-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

tests/lambda/src/printer.mli

-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

tests/lambda/src/typedTests.ml

@@ -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 = [

tests/lambda/src/valueTests.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 -> %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) ->

typing/typed.ml

@@ -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
+