Commit 42341383 authored by Pietro Abate's avatar Pietro Abate
Browse files

Add a new small testing tool to print various ASTs

parent 9c97ce5a
......@@ -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
......
<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)
......
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)
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 ();;
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; *)
]
)
;;
......
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
......
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