Merge pull request #271 from CraigFe/fix-and-escape-with-cli

Fix handling of `~and_exit` parameter when running via CLI functor

CHANGES.md

@@ -1,3 +1,8 @@
+### Unreleased
+
+- Fix a bug in the handling of the `~and_exit:false` option when the test suite
+  fails. (#271, @CraigFe)
+
 ### 1.2.2 (2020-08-26)
 
 - Fail gracefully when the user supplies an empty suite name. (#265, @CraigFe)

examples/bad/bad.ml

@@ -25,38 +25,47 @@ OTHER DEALINGS IN THE SOFTWARE.
 For more information, please refer to <http://unlicense.org/>
 *)
 
-(* Build with
- * ocamlbuild -pkg alcotest bad.byte *)
+(* Run with [dune exec ./examples/bad/bad.exe] *)
 
 (* A module with functions to test *)
 module To_test = struct
-  let capit letter = Astring.String.Ascii.uppercase letter
+  let capitalise = Astring.String.Ascii.uppercase
 
-  let plus int_list = List.map (fun a -> a + a) int_list
+  let double_all = List.map (fun a -> a + a)
 end
 
-(* The tests *)
-let capit () = Alcotest.(check string) "strings" "A" (To_test.capit "b")
+let test_capitalise () =
+  To_test.capitalise "b" |> Alcotest.(check string) "strings" "A"
 
-let plus () =
-  Alcotest.(check (list int)) "int lists" [ 1 ] (To_test.plus [ 1; 1; 2; 3 ])
+let test_double_all () =
+  To_test.double_all [ 1; 1; 2; 3 ]
+  |> Alcotest.(check (list int)) "int lists" [ 1 ]
 
-let test_one = [ ("Capitalize", `Quick, capit); ("Add entries", `Slow, plus) ]
-
-let test_two =
+let suite1 =
   [
-    ("ok", `Quick, fun () -> ());
-    ("Capitalize", `Quick, capit);
-    ("ok", `Quick, fun () -> ());
+    ( "to_test",
+      [
+        ("capitalise", `Quick, test_capitalise);
+        ("double all", `Slow, test_double_all);
+      ] );
   ]
 
-(* Run it *)
-let one () =
-  try Alcotest.run ~and_exit:false "My first test" [ ("Ωèone", test_one) ]
-  with Alcotest.Test_error -> Printf.printf "Continue!!\n%!"
-
-let two () = Alcotest.run ~and_exit:true "Hoho" [ ("two", test_two) ]
+let suite2 =
+  [
+    ( "Ωèone",
+      [
+        ("Passing test 1", `Quick, fun () -> ());
+        ( "Failing test",
+          `Quick,
+          fun () -> Alcotest.fail "This was never going to work..." );
+        ("Passing test 2", `Quick, fun () -> ());
+      ] );
+  ]
 
+(* Run both suites completely, even if the first contains failures *)
 let () =
-  one ();
-  two ()
+  try Alcotest.run ~and_exit:false "First suite" suite1
+  with Alcotest.Test_error ->
+    Printf.printf "Forging ahead regardless!\n%!";
+    Alcotest.run ~and_exit:false "Second suite" suite2;
+    Printf.printf "Finally done."

src/alcotest-engine/cli.ml

@@ -299,34 +299,33 @@ struct
     ( Term.(pure (fun () -> list_tests) $ set_color $ pure tests),
       Term.info "list" ~doc )
 
-  let run_with_args ?and_exit ?verbose ?compact ?tail_errors ?quick_only
-      ?show_errors ?json ?filter ?log_dir ?argv name (args : 'a Term.t)
-      (tl : 'a test list) =
+  let run_with_args ?(and_exit = true) ?verbose ?compact ?tail_errors
+      ?quick_only ?show_errors ?json ?filter ?log_dir ?argv name
+      (args : 'a Term.t) (tl : 'a test list) =
     let ( >>= ) = M.bind in
     let runtime_flags =
       { verbose; compact; tail_errors; show_errors; quick_only; json; log_dir }
     in
     let choices =
       [
         list_cmd tl;
-        test_cmd ?and_exit runtime_flags ~filter:(`Test_filter filter) args name
+        test_cmd ~and_exit runtime_flags ~filter:(`Test_filter filter) args name
           tl;
       ]
     in
     let exit_or_return result =
-      match and_exit with
-      | Some true -> exit (Term.exit_status_of_result result)
-      | _ -> M.return ()
+      if and_exit then exit (Term.exit_status_of_result result) else M.return ()
     in
     let result =
       Term.eval_choice ?argv
-        (default_cmd ?and_exit runtime_flags args name tl)
+        ~catch:and_exit (* Only log exceptions not raised to the user code *)
+        (default_cmd ~and_exit runtime_flags args name tl)
         choices
     in
     match result with
     | `Ok unit_m -> unit_m >>= fun () -> exit_or_return result
-    | `Help | `Version -> exit_or_return result
-    | `Error _ -> exit (Term.exit_status_of_result result)
+    | `Help | `Version | `Error `Exn -> exit_or_return result
+    | `Error (`Parse | `Term) -> exit (Term.exit_status_of_result result)
 
   let run ?and_exit ?verbose ?compact ?tail_errors ?quick_only ?show_errors
       ?json ?filter ?log_dir ?argv name tl =