Testsuite: fix error handling

test/lib/test.ml

@@ -31,6 +31,8 @@ let output name res =
   match res with
   | Passed ->
       Printf.fprintf out "Test '%s' ... passed\n" name
+  | Failed { Assertion.expected_value = "" ; actual_value = ""  ; message } ->
+      Printf.fprintf out "Test '%s' ... failed\n  %s \n" name message
   | Failed { Assertion.expected_value ; actual_value ; message = "" } ->
       if expected_value <> actual_value then
         Printf.fprintf out
@@ -111,8 +113,18 @@ let run prefix tests =
                   remove_dir base_dir
               in
               try
-                Lwt_main.run (f base_dir) ;
+                match Lwt_main.run (f base_dir) with
-                finalise ()
+                | Ok () -> finalise ()
+                | Error err ->
+                    finalise () ;
+                    Format.kasprintf
+                      (fun message ->
+                         raise @@
+                         Kaputt.Assertion.Failed
+                           { expected_value = "" ;
+                             actual_value = "" ;
+                             message })
+                      "%a" Error_monad.pp_print_error err
               with exn ->
                 finalise () ;
                 raise exn))

test/lib/test.mli

@@ -7,4 +7,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-val run : string -> (string * (string -> unit Lwt.t)) list -> unit
+open Error_monad
+
+val run : string -> (string * (string -> unit tzresult Lwt.t)) list -> unit

test/test_basic.ml

@@ -206,8 +206,7 @@ let main () =
   @@ transfer ~src:bar ~target:foo 1000_00L >>=? fun () ->
   mine bootstrap
 
-let tests =
+let tests = [ "main", fun _ -> main () ]
-  [ "main", (fun _ -> main () >>= fun _ -> Lwt.return_unit) ]
 
 let () =
   Test.run "basic." tests

test/test_context.ml

@@ -92,7 +92,8 @@ let wrap_context_init f base_dir =
   create_block2 idx >>= fun () ->
   create_block3a idx >>= fun () ->
   create_block3b idx >>= fun () ->
-  f idx
+  f idx >>= fun result ->
+  Error_monad.return result
 
 (** Simple test *)
 

test/test_data_encoding.ml

@@ -1,6 +1,7 @@
 open Data_encoding
 open Context
 open Hash
+open Error_monad
 
 let (>>=) = Lwt.bind
 let (>|=) = Lwt.(>|=)
@@ -305,6 +306,10 @@ let test_json_input testdir =
         Lwt.return_unit
   end
 
+let wrap_test f base_dir =
+  f base_dir >>= fun result ->
+  return result
+
 let tests = [
   "simple", test_simple_values ;
   "json", test_json ;
@@ -315,4 +320,4 @@ let tests = [
 ]
 
 let () =
-  Test.run "data_encoding." tests
+  Test.run "data_encoding." (List.map (fun (s, f) -> s, wrap_test f) tests)

test/test_state.ml

@@ -215,10 +215,7 @@ let wrap_state_init f base_dir =
     build_example_tree net >>= fun (block, vblock, operation) ->
     f { state ; net ; block ; vblock ; operation ; init } >>=? fun s ->
     return ()
-  end >>= function
+  end
-  | Ok () -> Lwt.return_unit
-  | Error err ->
-      Lwt.return (Error_monad.pp_print_error Format.err_formatter err)
 
 let test_init (s: state) =
   return ()

test/test_store.ml

@@ -39,7 +39,9 @@ let genesis = {
 let wrap_store_init f base_dir =
   let root = base_dir // "store" in
   Store.init root >>= function
-  | Ok store -> f store
+  | Ok store ->
+      f store >>= fun () ->
+      return ()
   | Error err ->
       Format.kasprintf Pervasives.failwith
         "@[Cannot initialize store:@ %a@]" pp_print_error err
@@ -47,7 +49,9 @@ let wrap_store_init f base_dir =
 let wrap_raw_store_init f base_dir =
   let root = base_dir // "store" in
   Raw_store.init root >>= function
-  | Ok store -> f store
+  | Ok store ->
+      f store >>= fun () ->
+      return ()
   | Error err ->
       Format.kasprintf Pervasives.failwith
         "@[Cannot initialize store:@ %a@]" pp_print_error err