Commit 1c455906 authored by Pietro Abate's avatar Pietro Abate
Browse files

Add infrastructure to test Compile.compile

parent d2de4b28
......@@ -66,23 +66,22 @@ let rec _to_typed env l expr =
exp_descr=Cst s }
and make_sigma s =
let rec _make_sigma s res = match s with
let rec aux acc = function
| (name, ptype) :: rest ->
_make_sigma rest ([`Var (Var.make_id name), type_of_ptype ptype] :: res)
| [] -> res
aux ([`Var (Var.make_id name), type_of_ptype ptype] :: acc) rest
| [] -> acc
in
_make_sigma s []
aux [] s
and type_of_sigma x s =
let rec _type_of_sigma x s res = match s with
| [] -> res
| (id, t2) :: rest ->
if id = x then _type_of_sigma x rest (cup res (type_of_ptype t2))
else _type_of_sigma x rest res
let rec aux x acc = function
| [] -> acc
| (id, t2) :: rest when id = x -> aux x (cup acc (type_of_ptype t2)) rest
| _ :: rest -> aux x acc rest
in
_type_of_sigma x s empty
aux x empty s
and type_of_ptype arg = match arg with
and type_of_ptype = function
| Type(t) -> type_of_string t
| PType(t, s) ->
if s = [] then var (`Var (Var.make_id t)) else type_of_sigma t s
......
open OUnit2
open Camlp4.PreCast
let run_test str =
try
let expr = Parse.ExprParser.of_string_no_file str in
let env, texpr = Compute.to_typed expr in
let evalexpr = Compile.compile_eval_expr env texpr in
Printer.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
(* Typed -> Lambda -> Value *)
let run_test_eval str =
try
let expr = Parse.ExprParser.of_string_no_file str in
let env, texpr = Compute.to_typed expr in
let evalexpr = Compile.compile_eval_expr env texpr in
Printer.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
let tests = "CDuce runtime tests" >:::
(* Typed -> Lamda *)
let run_test_compile str =
try
let expr = Parse.ExprParser.of_string_no_file str in
let env, texpr = Compute.to_typed expr in
let lambdaexpr = Compile.compile env texpr in
Printer.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
let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
[
"abstr" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test CDuce.runtime.abstr.simple failed"
~printer:(fun x -> x) "Abstraction((Int, Int),{})"
(run_test "fun f x : Int : Int -> 2");
(run_test_eval "fun f x : Int : Int -> 2");
assert_equal ~msg:"Test CDuce.runtime.abstr.medium failed"
~printer:(fun x -> x) "Abstraction((Int, [ Char* ] -> [ Int Char* ]),{})"
(run_test "fun f x : Int y : String : (Int*String) -> x,y");
(run_test_eval "fun f x : Int y : String : (Int*String) -> x,y");
);
"apply" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test CDuce.runtime.apply.simple failed"
~printer:(fun x -> x) "2"
(run_test "(fun f x : Int : Int -> x).2");
(run_test_eval "(fun f x : Int : Int -> x).2");
assert_equal ~msg:"Test CDuce.runtime.apply.simple_pair failed"
~printer:(fun x -> x) "(3, 2, {})"
(run_test "(fun f x : (Int*Int) : (Int*Int) -> x).(3,2)");
(run_test_eval "(fun f x : (Int*Int) : (Int*Int) -> x).(3,2)");
assert_equal ~msg:"Test CDuce.runtime.apply.medium failed"
~printer:(fun x -> x) "(2, 3, {})"
(run_test "((fun f x : Int y : Int : (Int*Int) -> x,y).2).3");
(run_test_eval "((fun f x : Int y : Int : (Int*Int) -> x,y).2).3");
);
"misc" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test CDuce.runtime.misc.firsts failed"
~printer:(fun x -> x) "Abstraction(((Int,Int), (Int,Int) -> (Int,Int)),{})"
(run_test "fun firsts x : (Int*Int) y : (Int*Int) : (Int*Int) ->
(run_test_eval "fun firsts x : (Int*Int) y : (Int*Int) : (Int*Int) ->
match x,y : ((Int*Int)*(Int*Int)) with
| (a : Int,_ : Int),(b : Int,_ : Int) -> a,b");
assert_equal ~msg:"Test CDuce.runtime.misc.firsts_applied failed"
~printer:(fun x -> x) "(5, 1, {})"
(run_test "((fun firsts x : (Int*Int) y : (Int*Int) : (Int*Int) ->
(run_test_eval "((fun firsts x : (Int*Int) y : (Int*Int) : (Int*Int) ->
match x,y : ((Int*Int)*(Int*Int)) with
| (a : Int,_ : Int),(b : Int,_ : Int) -> a,b)
.(5, 3)).(1, 4)");
assert_equal ~msg:"Test CDuce.runtime.misc.applier failed"
~printer:(fun x -> x) "Abstraction((Int, Int -> Int -> Int),{})"
(run_test "fun applier x : Int f : (Int->Int) : Int -> f.x");
(run_test_eval "fun applier x : Int f : (Int->Int) : Int -> f.x");
assert_equal ~msg:"Test CDuce.runtime.misc.applier_applied failed"
~printer:(fun x -> x) "2"
(run_test "((fun applier x : Int f : (Int->Int) : Int ->
(run_test_eval "((fun applier x : Int f : (Int->Int) : Int ->
f.x).2).(fun g x : Int : Int -> x)");
);
"match" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test CDuce.runtime.match.simple failed"
~printer:(fun x -> x) "1"
(run_test "match 1 : Int with | 1 -> 1 | \"true\" -> \"true\"");
(run_test_eval "match 1 : Int with | 1 -> 1 | \"true\" -> \"true\"");
assert_equal ~msg:"Test CDuce.runtime.match.unused_branches failed"
~printer:(fun x -> x) "1"
(run_test "match 1 : Int with
(run_test_eval "match 1 : Int with
| s : String -> s | b : Bool -> b | i : Int -> i");
assert_equal ~msg:"Test CDuce.runtime.match.simple_var failed"
~printer:(fun x -> x) "2"
(run_test "(fun f x : Int : Int ->
(run_test_eval "(fun f x : Int : Int ->
match x : Int with | y : Int -> x).2");
assert_equal ~msg:"Test CDuce.runtime.match.medium failed"
~printer:(fun x -> x) "2"
(run_test "(fun f x : Int : Int ->
(run_test_eval "(fun f x : Int : Int ->
match x : Int with | 1 -> 3 | x : Int -> x).2");
assert_equal ~msg:"Test CDuce.runtime.match.rec failed"
~printer:(fun x -> x) "3"
(run_test "(fun f x : Int : Int ->
(run_test_eval "(fun f x : Int : Int ->
match x : Int with | 1 -> 3 | x : Int -> f.1).2");
);
"string" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test CDuce.runtime.string.simple failed"
~printer:(fun x -> x) "\"The cake is a lie\""
(run_test "\"The cake is a lie\"");
(run_test_eval "\"The cake is a lie\"");
);
"list" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test CDuce.runtime.list.simple failed"
~printer:(fun x -> x) "1"
(run_test "match [1; 2] : [Int] with
(run_test_eval "match [1; 2] : [Int] with
| (el : Int) :: (rest : [Int]) -> el
| x : Int -> 3");
assert_equal ~msg:"Test CDuce.runtime.list.simple2 failed"
~printer:(fun x -> x) "3"
(run_test "match 2 : Int with
(run_test_eval "match 2 : Int with
| (el : Int) :: (rest : [Int]) -> el
| x : Int -> 3");
assert_equal ~msg:"Test CDuce.runtime.list.tail failed"
~printer:(fun x -> x) "Abstraction(([ Int* ], [ Int* ]),{})"
(run_test "fun tail x : [Int] : [Int] -> match x : [Int] with
(run_test_eval "fun tail x : [Int] : [Int] -> match x : [Int] with
| (el : Int) :: (rest : [Int]) -> rest");
assert_equal ~msg:"Test CDuce.runtime.list.tail.eval failed"
~printer:(fun x -> x) "(2, 5, {})"
(run_test "(fun tail x : [Int] : [Int] -> match x : [Int] with
(run_test_eval "(fun tail x : [Int] : [Int] -> match x : [Int] with
| (el : Int) :: (rest : [Int]) -> rest).[1; 2; 5]");
(* TODO: Fix this test, we need to define [] aka `nil *)
assert_equal ~msg:"Test CDuce.runtime.list.last failed"
~printer:(fun x -> x) "7"
(run_test "(fun f x : [Int] : [Int] -> match x : [Int] with
(run_test_eval "(fun f x : [Int] : [Int] -> match x : [Int] with
| (el : Int) :: (rest : [Int]) -> f.rest
| el : [Int] -> el).[1; 2; 5; 4; 8; 7]");
);
......@@ -119,22 +137,22 @@ let tests = "CDuce runtime tests" >:::
"union" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test CDuce.runtime.union.identity failed"
~printer:(fun x -> x) "Abstraction(([ Char* ] | Int, [ Char* ] | Int),{})"
(run_test "fun f x : (Int | String) : (Int | String) -> x");
(run_test_eval "fun f x : (Int | String) : (Int | String) -> x");
assert_equal ~msg:"Test CDuce.runtime.union.match failed"
~printer:(fun x -> x) "Abstraction(([ Char* ] | Int, [ Char* ] | Int),{})"
(run_test "fun f x : (Int | String) : (Int | String) ->
(run_test_eval "fun f x : (Int | String) : (Int | String) ->
match x : (Int | String) with
| x : Int -> 2
| x : String -> \"Piece of cake\"");
assert_equal ~msg:"Test CDuce.runtime.union.match_applied failed"
~printer:(fun x -> x) "2"
(run_test "(fun f x : (Int | String) : (Int | String) ->
(run_test_eval "(fun f x : (Int | String) : (Int | String) ->
match x : (Int | String) with
| x : Int -> 2
| x : String -> \"Piece of cake\").5");
assert_equal ~msg:"Test CDuce.runtime.union.match_applied2 failed"
~printer:(fun x -> x) "\"Piece of cake\""
(run_test "(fun f x : (Int | String) : (Int | String) ->
(run_test_eval "(fun f x : (Int | String) : (Int | String) ->
match x : (Int | String) with
| x : Int -> 2
| x : String -> \"Piece of cake\").\"test\"");
......@@ -145,33 +163,33 @@ let tests = "CDuce runtime tests" >:::
~printer:(fun x -> x)
"Abstraction((`$A & Int | Char | Atom | (Any,Any) | <(Any) (Any)>Any | \
Arrow, `$A & Int | Char | Atom | (Any,Any) | <(Any) (Any)>Any | Arrow),{})"
(run_test "fun f x : 'A{} : 'A{} -> x");
(run_test_eval "fun f x : 'A{} : 'A{} -> x");
assert_equal ~msg:"Test CDuce.runtime.poly.identity failed"
~printer:(fun x -> x)
"Abstraction(([ Char* ] | Int, [ Char* ] | Int),{})"
(run_test "(fun f x : 'A{A/Int;A/String} : 'A{A/Int;A/String} -> x)
(run_test_eval "(fun f x : 'A{A/Int;A/String} : 'A{A/Int;A/String} -> x)
{A/Int;A/String}");
assert_equal ~msg:"Test CDuce.runtime.poly.identity_applied failed"
~printer:(fun x -> x) "2"
(run_test "((fun f x : 'A{A/Int;A/String} : 'A{A/Int;A/String} -> x)
(run_test_eval "((fun f x : 'A{A/Int;A/String} : 'A{A/Int;A/String} -> x)
{A/Int;A/String}).2");
(* TODO: Should have error (?) *)
assert_equal ~msg:"Test CDuce.runtime.poly.identity_applied2 failed"
~printer:(fun x -> x) "2"
(run_test "((fun f x : 'A{A/String} : 'A{A/String} -> x){A/String}).2");
(run_test_eval "((fun f x : 'A{A/String} : 'A{A/String} -> x){A/String}).2");
assert_equal ~msg:"Test CDuce.runtime.poly.tail failed"
~printer:(fun x -> x)
"Abstraction(([ (`$A & Int | Char | Atom | (Any,Any) | <(Any) (Any)>Any \
| Arrow)* ], [ (`$A & Int | Char | Atom | (Any,Any) | <(Any) (Any)>Any | \
Arrow)* ]),{})"
(run_test "fun tail x : ['A{}] : ['A{}] -> match x : ['A{}] with
(run_test_eval "fun tail x : ['A{}] : ['A{}] -> match x : ['A{}] with
| (el : 'A{}) :: (rest : ['A{}]) -> rest");
assert_equal ~msg:"Test CDuce.runtime.poly.tail_applied failed"
~printer:(fun x -> x) "(7, (8, 5, {}), {})"
(run_test "(fun tail x : ['A{}] : ['A{}] -> match x : ['A{}] with
(run_test_eval "(fun tail x : ['A{}] : ['A{}] -> match x : ['A{}] with
| (el : 'A{}) :: (rest : ['A{}]) -> rest).[3; 7; 8; 5]");
);
]
let _ = run_test_tt_main tests
let _ = run_test_tt_main tests_eval
......@@ -191,3 +191,4 @@ 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 t = ""
......@@ -2,3 +2,4 @@ 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
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