diff --git a/src/ast_typed/misc.ml b/src/ast_typed/misc.ml index 733f576c7..c1393fe53 100644 --- a/src/ast_typed/misc.ml +++ b/src/ast_typed/misc.ml @@ -204,7 +204,6 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m @@ Assert.assert_list_same_size sa' sb' in trace (simple_error "sum type") @@ bind_list_iter aux (List.combine sa' sb') - ) | T_sum _, _ -> fail @@ different_kinds a b | T_record ra, T_record rb -> ( diff --git a/src/test/bin_tests.ml b/src/test/bin_tests.ml index cef36ab94..d54239a64 100644 --- a/src/test/bin_tests.ml +++ b/src/test/bin_tests.ml @@ -8,6 +8,6 @@ let compile_contract_basic () : unit result = in ok () -let main = "Bin", [ +let main = test_suite "Bin" [ test "compile contract basic" compile_contract_basic ; ] diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index a0e176a29..2f16212d4 100644 --- a/src/test/coase_tests.ml +++ b/src/test/coase_tests.ml @@ -229,7 +229,7 @@ let sell () = ok () -let main = "Coase (End to End)", [ +let main = test_suite "Coase (End to End)" [ test "buy" buy ; test "dispatch buy" dispatch_buy ; test "transfer" transfer ; diff --git a/src/test/compiler_tests.ml b/src/test/compiler_tests.ml index 2424d0cd4..af26e74d4 100644 --- a/src/test/compiler_tests.ml +++ b/src/test/compiler_tests.ml @@ -28,7 +28,7 @@ let multiple_vars () : unit result = let%bind _ = Assert.assert_equal_int ~msg:__LOC__ 42 result in ok () -let main = "Compiler (from Mini_C)", [ +let main = test_suite "Compiler (from Mini_C)" [ test "identity" identity ; test "multiple_vars" multiple_vars ; ] diff --git a/src/test/heap_tests.ml b/src/test/heap_tests.ml index f21b9df75..a7be1fbb4 100644 --- a/src/test/heap_tests.ml +++ b/src/test/heap_tests.ml @@ -118,7 +118,7 @@ let pop () : unit result = simple_fail "display" (* ok () *) -let main = "Heap (End to End)", [ +let main = test_suite "Heap (End to End)" [ test "is_empty" is_empty ; test "get_top" get_top ; test "pop_switch" pop_switch ; diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 6c8e78eff..e303ac29f 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -456,7 +456,7 @@ let guess_the_hash_mligo () : unit result = let make_expected = fun n -> e_pair (e_typed_list [] t_operation) (e_int (42 + n)) in expect_eq_n program "main" make_input make_expected -let main = "Integration (End to End)", [ +let main = test_suite "Integration (End to End)" [ test "type alias" type_alias ; test "function" function_ ; test "assign" assign ; diff --git a/src/test/test.ml b/src/test/test.ml index ad5178462..e07209be2 100644 --- a/src/test/test.ml +++ b/src/test/test.ml @@ -1,9 +1,50 @@ (* -*- compile-command: "cd .. ; dune runtest" -*- *) +open Test_helpers + +let rec test_height : test -> int = fun t -> + match t with + | Test _ -> 1 + | Test_suite (_ , lst) -> (List.fold_left max 1 @@ List.map test_height lst) + 1 + +let extract_test : test -> test_case = fun t -> + match t with + | Test tc -> tc + | _ -> assert false + +let extract_param : test -> (string * (string * test_case list) list) = + let extract_element = extract_test in + let extract_group : test -> (string * test_case list) = fun t -> + match t with + | Test tc -> ("isolated" , [ tc ]) + | Test_suite (name , lst) -> (name , List.map extract_element lst) in + fun t -> + match t with + | Test tc -> ("" , [ ("isolated" , [ tc ] ) ]) + | Test_suite (name , lst) -> (name , List.map extract_group lst) + +let x : _ -> (unit Alcotest.test) = fun x -> x + +(* + Alcotest.run parameters: + string * (string * f list) list +*) + +let rec run_test ?(prefix = "") : test -> unit = fun t -> + match t with + | Test case -> Alcotest.run "isolated test" [ ("" , [ case ]) ] + | Test_suite (name , lst) -> ( + if (test_height t <= 3) then ( + let (name , tests) = extract_param t in + Alcotest.run (prefix ^ name) tests + ) else ( + List.iter (run_test ~prefix:(prefix ^ name ^ "_")) lst + ) + ) + let () = (* Printexc.record_backtrace true ; *) - Alcotest.run "LIGO" [ - (* Multifix_tests.main ; *) + run_test @@ test_suite "LIGO" [ Integration_tests.main ; Compiler_tests.main ; Transpiler_tests.main ; diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index 4719ec2ee..03ae9e73d 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -1,16 +1,25 @@ open! Trace +type test_case = unit Alcotest.test_case +type test = + | Test_suite of (string * test list) + | Test of test_case + let test name f = - Alcotest.test_case name `Quick @@ fun () -> - let result = - trace (fun () -> error (thunk "running test") (thunk name) ()) @@ + Test ( + Alcotest.test_case name `Quick @@ fun () -> + let result = + trace (fun () -> error (thunk "running test") (thunk name) ()) @@ f () in - match result with - | Ok ((), annotations) -> ignore annotations; () - | Error err -> + match result with + | Ok ((), annotations) -> ignore annotations; () + | Error err -> Format.printf "Errors : {\n%a}\n%!" error_pp (err ()) ; raise Alcotest.Test_error + ) +let test_suite name lst = Test_suite (name , lst) + open Ast_simplified.Combinators let expect ?options program entry_point input expecter = diff --git a/src/test/transpiler_tests.ml b/src/test/transpiler_tests.ml index e0e2abf3b..8b05fe665 100644 --- a/src/test/transpiler_tests.ml +++ b/src/test/transpiler_tests.ml @@ -1,12 +1,7 @@ (* open Ligo_helpers.Trace * open Ligo.Mini_c - * open Combinators - * open Test_helpers *) + * open Combinators *) +open Test_helpers -(* - How should one test the transpiler? - I'm doing the dumb thing. -*) - -let main = "Transpiler (from Ast_typed)", [ +let main = test_suite "Transpiler (from Ast_typed)" [ ] diff --git a/src/test/typer_tests.ml b/src/test/typer_tests.ml index 88bcd1a14..89500c2a7 100644 --- a/src/test/typer_tests.ml +++ b/src/test/typer_tests.ml @@ -65,7 +65,7 @@ end (* TODO: deep types (e.g. record of record) TODO: negative tests (expected type error) *) -let main = "Typer (from simplified AST)", [ +let main = test_suite "Typer (from simplified AST)" [ test "int" int ; test "unit" TestExpressions.unit ; test "int2" TestExpressions.int ; diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 7523e08dd..7da6985e9 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -86,7 +86,6 @@ end open Errors let rec translate_type (t:AST.type_value) : type_value result = - trace (simple_info "") @@ match t.type_value' with | T_constant ("bool", []) -> ok (T_base Base_bool) | T_constant ("int", []) -> ok (T_base Base_int) @@ -143,23 +142,13 @@ let tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [ let node_tv = Append_tree.of_list @@ List.mapi (fun i a -> (i, a)) tys in let%bind path = let aux (i , _) = i = ind in - trace_option (simple_error "no leaf with given index") @@ + trace_option (corner_case ~loc:__LOC__ "tuple access leaf") @@ Append_tree.exists_path aux node_tv in let lr_path = List.map (fun b -> if b then `Right else `Left) path in let%bind (_ , lst) = let aux = fun (ty' , acc) cur -> let%bind (a , b) = - let error = - let title () = "expected a pair" in - let content () = Format.asprintf "Big: %a.\tGot: %a\tFull path: %a\tSmall path: %a" - Mini_c.PP.type_ ty - Mini_c.PP.type_ ty' - PP_helpers.(list_sep bool (const ".")) path - PP_helpers.(list_sep lr (const ".")) (List.map snd acc) - in - error title content - in - trace_strong error @@ + trace_strong (corner_case ~loc:__LOC__ "tuple access pair") @@ Mini_c.get_t_pair ty' in match cur with | `Left -> ok (a , acc @ [(a , `Left)]) @@ -173,12 +162,14 @@ let record_access_to_lr : type_value -> type_value AST.type_name_map -> string - let node_tv = Append_tree.of_list tys in let%bind path = let aux (i , _) = i = ind in - trace_option (simple_error "no leaf with given index") @@ + trace_option (corner_case ~loc:__LOC__ "record access leaf") @@ Append_tree.exists_path aux node_tv in let lr_path = List.map (fun b -> if b then `Right else `Left) path in let%bind (_ , lst) = let aux = fun (ty , acc) cur -> - let%bind (a , b) = Mini_c.get_t_pair ty in + let%bind (a , b) = + trace_strong (corner_case ~loc:__LOC__ "recard access pair") @@ + Mini_c.get_t_pair ty in match cur with | `Left -> ok (a , acc @ [(a , `Left)]) | `Right -> ok (b , acc @ [(b , `Right)] ) in @@ -213,7 +204,6 @@ and transpile_small_environment : AST.small_environment -> Environment.t result ok @@ Environment.add (name , tv') prec in let%bind result = - trace (simple_error "transpiling small environment") @@ bind_fold_right_list aux Environment.empty x' in ok result @@ -246,7 +236,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | E_literal l -> return @@ E_literal (translate_literal l) | E_variable name -> ( let%bind ele = - trace_option (simple_error "name not in environment") @@ + trace_option (corner_case ~loc:__LOC__ "name not in environment") @@ AST.Environment.get_opt name ae.environment in let%bind tv = transpile_environment_element_type ele in return ~tv @@ E_variable name