main.ml

open OUnit2
open Camlp4.PreCast 

(* Typed -> Lamda *)
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
      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
  in
  fun _ -> assert_equal ~msg:msg ~printer:(fun x -> x) expected (aux totest)

let tests_poly_abstr = [
  "Test CDuce.lambda.const_abstr failed",
  "Abstraction(Dummy,,,,Sel(,(Int -> Int),{}))",
  "fun f x : Int : Int -> 2";

  "Test CDuce.lambda.poly.identity failed",
  "Abstraction(Dummy,,,,Sel(,([ Char* ] | Int -> [ Char* ] | Int),Comp({},{ { (`$A/
[ Char* ]) } ,{ (`$A/Int) } })))",
  "(fun f x : 'A{A/Int;A/String} : 'A{A/Int;A/String} -> x) {A/Int;A/String}";

  "Test CDuce.runtime.poly.tail failed",
  "Abstraction(Dummy,,,,Sel(,([ (`$A & Int | Char | Atom | (Any,Any) |
                             <(Any) (Any)>Any | Arrow)* ] -> [ (`$A & Int |
                                                               Char | 
                                                               Atom |
                                                               (Any,Any) |
                                                               <(Any) (Any)>Any |
                                                               Arrow)* ]),{}))",
  "fun tail x : ['A{}] : ['A{}] -> match x : ['A{}] with | (el : 'A{}) :: (rest : ['A{}]) -> rest";

  "Test CDuce.runtime.poly.pair failed", "",
  "fun pair x : ('A{} * 'B{}) : 'A{} -> match x : ('A{} * 'B{}) with | (x : 'A{}, y : 'B{}) -> x";

  "Test CDuce.runtime.poly.match_abstr failed", "",
  "(match (fun f x : 'A{} : 'A{} -> x) : ('A{} -> 'A{}) with | y : ('A{} -> 'A{}) -> y{A/Int}).3";



]

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 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_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
  [
    "abstr" >:: ( fun test_ctxt ->
      assert_equal ~msg:"Test CDuce.runtime.abstr.let_simple failed"
	~printer:(fun x -> x) "3"
	(run_test_eval "let x : Int = 3 in x : Int");
      assert_equal ~msg:"Test CDuce.runtime.abstr.let_medium failed"
	~printer:(fun x -> x) "2"
	(run_test_eval "let f : (Int -> Int) = (fun (Int -> Int) | x : Int -> x)
                        in (f.f.2) : Int");
      assert_equal ~msg:"Test CDuce.runtime.abstr.let_nested_simple failed"
	~printer:(fun x -> x) "3"
	(run_test_eval "let f : (Int -> Int) = (fun (Int -> Int) | x : Int -> x + 1)
                        in (let x : Int = f.2
                            in x : Int) : Int");
      assert_equal ~msg:"Test CDuce.runtime.abstr.let_nested_medium failed"
	~printer:(fun x -> x) "4"
	(run_test_eval "let f : (Int -> Int) = (fun (Int -> Int) | x : Int -> x + 1)
                        in (let x : Int = f.2
                            in f.x : Int) : Int");
      assert_equal ~msg:"Test CDuce.runtime.abstr.simple failed"
	~printer:(fun x -> x) "Abstraction((Int, Int),{})"
	(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_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_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_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_eval "((fun f x : Int y : Int : (Int*Int) -> x,y).2).3");
    );

    "misc" >:: ( fun test_ctxt ->
      assert_equal ~msg:"Test CDuce.runtime.misc.even failed"
	~printer:(fun x -> x)
	"Abstraction((Int, Bool) ,(Any \\ (Int), Any \\ (Int)),{})"
	(run_test_eval "fun ((Int -> Bool) & ((!Int) -> (!Int)))
                          | x : Int -> (match (x % 2) : Int with
                                          | 0 -> `true
                                          | 1 -> `false)
                          | x : (!Int) -> x");
      assert_equal ~msg:"Test CDuce.runtime.misc.even_applied1 failed"
	~printer:(fun x -> x)
	"Atom(false)"
	(run_test_eval "(fun ((Int -> Bool) & ((!Int) -> (!Int)))
                          | x : Int -> (match (x % 2) : Int with
                                          | 0 -> `true
                                          | 1 -> `false)
                          | x : (!Int) -> x).5");
      assert_equal ~msg:"Test CDuce.runtime.misc.even_applied2 failed"
	~printer:(fun x -> x)
	"Atom(true)"
	(run_test_eval "(fun ((Int -> Bool) & ((!Int) -> (!Int)))
                          | x : Int -> (match (x % 2) : Int with
                                          | 0 -> `true
                                          | 1 -> `false)
                          | x : (!Int) -> x).8");
      assert_equal ~msg:"Test CDuce.runtime.misc.even_applied3 failed"
	~printer:(fun x -> x)
	"(2, (3, Atom(nil), {}), {})"
	(run_test_eval "(fun ((Int -> Bool) & ((!Int) -> (!Int)))
                          | x : Int -> (match (x % 2) : Int with
                                          | 0 -> `true
                                          | 1 -> `false)
                          | x : (!Int) -> x).[2; 3]");
      assert_equal ~msg:"Test CDuce.runtime.misc.is_int failed"
	~printer:(fun x -> x)
	"Abstraction((Int, Bool) ,(Bool, Bool) ,(Any \\ (Int | Bool), Any \\ (Int | Bool)),{})"
	(run_test_eval "fun ((Int -> Bool) & (Bool -> Bool) & ((!(Int|Bool)) -> (!(Int|Bool))))
                          | x : Int -> `true
                          | x : Bool -> `false
                          | x : (!(Int|Bool)) -> x");
      assert_equal ~msg:"Test CDuce.runtime.misc.is_int_applied1 failed"
	~printer:(fun x -> x)
	"Atom(true)"
	(run_test_eval "(fun ((Int -> Bool) & (Bool -> Bool) & ((!(Int|Bool)) -> (!(Int|Bool))))
                           | x : Int -> `true
                           | x : Bool -> `false
                           | x : (!(Int|Bool)) -> x).2");
      assert_equal ~msg:"Test CDuce.runtime.misc.is_int_applied2 failed"
	~printer:(fun x -> x)
	"Atom(false)"
	(run_test_eval "(fun ((Int -> Bool) & (Bool -> Bool) & ((!(Int|Bool)) -> (!(Int|Bool))))
                           | x : Int -> `true
                           | x : Bool -> `false
                           | x : (!(Int|Bool)) -> x).`true");
      assert_equal ~msg:"Test CDuce.runtime.misc.is_int_applied3 failed"
	~printer:(fun x -> x)
	"(2, (3, Atom(nil), {}), {})"
	(run_test_eval "(fun ((Int -> Bool) & (Bool -> Bool) & ((!(Int|Bool)) -> (!(Int|Bool))))
                           | x : Int -> `true
                           | x : Bool -> `false
                           | x : (!(Int|Bool)) -> x).[2; 3]");
      assert_equal ~msg:"Test CDuce.runtime.misc.map failed"
	~printer:(fun x -> x)
	"Abstraction(((`$A & Int | Char | Atom | (Any,Any) | <(Any) (Any)>Any | Arrow) -> 
             (`$B & Int | Char | Atom | (Any,Any) | <(Any) (Any)>Any | 
             Arrow), [ (`$A & Int | Char | Atom | (Any,Any) |
                       <(Any) (Any)>Any | Arrow)* ] -> [ (`$B & Int | 
                                                         Char | Atom |
                                                         (Any,Any) |
                                                         <(Any) (Any)>Any |
                                                         Arrow)* ]),{})"
	(run_test_eval "fun map f : ('A{}->'B{}) x : ['A{}] : ['B{}] ->
                          match x : ['A{}] with
                            | (el : 'A{}) :: [] -> f.el
                            | (el : 'A{}) :: (rest : ['A{}]) -> ((f.el), ((map.f).rest))");
      assert_equal ~msg:"Test CDuce.runtime.misc.map_even_simple failed"
	~printer:(fun x -> x)
	"(\"hey\", Atom(false), {A/Int;A/Bool})"
	(run_test_eval "(fun map f : ('A{A/Int;A/Bool}->'B{A/Int;A/Bool}) x : ['A{A/Int;A/Bool}] : ['B{A/Int;A/Bool}] ->
                          match x : ['A{A/Int;A/Bool}] with
                            | (el : 'A{A/Int;A/Bool}) :: [] -> f.el
                            | (el : 'A{A/Int;A/Bool}) :: (rest : ['A{A/Int;A/Bool}]) -> ((f.el), ((map.f).rest))).(fun ((Int -> Bool) & ((!Int) -> (!Int)))
                          | x : Int -> (match (x % 2) : Int with
                                          | 0 -> `true
                                          | 1 -> `false)
                          | x : (!Int) -> x).[\"hey\"; 3]");
      assert_equal ~msg:"Test CDuce.runtime.misc.map_even_medium failed"
	~printer:(fun x -> x)
	"(\"hey\", Atom(false), Atom(true), {A/Int;A/Bool})"
	(run_test_eval "(fun map f : ('A{A/Int;A/Bool}->'B{A/Int;A/Bool}) x : ['A{A/Int;A/Bool}] : ['B{A/Int;A/Bool}] ->
                          match x : ['A{A/Int;A/Bool}] with
                            | (el : 'A{A/Int;A/Bool}) :: [] -> f.el
                            | (el : 'A{A/Int;A/Bool}) :: (rest : ['A{A/Int;A/Bool}]) -> ((f.el), ((map.f).rest))).(fun ((Int -> Bool) & ((!Int) -> (!Int)))
                          | x : Int -> (match (x % 2) : Int with
                                          | 0 -> `true
                                          | 1 -> `false)
                          | x : (!Int) -> x).[\"hey\"; 3; 2]");
      assert_equal ~msg:"Test CDuce.runtime.misc.map_is_int_simple failed"
	~printer:(fun x -> x)
	"(Atom(false), Atom(true), {A/Int;A/Bool})"
	(run_test_eval "(fun map f : ('A{A/Int;A/Bool}->'B{A/Int;A/Bool}) x : ['A{A/Int;A/Bool}] : ['B{A/Int;A/Bool}] ->
                          match x : ['A{A/Int;A/Bool}] with
                            | (el : 'A{A/Int;A/Bool}) :: [] -> f.el
                            | (el : 'A{A/Int;A/Bool}) :: (rest : ['A{A/Int;A/Bool}]) -> ((f.el), ((map.f).rest))).(fun ((Int -> Bool) & (Bool -> Bool) & ((!(Int|Bool)) -> (!(Int|Bool))))
                          | x : Int -> `true
                          | x : Bool -> `false
                          | x : (!(Int|Bool)) -> x).[`true; 3]");
      assert_equal ~msg:"Test CDuce.runtime.misc.map_is_int_medium failed"
	~printer:(fun x -> x)
	"(Atom(false), Atom(true), Atom(false), {A/Int;A/Bool})"
	(run_test_eval "(fun map f : ('A{A/Int;A/Bool}->'B{A/Int;A/Bool}) x : ['A{A/Int;A/Bool}] : ['B{A/Int;A/Bool}] ->
                          match x : ['A{A/Int;A/Bool}] with
                            | (el : 'A{A/Int;A/Bool}) :: [] -> f.el
                            | (el : 'A{A/Int;A/Bool}) :: (rest : ['A{A/Int;A/Bool}]) -> ((f.el), ((map.f).rest))).(fun ((Int -> Bool) & (Bool -> Bool) & ((!(Int|Bool)) -> (!(Int|Bool))))
                          | x : Int -> `true
                          | x : Bool -> `false
                          | x : (!(Int|Bool)) -> x).[`true; 3; `true]");
      assert_equal ~msg:"Test CDuce.runtime.misc.firsts failed"
	~printer:(fun x -> x)
	"Abstraction(((Int,Int), X1 -> X1 where X1 = (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_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_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_eval "((fun applier x : Int f : (Int->Int) : Int ->
                       f.x).2).(fun g x : Int : Int -> x)");
    );

    "arith" >:: ( fun test_ctxt ->
      assert_equal ~msg:"Test CDuce.runtime.arith.simple failed"
	~printer:(fun x -> x) "5"
	(run_test_eval "2+3");
      assert_equal ~msg:"Test CDuce.runtime.arith.complete failed"
	~printer:(fun x -> x) "1"
	(run_test_eval "2+5*7%2-8/4");
    );

    "match" >:: ( fun test_ctxt ->
      assert_equal ~msg:"Test CDuce.runtime.match.simple failed"
	~printer:(fun x -> x) "1"
	(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_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_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_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_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_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_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_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_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, Atom(nil), {}), {})"
	(run_test_eval "(fun tail x : [Int] : [Int] -> match x : [Int] with
                     | (el : Int) :: (rest : [Int]) -> rest).[1; 2; 5]");
      assert_equal ~msg:"Test CDuce.runtime.list.last failed"
	~printer:(fun x -> x) "7"
	(run_test_eval "(fun f x : [Int] : [Int] -> match x : [Int] with
                     | (el : Int) :: [] -> el
                     | (el : Int) :: (rest : [Int]) -> f.rest).[1; 2; 5; 4; 8; 7]");
      assert_equal ~msg:"Test CDuce.runtime.list.plusone failed"
	~printer:(fun x -> x) "(2, (3, (6, (5, (9, 8, {}), {}), {}), {}), {})"
	(run_test_eval "(fun f x : [Int] : [Int] -> match x : [Int] with
                     | (el : Int) :: [] -> el+1
                     | (el : Int) :: (rest : [Int]) -> ((el+1), (f.rest))).[1; 2; 5; 4; 8; 7]");
    );

    "union" >:: ( fun test_ctxt ->
      assert_equal ~msg:"Test CDuce.runtime.union.identity failed"
	~printer:(fun x -> x) "Abstraction(([ Char* ] | Int, [ Char* ] | Int),{})"
	(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_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_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_eval "(fun f x : (Int | String) : (Int | String) ->
                      match x : (Int | String) with
                        | x : Int -> 2
                        | x : String -> \"Piece of cake\").\"test\"");
    );

    "union_precise" >:: ( fun test_ctxt ->
      assert_equal ~msg:"Test CDuce.runtime.union_precise.identity failed"
	~printer:(fun x -> x) "Abstraction((Int, Int) ,([ Char* ], [ Char* ]),{})"
	(run_test_eval "fun ((Int -> Int) & (String -> String))
                          | x : (Int | String) -> x");
      assert_equal ~msg:"Test CDuce.runtime.union_precise.match failed"
	~printer:(fun x -> x) "Abstraction((Int, Int) ,([ Char* ], [ Char* ]),{})"
	(run_test_eval "fun ((Int -> Int) & (String -> String))
                          | x : Int -> 2
                          | x : String -> \"Piece of cake\"");
      assert_equal ~msg:"Test CDuce.runtime.union_precise.match_applied failed"
	~printer:(fun x -> x) "2"
	(run_test_eval "(fun ((Int -> Int) & (String -> String))
                           | x : Int -> 2
                           | x : String -> \"Piece of cake\").5");
      assert_equal ~msg:"Test CDuce.runtime.union_precise.match_applied2 failed"
	~printer:(fun x -> x) "\"Piece of cake\""
	(run_test_eval "(fun ((Int -> Int) & (String -> String))
                           | x : Int -> 2
                           | x : String -> \"Piece of cake\").\"test\"");
    );

    "poly" >:: ( fun test_ctxt ->
      assert_equal ~msg:"Test CDuce.runtime.poly.identity_pure 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_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_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_eval "((fun f x : 'A{A/Int;A/String} : 'A{A/Int;A/String} -> x)
                   {A/Int;A/String}).2");
      assert_equal ~msg:"Test CDuce.runtime.poly.identity_applied2 failed"
	~printer:(fun x -> x) "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_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, Atom(nil), {}), {}), {})"
	(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 (
    test_list
      [ tests_compile;
        tests_eval
      ]
  )
;;