From 05d210b982c963d295a2c2c1ebecaf32394c6f69 Mon Sep 17 00:00:00 2001
From: Cagdas Bozman <cagdas.bozman@ocamlpro.com>
Date: Tue, 7 Mar 2017 09:51:11 +0100
Subject: [PATCH] Testsuite: fix error handling

---
 test/lib/test.ml           | 16 ++++++++++++++--
 test/lib/test.mli          |  4 +++-
 test/test_basic.ml         |  3 +--
 test/test_context.ml       |  3 ++-
 test/test_data_encoding.ml |  7 ++++++-
 test/test_state.ml         |  5 +----
 test/test_store.ml         |  8 ++++++--
 7 files changed, 33 insertions(+), 13 deletions(-)

diff --git a/test/lib/test.ml b/test/lib/test.ml
index d156fdf2c..3ca2d85c6 100644
--- a/test/lib/test.ml
+++ b/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) ;
-                finalise ()
+                match Lwt_main.run (f base_dir) with
+                | 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))
diff --git a/test/lib/test.mli b/test/lib/test.mli
index 28b29b309..a325c7522 100644
--- a/test/lib/test.mli
+++ b/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
diff --git a/test/test_basic.ml b/test/test_basic.ml
index d898d24ac..d20e29a97 100644
--- a/test/test_basic.ml
+++ b/test/test_basic.ml
@@ -206,8 +206,7 @@ let main () =
   @@ transfer ~src:bar ~target:foo 1000_00L >>=? fun () ->
   mine bootstrap
 
-let tests =
-  [ "main", (fun _ -> main () >>= fun _ -> Lwt.return_unit) ]
+let tests = [ "main", fun _ -> main () ]
 
 let () =
   Test.run "basic." tests
diff --git a/test/test_context.ml b/test/test_context.ml
index a1b32950f..448fcd97c 100644
--- a/test/test_context.ml
+++ b/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 *)
 
diff --git a/test/test_data_encoding.ml b/test/test_data_encoding.ml
index 1d264c358..0ce07cee4 100644
--- a/test/test_data_encoding.ml
+++ b/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)
diff --git a/test/test_state.ml b/test/test_state.ml
index 2ce173a8a..62e1766ad 100644
--- a/test/test_state.ml
+++ b/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
-  | Ok () -> Lwt.return_unit
-  | Error err ->
-      Lwt.return (Error_monad.pp_print_error Format.err_formatter err)
+  end
 
 let test_init (s: state) =
   return ()
diff --git a/test/test_store.ml b/test/test_store.ml
index 434923ffc..ae8a9685d 100644
--- a/test/test_store.ml
+++ b/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