add test hierarchy

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 -> (

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 ;
 ]

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 ;

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 ;
   ]

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 ;

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 ;

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" [
+  run_test @@ test_suite "LIGO" [
-    (* Multifix_tests.main ; *)
     Integration_tests.main ;
     Compiler_tests.main ;
     Transpiler_tests.main ;

src/test/test_helpers.ml

@@ -1,6 +1,12 @@
 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 =
+  Test (
     Alcotest.test_case name `Quick @@ fun () ->
     let result =
       trace (fun () -> error (thunk "running test") (thunk name) ()) @@
@@ -10,6 +16,9 @@ let test name f =
     | 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
 

src/test/transpiler_tests.ml

@@ -1,12 +1,7 @@
 (* open Ligo_helpers.Trace
  * open Ligo.Mini_c
- * open Combinators
+ * open Combinators *)
- * open Test_helpers *)
+open Test_helpers
 
-(*
+let main = test_suite "Transpiler (from Ast_typed)" [
-  How should one test the transpiler?
-  I'm doing the dumb thing.
-*)
-
-let main = "Transpiler (from Ast_typed)", [
   ]

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 ;

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 =
+        trace_strong (corner_case ~loc:__LOC__ "tuple access pair") @@
-          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 @@
         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