Add a new small testing tool to print various ASTs

tests/lambda/Makefile

@@ -22,8 +22,8 @@ INEXTFILES  = misc/custom.ml misc/encodings.ml misc/upool.ml misc/ns.ml\
 EXTFILES  = $(INEXTFILES:%=$(ROOTDIR)/%)
 
 RM		?= rm -f
-OUT		?= valueTests.native lambdaTests.native typedTests.native
-OUTDEBUG	?= valueTests.native lambdaTests.byte typedTests.byte
+OUT		?= valueTests.native lambdaTests.native typedTests.native tests.native
+OUTDEBUG	?= valueTests.native lambdaTests.byte typedTests.byte tests.byte
 
 .PHONY: clean _import tests
 

tests/lambda/_tags

 <src>: include
 <src/parse*>: pp(camlp4orf.opt), package(camlp4.lib)
+<src/testlib*>: pp(camlp4orf.opt), package(camlp4.lib)
 <src/compute*>: pp(camlp4orf.opt), package(camlp4.lib, unix, netsys, str)
 <src/*Tests*>: pp(camlp4orf.opt), package(camlp4.lib, unix, netsys, str, oUnit, pcre, ulex, num, netstring)
+<src/tests*>: pp(camlp4orf.opt), package(camlp4.lib, unix, netsys, str, oUnit, pcre, ulex, num, netstring)
 
 <src/externals>: include
 <src/externals/schema_*>: package(pcre, netcgi2)

tests/lambda/src/testlib.ml

+open Camlp4.PreCast
+
+module BIN = struct
+  open Builtin_defs
+
+  (* Types *)
+
+  let stringn = Types.cons string
+  let namespaces =
+    Sequence.star (Types.times stringn stringn)
+
+  let types =
+    [
+      "Empty",   Types.empty;
+      "Any",     any;
+      "Int",     int;
+      "Char",    Types.char Chars.any;
+      "Byte",    char_latin1;
+      "Atom",    atom;
+      "Pair",    Types.Product.any;
+      "Arrow",   Types.Arrow.any;
+      "Record",  Types.Record.any;
+      "String",  string;
+      "Latin1",  string_latin1;
+      "Bool",    bool;
+      "Float",   float;
+      "AnyXml",  any_xml;
+      "Namespaces", namespaces;
+      "Caml_int", caml_int;
+    ]
+
+  let env =
+    List.fold_left
+      (fun accu (n,t) ->
+         let n = (Ns.empty, Ident.U.mk n) in
+         Types.Print.register_global "" n t;
+         Typer.enter_type (Ident.ident n) t accu
+      )
+      Typer.empty_env
+      types
+end
+
+let wrap f s =
+  try f s
+  with
+    | Compute.Error -> exit 3
+    | Loc.Exc_located (loc, exn) ->
+      let l = Loc.start_line loc in
+      let cbegin = Loc.start_off loc - Loc.start_bol loc in
+      let cend = Loc.stop_off loc - Loc.start_bol loc in
+      Printf.eprintf "File %s, line %d, characters %d-%d:\n" (Loc.file_name loc) l
+        cbegin cend; raise exn
+    | e -> Printf.eprintf "Runtime error.\n"; raise e
+
+(* Cduce program -> Typed *)
+let parse_cduce ?(verbose=false) s =
+  let astexpr = Parser.expr (Stream.of_string s) in
+  let texpr = fst (Typer.type_expr BIN.env astexpr) in
+  if verbose then
+    Format.printf "Cduce Typed %s ====> \n %s\n%!@." s (Typed.Print.typed_to_string texpr);
+  texpr
+
+(* Typed AST -> Typed *)
+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);
+  texpr
+
+(* --> Lambda *)
+let parse_lexpr ?(verbose=false) texpr =
+  let lambdaexpr,lsize = Compile.compile_expr Compile.empty_toplevel texpr in
+  if verbose then 
+    Format.printf "Lambda : %s\n" (Lambda.Print.lambda_to_string lambdaexpr);
+  lambdaexpr, lsize
+
+(* --> Value *)
+let parse_vexpr ?(verbose=false) (lambdaexpr,lsize) =
+  let evalexpr = Eval.expr lambdaexpr lsize in
+  if verbose then 
+    Format.printf "Value : %s\n" (Value.value_to_string evalexpr);
+  evalexpr
+
+(* Cduce program -> Lambda *)
+let parse_cduce_lexpr ?(verbose=false) s = 
+  let texpr = wrap (parse_cduce ~verbose) s in
+  parse_lexpr ~verbose:true texpr
+
+(* Cduce program -> Value *)
+let parse_cduce_vexpr ?(verbose=false) s = 
+  let texpr = wrap (parse_cduce ~verbose) s in
+  let lambdaexpr, lsize = parse_lexpr ~verbose texpr in
+  parse_vexpr ~verbose:true (lambdaexpr,lsize)
+
+(* Typed AST -> Lambda *)
+let parse_texpr_lexpr ?(verbose=false) s =
+  let texpr = wrap (parse_texpr ~verbose) s in
+  parse_lexpr ~verbose:true texpr
+
+(* Typed AST -> Value *)
+let parse_texpr_vexpr ?(verbose=false) s =
+  let texpr = wrap (parse_texpr ~verbose) s in
+  let lambdaexpr, lsize = parse_lexpr ~verbose texpr in
+  parse_vexpr ~verbose:true (lambdaexpr,lsize)

tests/lambda/src/tests.ml

+
+let verbose = ref false
+let typed = ref false
+let lambda = ref false
+let value = ref false
+let program = ref ""
+
+let main () = 
+  let speclist = [
+    ("-v", Arg.Set verbose, "Enables verbose mode (print all itermediate ASTs)");
+    ("--lambda", Arg.Set lambda, "Print Lambda AST");
+    ("--value", Arg.Set value, "Print Value AST");
+  ]
+  in 
+  let usage_msg = "Print various cduce ASTs fragments (default typed)" in
+  Arg.parse speclist (fun s -> program := s) usage_msg;
+  let verbose = !verbose in
+  if not(!lambda || !value) then ignore(Testlib.parse_cduce ~verbose:true !program);
+  if !lambda then ignore (Testlib.parse_cduce_lexpr ~verbose !program);
+  if !value then ignore (Testlib.parse_cduce_vexpr ~verbose !program)
+;;
+
+main ();;

tests/lambda/src/typedTests.ml

 open OUnit2
-open Camlp4.PreCast 
-
-module BIN = struct
-  open Builtin_defs
-
-  (* Types *)
-
-  let stringn = Types.cons string
-  let namespaces =
-    Sequence.star (Types.times stringn stringn)
-
-  let types =
-    [
-      "Empty",   Types.empty;
-      "Any",     any;
-      "Int",     int;
-      "Char",    Types.char Chars.any;
-      "Byte",    char_latin1;
-      "Atom",    atom;
-      "Pair",    Types.Product.any;
-      "Arrow",   Types.Arrow.any;
-      "Record",  Types.Record.any;
-      "String",  string;
-      "Latin1",  string_latin1;
-      "Bool",    bool;
-      "Float",   float;
-      "AnyXml",  any_xml;
-      "Namespaces", namespaces;
-      "Caml_int", caml_int;
-    ]
-
-  let env =
-    List.fold_left
-      (fun accu (n,t) ->
-         let n = (Ns.empty, Ident.U.mk n) in
-         Types.Print.register_global "" n t;
-         Typer.enter_type (Ident.ident n) t accu
-      )
-      Typer.empty_env
-      types
-end
-
-let wrap f s =
-  try f s
-  with
-    | Compute.Error -> exit 3
-    | Loc.Exc_located (loc, exn) ->
-      let l = Loc.start_line loc in
-      let cbegin = Loc.start_off loc - Loc.start_bol loc in
-      let cend = Loc.stop_off loc - Loc.start_bol loc in
-      Printf.eprintf "File %s, line %d, characters %d-%d:\n" (Loc.file_name loc) l
-        cbegin cend; raise exn
-    | e -> Printf.eprintf "Runtime error.\n"; raise e
-
-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 (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 (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" (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" (Value.value_to_string evalexpr);
-  evalexpr
+open Testlib
 
 let run_test_typer msg expected totest _ =
   let expected = wrap parse_texpr expected in
@@ -83,8 +7,8 @@ let run_test_typer msg 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
+  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
 
 (* (message, typed expr - expected, cduce expr) *)
@@ -109,10 +33,15 @@ let tests_typer_list = [
   "Test CDuce.typed.fun.partial 1",
   "fun f x : 'A : 'A -> 2",
   "fun f ( `$A -> `$A -> `$A) x -> fun g -> g x";
-*)
+
   "Test CDuce.typed.fun.partial 2",
   "fun f x : 'A : 'A -> 2",
   "fun f ( g : `$A -> `$B ) ( x : `$A) : `$B  = g x"; 
+*)
+
+  "Test CDuce.typed.fun.partial 2",
+  "fun f x : 'A : 'A -> 2",
+  "let id ( y : `$A ) : `$B = y in id"; 
 
 
 ]
@@ -133,7 +62,7 @@ let _ =
     test_list
       [ 
         tests_typer;
-        tests_compile;
+        (* tests_compile; *)
       ]
   )
 ;;

tests/lambda/src/valueTests.ml

 open OUnit2
-open Camlp4.PreCast 
+open Testlib
+
 
 (* Typed -> Lambda *)
-let run_test_compile msg expected totest =
-  let aux str =
-    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 (Typed.Print.typed_to_string texpr);
-      let lambdaexpr = Compile.compile env texpr in
-      Lambda.Print.lambda_to_string lambdaexpr
-    with
-      | Compute.Error -> exit 3
-      | Loc.Exc_located (loc, exn) ->
-	let l = Loc.start_line loc in
-	let cbegin = Loc.start_off loc - Loc.start_bol loc in
-	let cend = Loc.stop_off loc - Loc.start_bol loc in
-	Printf.eprintf "File %s, line %d, characters %d-%d:\n" (Loc.file_name loc) l
-	  cbegin cend; raise exn
-      | e -> Printf.eprintf "Runtime error.\n"; raise e
-  in
-  fun _ -> assert_equal ~msg:msg ~printer:(fun x -> x) expected (aux 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
 
 let tests_poly_abstr = [
   "Test CDuce.lambda.const_abstr failed",
   "",
   "fun f x : 'A : 'A -> 2";
 
+(*
   "Test CDuce.lambda.let",
   "",
   "let x : Int = 3 in x : Int";
@@ -39,7 +26,6 @@ let tests_poly_abstr = [
   "",
   "fun applier x : 'A f : ('A -> 'A) : 'A -> f.x";
 
-(*
   "Test CDuce.lambda.apply",
   "",
   "(fun f x : Int : Int -> x).2";
@@ -62,27 +48,10 @@ let tests_compile = "CDuce compile tests (Typed -> Lambda )" >:::
   List.map (fun (m,e,f) -> f >:: run_test_compile m e f) tests_poly_abstr
 
 (* Typed -> Lambda -> Value *)
-let run_test_eval msg expected totest =
-  let aux str =
-    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 (Typed.Print.typed_to_string texpr);
-      let lambdaexpr,lsize = Compile.compile_expr env texpr in
-      Format.printf "Lambda : %s\n" (Lambda.Print.lambda_to_string lambdaexpr);
-      let evalexpr = Eval.expr lambdaexpr lsize in
-      Value.value_to_string evalexpr
-    with
-      | Compute.Error -> exit 3
-      | Loc.Exc_located (loc, exn) ->
-	let l = Loc.start_line loc in
-	let cbegin = Loc.start_off loc - Loc.start_bol loc in
-	let cend = Loc.stop_off loc - Loc.start_bol loc in
-	Printf.eprintf "File %s, line %d, characters %d-%d:\n" (Loc.file_name loc) l
-	  cbegin cend; raise exn
-      | e -> Printf.eprintf "Runtime error.\n"; raise e
-  in
-  fun _ -> assert_equal ~msg:msg ~printer:(fun x -> x) expected (aux totest)
+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 -> Value.value_to_string x) expected 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