Merge pull request #271 from alopezz/honor-polarity-in-check_exn

Make `Test.check_exn` honor test polarity

CHANGELOG.md

@@ -2,6 +2,10 @@
 
 ## NEXT RELEASE
 
+- make `Test.check_result`, `Test.check_cell_exn`, and
+  `Test.check_exn` honor test polarity by raising
+  `Test_unexpected_success` when a negative test (expected to have a
+  counter example), unexpectedly succeeds.
 - ...
 
 ## 0.20

example/alcotest/output.txt.expected.32

@@ -29,8 +29,7 @@ on `0 (after 31 shrink steps)`
 │ [FAIL]        suite              4   neg test unexpected success.            │
 └──────────────────────────────────────────────────────────────────────────────┘
 negative test 'neg test unexpected success' succeeded unexpectedly
-ASSERT negative test 'neg test unexpected success' succeeded unexpectedly
-FAIL negative test 'neg test unexpected success' succeeded unexpectedly
+[exception] negative test `neg test unexpected success` succeeded unexpectedly
  ──────────────────────────────────────────────────────────────────────────────
 ┌──────────────────────────────────────────────────────────────────────────────┐
 │ [FAIL]        suite              5   neg fail with error.                    │

example/alcotest/output.txt.expected.64

@@ -29,8 +29,7 @@ on `0 (after 63 shrink steps)`
 │ [FAIL]        suite              4   neg test unexpected success.            │
 └──────────────────────────────────────────────────────────────────────────────┘
 negative test 'neg test unexpected success' succeeded unexpectedly
-ASSERT negative test 'neg test unexpected success' succeeded unexpectedly
-FAIL negative test 'neg test unexpected success' succeeded unexpectedly
+[exception] negative test `neg test unexpected success` succeeded unexpectedly
  ──────────────────────────────────────────────────────────────────────────────
 ┌──────────────────────────────────────────────────────────────────────────────┐
 │ [FAIL]        suite              5   neg fail with error.                    │

example/alcotest/output.txt.expected.ocaml5

@@ -29,8 +29,7 @@ on `0 (after 62 shrink steps)`
 │ [FAIL]        suite              4   neg test unexpected success.            │
 └──────────────────────────────────────────────────────────────────────────────┘
 negative test 'neg test unexpected success' succeeded unexpectedly
-ASSERT negative test 'neg test unexpected success' succeeded unexpectedly
-FAIL negative test 'neg test unexpected success' succeeded unexpectedly
+[exception] negative test `neg test unexpected success` succeeded unexpectedly
  ──────────────────────────────────────────────────────────────────────────────
 ┌──────────────────────────────────────────────────────────────────────────────┐
 │ [FAIL]        suite              5   neg fail with error.                    │

src/alcotest/QCheck_alcotest.ml

@@ -54,14 +54,6 @@ let to_alcotest
   let name = T.get_name cell in
   let run () =
     let call = Raw.callback ~colors ~verbose ~print_res:true ~print in
-    if T.get_positive cell
-    then
-      T.check_cell_exn ~long ~call ~handler ~rand cell
-    else
-      try
-        T.check_cell_exn ~long ~call ~handler ~rand cell;
-        Alcotest.failf "negative test '%s' succeeded unexpectedly" name
-      with
-        T.Test_fail (_name,_l) -> ()
+    T.check_cell_exn ~long ~call ~handler ~rand cell
   in
   ((name, `Slow, run) : unit Alcotest.test_case)

src/core/QCheck.mli

@@ -1137,13 +1137,16 @@ module Test : sig
     ?long:bool -> ?call:'a callback ->
     ?step:'a step -> ?handler:'a handler ->
     ?rand:Random.State.t -> 'a cell -> 'a TestResult.t
+  (** See {!QCheck2.Test.check_cell}. *)
 
   val check_cell_exn :
     ?long:bool -> ?call:'a callback ->
     ?step:'a step -> ?handler:'a handler ->
     ?rand:Random.State.t -> 'a cell -> unit
+  (** See {!QCheck2.Test.check_cell_exn}. *)
 
   val check_exn : ?long:bool -> ?rand:Random.State.t -> t -> unit
+  (** See {!QCheck2.Test.check_exn}. *)
 end
 
 (** {2 Sub-tests} *)

src/core/QCheck2.ml

@@ -1406,6 +1406,7 @@ module Test_exceptions = struct
 
   exception Test_fail of string * string list
   exception Test_error of string * string * exn * string
+  exception Test_unexpected_success of string
 end
 
 module Test = struct
@@ -1882,6 +1883,8 @@ module Test = struct
 
   let print_test_fail name l = asprintf "@[%a@]@?" (pp_print_test_fail name) l
 
+  let print_unexpected_success name = Format.sprintf "@[negative test `%s`@ succeeded unexpectedly@]" name
+
   let print_test_error name i e stack =
     Format.sprintf "@[test `%s`@ raised exception `%s`@ on `%s`@,%s@]"
       name (Printexc.to_string e) i stack
@@ -1982,6 +1985,7 @@ module Test = struct
       (function
         | Test_fail (name,l) -> Some (print_test_fail name l)
         | Test_error (name,i,e,st) -> Some (print_test_error name i e st)
+        | Test_unexpected_success name -> Some (print_unexpected_success name)
         | User_fail s -> Some ("qcheck: user fail:\n" ^ s)
         | _ -> None)
 
@@ -1998,14 +2002,17 @@ module Test = struct
   let print_error ?(st="") arb name (i,e) =
     print_test_error name (print_c_ex arb i) e st
 
-  let check_result cell res = match res.R.state with
-    | R.Success -> ()
-    | R.Error {instance; exn; backtrace} ->
+  let check_result cell res = match res.R.state, cell.positive with
+    | R.Success, true -> ()
+    | R.Success, false ->
+      raise (Test_unexpected_success cell.name)
+    | R.Error {instance; exn; backtrace}, _ ->
       raise (Test_error (cell.name, print_c_ex cell instance, exn, backtrace))
-    | R.Failed {instances=l} ->
+    | R.Failed {instances=l}, true ->
       let l = List.map (print_c_ex cell) l in
       raise (Test_fail (cell.name, l))
-    | R.Failed_other {msg} ->
+    | R.Failed _, false -> ()
+    | R.Failed_other {msg}, _ ->
       raise (Test_fail (cell.name, [msg]))
 
   let check_cell_exn ?long ?call ?step ?handler ?rand cell =

src/core/QCheck2.mli

@@ -1649,6 +1649,11 @@ module Test_exceptions : sig
       [Test_error (name, i, e, st)]
       means [name] failed on [i] with exception [e], and [st] is the
       stacktrace (if enabled) or an empty string. *)
+
+  exception Test_unexpected_success of string
+  (** Exception raised when a negative test failed.
+      [Test_unexpected_success name] means test [name] failed to find an
+      expected counter example. *)
 end
 
 (** A test is a pair of a generator and a property that all generated values must satisfy. *)
@@ -1801,9 +1806,11 @@ module Test : sig
       @since 0.6 *)
 
   val check_result : 'a cell -> 'a TestResult.t -> unit
-  (** [check_result cell res] checks that [res] is [Ok _], and returns unit.
+  (** For a positive test [check_result cell res] checks that [res] is [Ok _], and returns unit.
+      For a negative test [check_result cell res] checks that [res] is [Failed _], and returns unit.
       Otherwise, it raises some exception.
-      @raise Test_fail  if [res = Failed _]
+      @raise Test_fail  if the test is positive and [res = Failed _]
+      @raise Test_unexpected_success  if the test is negative and [res = Ok _]
       @raise Test_error if [res = Error _] *)
 
   type res =
@@ -1840,6 +1847,10 @@ module Test : sig
       predicate [law] is called on them and if it returns [false] or raises an
       exception then we have a counter-example for the [law].
 
+      Note: [check_cell] ignores a test's polarity, acting as
+      described above regardless of whether the tested cell is a
+      positive or negative test.
+
       @param long if [true] then multiply the number of instances to generate
         by the cell's long_factor.
       @param call function called on each test case, with the result.
@@ -1852,13 +1863,19 @@ module Test : sig
     ?step:'a step -> ?handler:'a handler ->
     ?rand:Random.State.t -> 'a cell -> unit
   (** Same as {!check_cell} but calls  {!check_result} on the result.
-      @raise Test_fail  if [res = Failed _]
+      [check_cell test] honors test polarity and thus expects positive tests to succeed
+      without finding a counterexample and expects negative tests to fail by finding one.
+      @raise Test_fail  if the test is positive and [res = Failed _]
+      @raise Test_unexpected_success  if the test is negative and [res = Success _]
       @raise Test_error if [res = Error _] *)
 
   val check_exn : ?long:bool -> ?rand:Random.State.t -> t -> unit
   (** Checks the property against some test cases, and calls {!check_result},
       which might raise an exception in case of failure.
-      @raise Test_fail  if [res = Failed _]
+      [check_exn test] honors test polarity and thus expects positive tests to succeed
+      without finding a counterexample and expects negative tests to fail by finding one.
+      @raise Test_fail  if the test is positive and [res = Failed _]
+      @raise Test_unexpected_success  if the test is negative and [res = Success _]
       @raise Test_error if [res = Error _] *)
 end
 

src/ounit/QCheck_ounit.ml

@@ -72,16 +72,8 @@ let to_ounit2_test ?(rand =default_rand()) (QCheck2.Test.Test cell) =
         fail = (fun fmt -> Printf.ksprintf assert_failure fmt);
         err = (fun fmt -> logf ctxt `Error fmt);
       } in
-      if QCheck2.Test.get_positive cell
-      then
-        T.check_cell_exn cell
-          ~long ~rand ~call:(Raw.callback ~colors:false ~verbose ~print_res:true ~print)
-      else
-        try
-          T.check_cell_exn cell
-            ~long ~rand ~call:(Raw.callback ~colors:false ~verbose ~print_res:true ~print);
-          ()
-        with T.Test_fail (_,_) -> ())
+      T.check_cell_exn cell
+        ~long ~rand ~call:(Raw.callback ~colors:false ~verbose ~print_res:true ~print))
 
 let to_ounit2_test_list ?rand lst =
   List.rev (List.rev_map (to_ounit2_test ?rand) lst)
@@ -93,18 +85,12 @@ let to_ounit_test_cell ?(verbose=verbose()) ?(long=long_tests())
   let module T = QCheck2.Test in
   let name = T.get_name cell in
   let run () =
-
-    let res =
-      try
-        T.check_cell_exn cell ~long ~rand
-          ~call:(Raw.callback ~colors:false ~verbose ~print_res:verbose ~print:Raw.print_std);
-        true
-      with T.Test_fail _ ->
-        false
-    in
-    if QCheck2.Test.get_positive cell
-    then res
-    else not res
+    try
+      T.check_cell_exn cell ~long ~rand
+        ~call:(Raw.callback ~colors:false ~verbose ~print_res:verbose ~print:Raw.print_std);
+      true
+    with T.Test_fail _ ->
+      false
   in
   name >:: (fun () -> assert_bool name (run ()))
 

test/core/QCheck2_unit_tests.ml

@@ -313,13 +313,29 @@ module Check_exn = struct
         then
           Alcotest.failf "%s: counter-example prefix. Received \"%s\"" name c_ex_str
 
+  let test_negative_trivial () =
+    let run_test () = check_exn QCheck2.(Test.make_neg Gen.int (fun _ -> false)) in
+    Alcotest.(check unit) "Success-negative-trivial" () @@ run_test ()
+
+  let test_negative_test_unexpected_success () =
+    let name = "negative-trivial-test" in
+    let run_test () = check_exn QCheck2.(Test.make_neg ~name Gen.int (fun _ -> true)) in
+    try
+      run_test ();
+      Alcotest.failf "Negative test didn't raise expected exception."
+    with
+      Test.Test_unexpected_success n ->
+        Alcotest.(check string) (Printf.sprintf "%s: name" name) n name
+
   let tests =
     ("Test.check_exn", Alcotest.[
          test_case "check_exn pass trivial" `Quick test_pass_trivial;
          test_case "check_exn pass random" `Quick test_pass_random;
          test_case "check_exn fail always" `Quick test_fail_always;
          test_case "check_exn fail random" `Quick test_fail_random;
          test_case "check_exn Error" `Quick test_error;
+         test_case "check_exn negative pass trivial" `Quick test_negative_trivial;
+         test_case "check_exn Unexpected success" `Quick test_negative_test_unexpected_success;
        ])
 end
 

test/core/QCheck_unit_tests.ml

@@ -151,13 +151,29 @@ module Check_exn = struct
         then
           Alcotest.failf "%s: counter-example prefix. Received \"%s\"" name c_ex_str
 
+  let test_negative_trivial () =
+    let run_test () = check_exn QCheck2.(Test.make_neg Gen.int (fun _ -> false)) in
+    Alcotest.(check unit) "Success-negative-trivial" () @@ run_test ()
+
+  let test_negative_test_unexpected_success () =
+    let name = "negative-trivial-test" in
+    let run_test () = check_exn QCheck2.(Test.make_neg ~name Gen.int (fun _ -> true)) in
+    try
+      run_test ();
+      Alcotest.failf "Negative test didn't raise expected exception."
+    with
+      Test.Test_unexpected_success n ->
+        Alcotest.(check string) (Printf.sprintf "%s: name" name) n name
+
   let tests =
     ("Test.check_exn", Alcotest.[
          test_case "check_exn pass trivial" `Quick test_pass_trivial;
          test_case "check_exn pass random" `Quick test_pass_random;
          test_case "check_exn fail always" `Quick test_fail_always;
          test_case "check_exn fail random" `Quick test_fail_random;
          test_case "check_exn Error" `Quick test_error;
+         test_case "check_exn negative pass trivial" `Quick test_negative_trivial;
+         test_case "check_exn Unexpected success" `Quick test_negative_test_unexpected_success;
        ])
 end