Repository: c-cube/qcheck
Pull request #244 (2022-05-30 12:30:50)

Add `Test.make_neg`
This PR adds a "primitive" `Test.make_neg` which lets one express negative property-based tests, that is, tests that are supposed to fail. This can be useful
- to safe guard the error-finding ability of a generator
- to supplement existing positive test (supposed to succeed)
- to document in test source code which tests are supposed to fail and succeed

The commercial Erlang QuickCheck has a similar operation, `fails`: http://quviq.com/documentation/eqc/eqc.html#fails-1

Here's an example:
```ocaml
open QCheck
let t1 = Test.make_neg ~name:"all ints are even" small_int (fun i -> i mod 2 = 0)
let t2 = Test.make ~name:"int double" small_int (fun i -> i + i = i * 2)
let t2' = Test.make_neg ~name:"int double" small_int (fun i -> i + i = i * 2)
let t3 = Test.make_neg ~name:"list rev concat" (pair (list small_int) (list small_int)) (fun (is,js) -> (List.rev is)@(List.rev js) = List.rev (is@js))
let t4 = Test.make ~name:"pos fail" small_int (fun i -> raise (Failure "pos-fail"))
let t5 = Test.make_neg ~name:"neg fail" small_int (fun i -> raise (Failure "neg-fail"))
;;
QCheck_runner.run_tests ~verbose:true [t1;t2;t2';t3;t4;t5];;
```
and corresponding output:
```
random seed: 442234180
generated error fail pass / total     time test name
[✓]    1    0    0    1 /  100     0.0s all ints are even
[✓]  100    0    0  100 /  100     0.0s int double
[✗]  100    0  100    0 /  100     0.0s int double
[✓]    1    0    0    1 /  100     0.0s list rev concat
[✗]    1    1    0    0 /  100     0.0s pos fail
[✗]    1    1    0    0 /  100     0.0s neg fail

--- Info -----------------------------------------------------------------------

Negative test all ints are even failed as expected (2 shrink steps):

3

--- Failure --------------------------------------------------------------------

Test int double failed:

Negative test int double succeeded but was expected to fail

--- Info -----------------------------------------------------------------------

Negative test list rev concat failed as expected (17 shrink steps):

([0], [1])

=== Error ======================================================================

Test pos fail errored on (5 shrink steps):

0

exception Failure("pos-fail")


=== Error ======================================================================

Test neg fail errored on (5 shrink steps):

0

exception Failure("neg-fail")

================================================================================
failure (1 tests failed, 2 tests errored, ran 6 tests)
- : int = 1
```

I have gone for keeping changes to a minimum and thus leave the test-generation-shrink loop and `Test.check_cell` untouched.
Negative tests are marked with a `bool` in their underlying `cell` - and it is instead the job of the runner to match this marker with `TestResult.t`s.

In the current design a test `Error` is considered a failure for both positive and negative tests (see pos-fail and neg-fail above).

Things missing:
- ~~internal tests of the new functionality~~
- ~~extend the alcotest runner~~
- ~~extend the ounit runner~~
- ~~add CHANGELOG entry~~

Input on the design and/or implementation are welcome.


Patch:
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 80148a8..b625d5a 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -17,6 +17,9 @@
 
 - add `tup2` to `tup9` for generators
 
+- add `Test.make_neg` for negative property-based tests, that are
+  expected not to satisfy the tested property.
+
 - rename `Gen.opt` to `Gen.option` but keep the old binding for compatibility.
 
 - add additional expect and unit tests and refactor expect test suite
diff --git a/example/ounit/output.txt.expected b/example/ounit/output.txt.expected
index df0adfb..874cd52 100644
--- a/example/ounit/output.txt.expected
+++ b/example/ounit/output.txt.expected
@@ -1,4 +1,15 @@
-.FEF.
+.FE.FEF.
+==============================================================================
+Error: tests:5:neg fail with error.
+
+Error: tests:5:neg fail with error (in the log).
+
+
+test `neg fail with error`
+raised exception `Dune__exe__QCheck_ounit_test.Error`
+on `0 (after 7 shrink steps)`
+
+------------------------------------------------------------------------------
 ==============================================================================
 Error: tests:2:error_raise_exn.
 
@@ -10,11 +21,11 @@ on `0 (after 63 shrink steps)`
 
 ------------------------------------------------------------------------------
 ==============================================================================
-Error: tests:3:fail_check_err_message.
+Error: tests:6:fail_check_err_message.
 
-Error: tests:3:fail_check_err_message (in the log).
+Error: tests:6:fail_check_err_message (in the log).
 
-Error: tests:3:fail_check_err_message (in the code).
+Error: tests:6:fail_check_err_message (in the code).
 
 
 test `fail_check_err_message` failed on ≥ 1 cases:
@@ -26,6 +37,17 @@ fail
 
 
 
+------------------------------------------------------------------------------
+==============================================================================
+Error: tests:4:neg test unexpected success.
+
+Error: tests:4:neg test unexpected success (in the log).
+
+Error: tests:4:neg test unexpected success (in the code).
+
+
+negative test 'neg test unexpected success' succeeded unexpectedly
+
 ------------------------------------------------------------------------------
 ==============================================================================
 Error: tests:1:fail_sort_id.
@@ -39,5 +61,5 @@ test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 11 shrink steps)
                                            
 
 ------------------------------------------------------------------------------
-Ran: 5 tests in: <nondet> seconds.
-FAILED: Cases: 5 Tried: 5 Errors: 1 Failures: 2 Skip:  0 Todo: 0 Timeouts: 0.
+Ran: 8 tests in: <nondet> seconds.
+FAILED: Cases: 8 Tried: 8 Errors: 2 Failures: 3 Skip:  0 Todo: 0 Timeouts: 0.
diff --git a/example/output.txt.expected b/example/output.txt.expected
index cf10485..f54f8f4 100644
--- a/example/output.txt.expected
+++ b/example/output.txt.expected
@@ -57,6 +57,21 @@ stats num:
   110..115: #######################################################           9
   116..121: ##################                                                3
 
+--- Failure --------------------------------------------------------------------
+
+Test neg test unexpected success failed:
+
+Negative test neg test unexpected success succeeded but was expected to fail
+
+=== Error ======================================================================
+
+Test neg fail with error errored on (7 shrink steps):
+
+0
+
+exception Dune__exe__QCheck_runner_test.Error
+
+
 --- Failure --------------------------------------------------------------------
 
 Test FAIL_pred_map_commute failed (77 shrink steps):
@@ -315,4 +330,4 @@ stats dist:
    4150387758342729156.. 4611540922436308291: ######################################################         5039
 ================================================================================
 1 warning(s)
-failure (9 tests failed, 1 tests errored, ran 25 tests)
+failure (10 tests failed, 2 tests errored, ran 28 tests)
diff --git a/src/core/QCheck.ml b/src/core/QCheck.ml
index 0268bc3..b0aa99e 100644
--- a/src/core/QCheck.ml
+++ b/src/core/QCheck.ml
@@ -1697,14 +1697,17 @@ module Test = struct
   let get_long_factor = QCheck2.Test.get_long_factor
 
   let make_cell ?if_assumptions_fail
-      ?count ?long_factor ?max_gen
+      ?count ?long_factor ?negative ?max_gen
   ?max_fail ?small:_removed_in_qcheck_2 ?retries ?name arb law
   =
   let {gen; shrink; print; collect; stats; _} = arb in
-  QCheck2.Test.make_cell_from_QCheck1 ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?retries ?name ~gen ?shrink ?print ?collect ~stats law
+  QCheck2.Test.make_cell_from_QCheck1 ?if_assumptions_fail ?count ?long_factor ?negative ?max_gen ?max_fail ?retries ?name ~gen ?shrink ?print ?collect ~stats law
 
-  let make ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?small ?retries ?name arb law =
-    QCheck2.Test.Test (make_cell ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?small ?retries ?name arb law)
+  let make' ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?small ?retries ?name ~negative arb law =
+    QCheck2.Test.Test (make_cell ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?small ?retries ?name ~negative arb law)
+
+  let make = make' ~negative:false
+  let make_neg = make' ~negative:true
 
   let fail_report = QCheck2.Test.fail_report
 
diff --git a/src/core/QCheck.mli b/src/core/QCheck.mli
index f6176f6..ab6dcf4 100644
--- a/src/core/QCheck.mli
+++ b/src/core/QCheck.mli
@@ -900,10 +900,17 @@ val get_print : 'a arbitrary -> 'a Print.t option
     with an object of type [foo arbitrary] used to generate, print, etc. values
     of type [foo].
 
-    See {!Test.make} to build a test, and {!Test.check_exn} to
-    run one test simply.
-    For more serious testing, it is better to create a testsuite
-    and use {!QCheck_runner}.
+    The main features of this module are:
+    - {!Test.make} to build a test,
+    - {!Test.make_neg} to build a negative test that is expected not to satisfy the tested property,
+    - {!Test.check_exn} to run a single test with a simple runner.
+
+    A test fails if the property does not hold for a given input. The {{!Test.fail_report} simple} form or the {{!Test.fail_reportf} rich} form) offer more elaborate forms to fail a test.
+
+    For more serious testing, it is recommended to create a testsuite and use a full-fledged runner:
+    - {!QCheck_base_runner} is a QCheck-only runner (useful if you don't have or don't need another test framework)
+    - {!QCheck_alcotest} interfaces to the Alcotest framework
+    - {!QCheck_ounit} interfaces to the to OUnit framework
 *)
 
 (** Result of running a test *)
@@ -997,7 +1004,7 @@ module Test : sig
 
   val make_cell :
     ?if_assumptions_fail:([`Fatal | `Warning] * float) ->
-    ?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int ->
+    ?count:int -> ?long_factor:int -> ?negative:bool -> ?max_gen:int -> ?max_fail:int ->
     ?small:('a -> int) -> ?retries:int -> ?name:string ->
     'a arbitrary -> ('a -> bool) -> 'a cell
   (** [make_cell arb prop] builds a test that checks property [prop] on instances
@@ -1008,6 +1015,7 @@ module Test : sig
       @param retries number of times to retry the tested property while shrinking.
       @param long_factor the factor by which to multiply count, max_gen and
         max_fail when running a long test (default: 1).
+      @param negative whether the test is expected not to satisfy the tested property.
       @param max_gen maximum number of times the generation function
         is called in total to replace inputs that do not satisfy
         preconditions (should be >= count).
@@ -1053,6 +1061,18 @@ module Test : sig
       See {!make_cell} for a description of the parameters.
   *)
 
+  val make_neg :
+    ?if_assumptions_fail:([`Fatal | `Warning] * float) ->
+    ?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int ->
+    ?small:('a -> int) -> ?retries:int -> ?name:string -> 'a arbitrary ->
+    ('a -> bool) -> t
+  (** [make_neg arb prop] builds a test that checks property [prop] on instances
+      of the generator [arb].
+      The test is considered negative, meaning that it is expected not to satisfy the tested property.
+      This information is recorded in an underlying test [cell] entry and interpreted suitably by test runners.
+      See {!make_cell} for a description of the parameters.
+  *)
+
   include module type of QCheck2.Test_exceptions
 
   val print_instance : 'a cell -> 'a -> string
diff --git a/src/core/QCheck2.ml b/src/core/QCheck2.ml
index 2e3c5da..f95104f 100644
--- a/src/core/QCheck2.ml
+++ b/src/core/QCheck2.ml
@@ -1367,6 +1367,10 @@ module TestResult = struct
   let is_success r = match r.state with
     | Success -> true
     | Failed _ | Error _ | Failed_other _ -> false
+
+  let is_failed r = match r.state with
+    | Failed _ -> true
+    | Success | Error _ | Failed_other _ -> false
 end
 
 module Test_exceptions = struct
@@ -1380,6 +1384,7 @@ module Test = struct
   type 'a cell = {
     count : int; (* number of tests to do *)
     long_factor : int; (* multiplicative factor for long test count *)
+    positive : bool; (* indicates whether test is considered positive or negative *)
     max_gen : int; (* max number of instances to generate (>= count) *)
     max_fail : int; (* max number of failures *)
     retries : int; (* max number of retries during shrinking *)
@@ -1413,6 +1418,8 @@ module Test = struct
 
   let get_long_factor {long_factor; _} = long_factor
 
+  let get_positive {positive; _} = positive
+
   let default_count = 100
 
   let default_long_factor = 1
@@ -1436,11 +1443,12 @@ module Test = struct
   let default_if_assumptions_fail = `Warning, 0.05
 
   let make_cell ?(if_assumptions_fail=default_if_assumptions_fail)
-      ?(count) ?long_factor ?max_gen
+      ?(count) ?long_factor ?(negative=false) ?max_gen
       ?(max_fail=1) ?(retries=1) ?(name=fresh_name()) ?print ?collect ?(stats=[]) gen law
     =
     let count = global_count count in
     let long_factor = global_long_factor long_factor in
+    let positive = not negative in
     let max_gen = match max_gen with None -> count + 200 | Some x->x in
     {
       law;
@@ -1454,16 +1462,18 @@ module Test = struct
       name;
       count;
       long_factor;
+      positive;
       if_assumptions_fail;
       qcheck1_shrink = None;
     }
 
   let make_cell_from_QCheck1 ?(if_assumptions_fail=default_if_assumptions_fail)
-      ?(count) ?long_factor ?max_gen
+      ?(count) ?long_factor ?(negative=false) ?max_gen
       ?(max_fail=1) ?(retries=1) ?(name=fresh_name()) ~gen ?shrink ?print ?collect ~stats law
     =
     let count = global_count count in
     let long_factor = global_long_factor long_factor in
+    let positive = not negative in
     (* Make a "fake" QCheck2 arbitrary with no shrinking *)
     let fake_gen = Gen.make_primitive ~gen ~shrink:(fun _ -> Seq.empty) in
     let max_gen = match max_gen with None -> count + 200 | Some x->x in
@@ -1479,15 +1489,19 @@ module Test = struct
       name;
       count;
       long_factor;
+      positive;
       if_assumptions_fail;
       qcheck1_shrink = shrink;
     }
 
-  let make ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?retries ?name ?print ?collect ?stats gen law =
-    Test (make_cell ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?retries ?name ?print ?collect ?stats gen law)
+  let make' ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?retries ?name ?print ?collect ?stats ~negative arb law =
+    Test (make_cell ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?retries ?name ?print ?collect ?stats ~negative arb law)
+
+  let make = make' ~negative:false
+  let make_neg = make' ~negative:true
 
   let test_get_count (Test cell) = get_count cell
-  
+
   let test_get_long_factor (Test cell) = get_long_factor cell
 
   (** {6 Running the test} *)
@@ -1949,6 +1963,10 @@ module Test = struct
   let print_fail_other name ~msg =
     print_test_fail name [msg]
 
+  let print_expected_failure cell c_exs = match c_exs with
+    | [] -> Format.sprintf "negative test `%s` failed as expected\n" (get_name cell)
+    | c_ex::_ -> Format.sprintf "negative test `%s` failed as expected on: %s\n" (get_name cell) (print_c_ex cell c_ex)
+
   let print_error ?(st="") arb name (i,e) =
     print_test_error name (print_c_ex arb i) e st
 
diff --git a/src/core/QCheck2.mli b/src/core/QCheck2.mli
index ec54ca1..c32627d 100644
--- a/src/core/QCheck2.mli
+++ b/src/core/QCheck2.mli
@@ -1537,9 +1537,12 @@ module TestResult : sig
       @since 0.18 *)
 
   val is_success : _ t -> bool
-  (** Returns true iff the state if [Success]
+  (** Returns true iff the state is [Success]
       @since 0.9 *)
 
+  val is_failed : _ t -> bool
+  (** Returns true iff the state is [Failed _] *)
+
   val stats : 'a t -> ('a stat * (int,int) Hashtbl.t) list
   (** Obtain statistics
       @since 0.6
@@ -1570,12 +1573,14 @@ module Test_exceptions : sig
       stacktrace (if enabled) or an empty string. *)
 end
 
-(** A test is a pair of an generator and a property thar all generated values must satisfy. *)
+(** A test is a pair of a generator and a property that all generated values must satisfy. *)
 module Test : sig
   (** The main features of this module are:
-      - {!make} a test
-      - fail the test if a property does not hold (using either the {{!fail_report} simple} form or the {{!fail_reportf} rich} form)
-      - {!check_exn} a single test
+      - {!make} to create a test
+      - {!make_neg} to create a negative test that is expected not to satisfy the tested property
+      - {!check_exn} to run a single test with a simple runner.
+
+      A test fails if the property does not hold for a given input. The {{!fail_report} simple} form or the {{!fail_reportf} rich} form) offer more elaborate forms to fail a test.
 
       Note that while {!check_exn} is provided for convenience to discover QCheck or to run a single test in {{: https://opam.ocaml.org/blog/about-utop/} utop}, to run QCheck tests in your project you probably want to opt for a more advanced runner, or convert
       QCheck tests to your favorite test framework:
@@ -1587,10 +1592,10 @@ module Test : sig
   type 'a cell
   (** A single property test on a value of type ['a]. A {!Test.t} wraps a [cell]
       and hides its type parameter. *)
-     
+
   val make_cell :
     ?if_assumptions_fail:([`Fatal | `Warning] * float) ->
-    ?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int -> ?retries:int ->
+    ?count:int -> ?long_factor:int ->  ?negative:bool -> ?max_gen:int -> ?max_fail:int -> ?retries:int ->
     ?name:string -> ?print:'a Print.t -> ?collect:('a -> string) -> ?stats:('a stat list) ->
      'a Gen.t -> ('a -> bool) ->
     'a cell
@@ -1601,6 +1606,7 @@ module Test : sig
         the test cases which satisfy preconditions.
       @param long_factor the factor by which to multiply count, max_gen and
         max_fail when running a long test (default: 1).
+      @param negative whether the test is expected not to satisfy the tested property.
       @param max_gen maximum number of times the generation function
         is called in total to replace inputs that do not satisfy
         preconditions (should be >= count).
@@ -1621,11 +1627,11 @@ module Test : sig
 
   val make_cell_from_QCheck1 :
     ?if_assumptions_fail:([`Fatal | `Warning] * float) ->
-    ?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int ->
+    ?count:int -> ?long_factor:int -> ?negative:bool -> ?max_gen:int -> ?max_fail:int ->
     ?retries:int -> ?name:string -> gen:(Random.State.t -> 'a) -> ?shrink:('a -> ('a -> unit) -> unit) ->
     ?print:('a -> string) -> ?collect:('a -> string) -> stats:'a stat list -> ('a -> bool) ->
     'a cell
-  (** ⚠️ Do not use, this is exposed for internal reasons only. ⚠️ 
+  (** ⚠️ Do not use, this is exposed for internal reasons only. ⚠️
 
       @deprecated Migrate to QCheck2 and use {!make_cell} instead.
    *)
@@ -1646,6 +1652,9 @@ module Test : sig
   (** Get the long factor of a cell.
       @since 0.5.3 *)
 
+  val get_positive : _ cell -> bool
+  (** Get the expected mode of a cell: positive indicates expected to satisfy the tested property, negative indicates expected not to satisfy the tested property.  *)
+
   type t = Test : 'a cell -> t
   (** Same as ['a cell], but masking the type parameter. This allows to
       put tests on different types in the same list of tests. *)
@@ -1660,6 +1669,18 @@ module Test : sig
       See {!make_cell} for a description of the parameters.
   *)
 
+  val make_neg :
+    ?if_assumptions_fail:([`Fatal | `Warning] * float) ->
+    ?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int -> ?retries:int ->
+    ?name:string -> ?print:('a Print.t) -> ?collect:('a -> string) -> ?stats:('a stat list) ->
+    'a Gen.t -> ('a -> bool) -> t
+  (** [make_neg gen prop] builds a test that checks property [prop] on instances
+      of the generator [gen].
+      The test is considered negative, meaning that it is expected not to satisfy the tested property.
+      This information is recorded in an underlying test [cell] entry and interpreted suitably by test runners.
+      See {!make_cell} for a description of the parameters.
+  *)
+
   val test_get_count : t -> int
 
   val test_get_long_factor : t -> int
@@ -1688,6 +1709,7 @@ module Test : sig
   val print_c_ex : 'a cell -> 'a TestResult.counter_ex -> string
   val print_fail : 'a cell -> string -> 'a TestResult.counter_ex list -> string
   val print_fail_other : string -> msg:string -> string
+  val print_expected_failure : 'a cell -> 'a TestResult.counter_ex list -> string
   val print_error : ?st:string -> 'a cell -> string -> 'a TestResult.counter_ex * exn -> string
   val print_test_fail : string -> string list -> string
   val print_test_error : string -> string -> exn -> string -> string
diff --git a/src/ounit/QCheck_ounit.ml b/src/ounit/QCheck_ounit.ml
index e4a814b..b6b2e66 100644
--- a/src/ounit/QCheck_ounit.ml
+++ b/src/ounit/QCheck_ounit.ml
@@ -2,7 +2,7 @@
 open OUnit
 open QCheck_base_runner
 
-let ps = print_string
+let ps = Printf.printf "%s"
 let va = Printf.sprintf
 let pf = Printf.printf
 
@@ -72,8 +72,16 @@ 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
-      T.check_cell_exn cell
-        ~long ~rand ~call:(Raw.callback ~colors:false ~verbose ~print_res:true ~print))
+      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 (_,_) -> ())
 
 let to_ounit2_test_list ?rand lst =
   List.rev (List.rev_map (to_ounit2_test ?rand) lst)
@@ -85,12 +93,18 @@ 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 () =
-    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
+
+    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
   in
   name >:: (fun () -> assert_bool name (run ()))
 
diff --git a/src/runner/QCheck_base_runner.ml b/src/runner/QCheck_base_runner.ml
index a5edbce..f9463a5 100644
--- a/src/runner/QCheck_base_runner.ml
+++ b/src/runner/QCheck_base_runner.ml
@@ -135,9 +135,14 @@ module Raw = struct
     if print_res then (
       (* even if [not verbose], print errors *)
       match R.get_state result with
-        | R.Success -> ()
+        | R.Success ->
+          if not (T.get_positive cell)
+          then
+            print.fail "%snegative test '%s' succeeded unexpectedly\n" reset_line name;
         | R.Failed {instances=l} ->
-          print.fail "%s%s\n" reset_line (T.print_fail cell name l);
+          if T.get_positive cell
+          then print.fail "%s%s\n" reset_line (T.print_fail cell name l)
+          else print.info "%s%s\n" reset_line (T.print_expected_failure cell l)
         | R.Failed_other {msg} ->
           print.fail "%s%s\n" reset_line (T.print_fail_other name ~msg);
         | R.Error {instance; exn; backtrace} ->
@@ -286,8 +291,11 @@ let step ~colors ~size ~out ~verbose c name _ _ r =
       (if colors then Color.reset_line else "\n") (pp_counter ~size) c name
   )
 
-let callback ~size ~out ~verbose ~colors c name _ r =
-  let pass = QCheck2.TestResult.is_success r in
+let callback ~size ~out ~verbose ~colors c name cell r =
+  let pass =
+    if QCheck2.Test.get_positive cell
+    then QCheck2.TestResult.is_success r
+    else QCheck2.TestResult.is_failed r in
   let color = if pass then `Green else `Red in
   if verbose then (
     Printf.fprintf out "%s[%a] %a %s\n%!"
@@ -356,6 +364,13 @@ let print_fail_other ~colors out cell msg =
   Printf.fprintf out "\n--- %a %s\n\n" (Color.pp_str_c ~colors `Red) "Failure" (String.make 68 '-');
   Printf.fprintf out "Test %s failed:\n\n%s\n%!" (QCheck2.Test.get_name cell) msg
 
+let print_expected_failure ~colors out cell c_ex =
+  Printf.fprintf out "\n--- %a %s\n\n" (Color.pp_str_c ~colors `Blue) "Info" (String.make 71 '-');
+  Printf.fprintf out "Negative test %s failed as expected (%d shrink steps):\n\n%s\n%!"
+    (QCheck2.Test.get_name cell) c_ex.QCheck2.TestResult.shrink_steps
+    (print_inst cell c_ex.QCheck2.TestResult.instance);
+  print_messages ~colors out cell c_ex.QCheck2.TestResult.msg_l
+
 let print_error ~colors out cell c_ex exn bt =
   Printf.fprintf out "\n=== %a %s\n\n" (Color.pp_str_c ~colors `Red) "Error" (String.make 70 '=');
   Printf.fprintf out "Test %s errored on (%d shrink steps):\n\n%s\n\nexception %s\n%s\n%!"
@@ -406,17 +421,24 @@ let run_tests
   let res = List.map aux_map l in
   let aux_fold (total, fail, error, warns) (Res (cell, r)) =
     let warns = warns + List.length (R.get_warnings r) in
-    let acc = match R.get_state r with
-      | R.Success ->
+    let acc = match R.get_state r, QCheck2.Test.get_positive cell with
+      | R.Success, true ->
         print_success ~colors out cell r;
         (total + 1, fail, error, warns)
-      | R.Failed {instances=l} ->
+      | R.Success, false ->
+        let msg = Printf.sprintf "Negative test %s succeeded but was expected to fail" (QCheck2.Test.get_name cell) in
+        print_fail_other ~colors out cell msg;
+        (total + 1, fail + 1, error, warns)
+      | R.Failed {instances=l}, true ->
         List.iter (print_fail ~colors out cell) l;
         (total + 1, fail + 1, error, warns)
-      | R.Failed_other {msg} ->
+      | R.Failed {instances=l}, false ->
+        if verbose then List.iter (print_expected_failure ~colors out cell) l;
+        (total + 1, fail, error, warns)
+      | R.Failed_other {msg}, _ ->  (* Failed_other is also considered a failure *)
         print_fail_other ~colors out cell msg;
         (total + 1, fail + 1, error, warns)
-      | R.Error {instance=c_ex; exn; backtrace=bt} ->
+      | R.Error {instance=c_ex; exn; backtrace=bt}, _ -> (* Error is always considered a failure *)
         print_error ~colors out cell c_ex exn bt;
         (total + 1, fail, error + 1, warns)
     in


Test patch:
diff --git a/example/QCheck_runner_test.ml b/example/QCheck_runner_test.ml
index b600e66..64a8dd8 100644
--- a/example/QCheck_runner_test.ml
+++ b/example/QCheck_runner_test.ml
@@ -36,6 +36,16 @@ let stats =
     )
     (fun _ -> true)
 
+
+let neg_test_failing_as_expected =
+  QCheck.Test.make_neg ~name:"neg test pass (failing as expected)" QCheck.small_int (fun i -> i mod 2 = 0)
+
+let neg_test_unexpected_success =
+  QCheck.Test.make_neg ~name:"neg test unexpected success" QCheck.small_int (fun i -> i + i = i * 2)
+
+let neg_test_error =
+  QCheck.Test.make_neg ~name:"neg fail with error" QCheck.small_int (fun _i -> raise Error)
+
 let fun1 =
   QCheck.Test.make ~count:100 ~long_factor:100
     ~name:"FAIL_pred_map_commute"
@@ -182,6 +192,9 @@ let () =
     error;
     collect;
     stats;
+    neg_test_failing_as_expected;
+    neg_test_unexpected_success;
+    neg_test_error;
     fun1;
     fun2;
     prop_foldleft_foldright;
diff --git a/example/alcotest/QCheck_alcotest_test.ml b/example/alcotest/QCheck_alcotest_test.ml
index 3b72c16..adadf42 100644
--- a/example/alcotest/QCheck_alcotest_test.ml
+++ b/example/alcotest/QCheck_alcotest_test.ml
@@ -18,6 +18,15 @@ let error =
     QCheck.int
     (fun _ -> raise Error)
 
+let neg_test_failing_as_expected =
+  QCheck.Test.make_neg ~name:"neg test pass (failing as expected)" QCheck.small_int (fun i -> i mod 2 = 0)
+
+let neg_test_unexpected_success =
+  QCheck.Test.make_neg ~name:"neg test unexpected success" QCheck.small_int (fun i -> i + i = i * 2)
+
+let neg_test_error =
+  QCheck.Test.make_neg ~name:"neg fail with error" QCheck.small_int (fun _i -> raise Error)
+
 let simple_qcheck =
   QCheck.Test.make ~name:"fail_check_err_message"
     ~count: 100
@@ -60,7 +69,9 @@ let () =
   let module A = Alcotest in
   let suite =
     List.map QCheck_alcotest.to_alcotest
-      [ passing; failing; error; simple_qcheck; passing_tree_rev ]
+      [ passing; failing; error;
+        neg_test_failing_as_expected; neg_test_unexpected_success; neg_test_error;
+        simple_qcheck; passing_tree_rev ]
   in
   A.run ~show_errors:true "my test" [
     "suite", suite;
diff --git a/example/alcotest/output.txt.expected b/example/alcotest/output.txt.expected
index 0e04603..ea706c7 100644
--- a/example/alcotest/output.txt.expected
+++ b/example/alcotest/output.txt.expected
@@ -3,8 +3,11 @@ Testing `my test'.
   [OK]          suite              0   list_rev_is_involutive.
   [FAIL]        suite              1   fail_sort_id.
   [FAIL]        suite              2   error_raise_exn.
-  [FAIL]        suite              3   fail_check_err_message.
-  [OK]          suite              4   tree_rev_is_involutive.
+  [OK]          suite              3   neg test pass (failing as expected).
+  [FAIL]        suite              4   neg test unexpected success.
+  [FAIL]        suite              5   neg fail with error.
+  [FAIL]        suite              6   fail_check_err_message.
+  [OK]          suite              7   tree_rev_is_involutive.
   [FAIL]        shrinking          0   debug_shrink.
 ┌──────────────────────────────────────────────────────────────────────────────┐
 │ [FAIL]        suite              1   fail_sort_id.                           │
@@ -23,7 +26,24 @@ raised exception `Error`
 on `0 (after 63 shrink steps)`
  ──────────────────────────────────────────────────────────────────────────────
 ┌──────────────────────────────────────────────────────────────────────────────┐
-│ [FAIL]        suite              3   fail_check_err_message.                 │
+│ [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
+ ──────────────────────────────────────────────────────────────────────────────
+┌──────────────────────────────────────────────────────────────────────────────┐
+│ [FAIL]        suite              5   neg fail with error.                    │
+└──────────────────────────────────────────────────────────────────────────────┘
+test `neg fail with error`
+raised exception `Error`
+on `0 (after 7 shrink steps)`
+[exception] test `neg fail with error`
+raised exception `Error`
+on `0 (after 7 shrink steps)`
+ ──────────────────────────────────────────────────────────────────────────────
+┌──────────────────────────────────────────────────────────────────────────────┐
+│ [FAIL]        suite              6   fail_check_err_message.                 │
 └──────────────────────────────────────────────────────────────────────────────┘
 test `fail_check_err_message` failed on ≥ 1 cases:
 0 (after 7 shrink steps)
@@ -57,4 +77,4 @@ law debug_shrink: 2 relevant cases (2 total)
 test `debug_shrink` failed on ≥ 1 cases: (1, 0) (after 3 shrink steps)
 [exception] test `debug_shrink` failed on ≥ 1 cases: (1, 0) (after 3 shrink steps)
  ──────────────────────────────────────────────────────────────────────────────
-4 failures! 6 tests run.
+6 failures! 9 tests run.
diff --git a/example/ounit/QCheck_ounit_test.ml b/example/ounit/QCheck_ounit_test.ml
index b8e52bb..66bb66b 100644
--- a/example/ounit/QCheck_ounit_test.ml
+++ b/example/ounit/QCheck_ounit_test.ml
@@ -1,3 +1,5 @@
+(* Tests to check integration with the 'OUnit2.test' interface *)
+
 let passing =
   QCheck.Test.make ~count:1000
     ~name:"list_rev_is_involutive"
@@ -24,6 +26,15 @@ let simple_qcheck =
     QCheck.small_int
     (fun _ -> QCheck.Test.fail_reportf "@[<v>this@ will@ always@ fail@]")
 
+let neg_test_failing_as_expected =
+  QCheck.Test.make_neg ~name:"neg test pass (failing as expected)" QCheck.small_int (fun i -> i mod 2 = 0)
+
+let neg_test_unexpected_success =
+  QCheck.Test.make_neg ~name:"neg test unexpected success" QCheck.small_int (fun i -> i + i = i * 2)
+
+let neg_test_error =
+  QCheck.Test.make_neg ~name:"neg fail with error" QCheck.small_int (fun _i -> raise Error)
+
 
 type tree = Leaf of int | Node of tree * tree
 
@@ -55,4 +66,6 @@ let () =
   run_test_tt_main
     ("tests" >:::
      List.map QCheck_ounit.to_ounit2_test
-       [passing; failing; error; simple_qcheck; passing_tree_rev])
+       [passing; failing; error;
+        neg_test_failing_as_expected; neg_test_unexpected_success; neg_test_error;
+        simple_qcheck; passing_tree_rev])
diff --git a/example/ounit/QCheck_test.ml b/example/ounit/QCheck_test.ml
index 1734ca2..76a1cbf 100644
--- a/example/ounit/QCheck_test.ml
+++ b/example/ounit/QCheck_test.ml
@@ -1,3 +1,5 @@
+(* Tests to check integration with the 'OUnit.test' interface *)
+
 let (|>) x f = f x
 
 module Q = QCheck
@@ -22,6 +24,15 @@ let error =
     Q.int
     (fun _ -> raise Error)
 
+let neg_test_failing_as_expected =
+  Q.Test.make_neg ~name:"neg test pass (failing as expected)" QCheck.small_int (fun i -> i mod 2 = 0)
+
+let neg_test_unexpected_success =
+  Q.Test.make_neg ~name:"neg test unexpected success" QCheck.small_int (fun i -> i + i = i * 2)
+
+let neg_test_error =
+  Q.Test.make_neg ~name:"neg fail with error" QCheck.small_int (fun _i -> raise Error)
+
 open OUnit
 
 let regression_23 =
@@ -37,6 +48,9 @@ let others =
   [ passing;
     failing;
     error;
+    neg_test_failing_as_expected;
+    neg_test_unexpected_success;
+    neg_test_error;
   ] |> List.map (fun t -> QCheck_ounit.to_ounit_test t)
 
 let suite =
diff --git a/src/alcotest/QCheck_alcotest.ml b/src/alcotest/QCheck_alcotest.ml
index ea2b71a..0baffa4 100644
--- a/src/alcotest/QCheck_alcotest.ml
+++ b/src/alcotest/QCheck_alcotest.ml
@@ -51,11 +51,17 @@ let to_alcotest
       ()
   in
   let print = Raw.print_std in
-  let run() =
+  let name = T.get_name cell in
+  let run () =
     let call = Raw.callback ~colors ~verbose ~print_res:true ~print in
-    T.check_cell_exn
-      ~long ~call ~handler ~rand
-      cell
+    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) -> ()
   in
-  let name = T.get_name cell in
   ((name, `Slow, run) : unit Alcotest.test_case)
diff --git a/test/core/QCheck2_expect_test.expected b/test/core/QCheck2_expect_test.expected
index bf66c64..c317182 100644
--- a/test/core/QCheck2_expect_test.expected
+++ b/test/core/QCheck2_expect_test.expected
@@ -260,6 +260,30 @@ ERROR: uncaught exception in generator for test FAIL_bad_gen after 100 steps:
 Exception: Invalid_argument("Gen.int_bound")
 Backtrace: 
 
+--- Failure --------------------------------------------------------------------
+
+Test int double failed:
+
+Negative test int double succeeded but was expected to fail
+
+=== Error ======================================================================
+
+Test pos fail with error errored on (1 shrink steps):
+
+0
+
+exception QCheck2_tests.Overall.Error
+
+
+=== Error ======================================================================
+
+Test neg fail with error errored on (1 shrink steps):
+
+0
+
+exception QCheck2_tests.Overall.Error
+
+
 --- Failure --------------------------------------------------------------------
 
 Test char never produces '\255' failed (0 shrink steps):
@@ -1250,7 +1274,7 @@ stats dist:
    4150517416584649600.. 4611686018427387903: #################                                               189
 ================================================================================
 1 warning(s)
-failure (57 tests failed, 1 tests errored, ran 122 tests)
+failure (58 tests failed, 3 tests errored, ran 127 tests)
 random seed: 153870556
 
 +++ Stats for int_dist_empty_bucket ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
diff --git a/test/core/QCheck2_tests.ml b/test/core/QCheck2_tests.ml
index d3c960e..f9c07e5 100644
--- a/test/core/QCheck2_tests.ml
+++ b/test/core/QCheck2_tests.ml
@@ -101,6 +101,22 @@ module Overall = struct
         ~gen:(fun rs -> Random.State.int rs))
       (fun _i -> false)
 
+  let neg_test_fail_as_expected =
+    Test.make_neg ~name:"all ints are even" ~print:Print.int Gen.small_int (fun i -> i mod 2 = 0)
+
+  let neg_test_unexpected_success =
+    Test.make_neg ~name:"int double" ~print:Print.int Gen.small_int (fun i -> i + i = i * 2)
+
+  let neg_test_fail_with_shrinking =
+    Test.make_neg ~name:"list rev concat" ~print:Print.(pair (list int) (list int))
+      Gen.(pair (list small_int) (list small_int)) (fun (is,js) -> (List.rev is)@(List.rev js) = List.rev (is@js))
+
+  let pos_test_fails_with_error =
+    Test.make ~name:"pos fail with error" ~print:Print.int Gen.small_int (fun _i -> raise Error)
+
+  let neg_test_fail_with_error =
+    Test.make_neg ~name:"neg fail with error" ~print:Print.int Gen.small_int (fun _i -> raise Error)
+
   (* [apply_n f x n] computes f(f(...f(x))) with n applications of f *)
   let rec apply_n f x n =
     if n=0
@@ -134,6 +150,11 @@ module Overall = struct
     bad_assume_fail;
     bad_gen_fail;
     (*bad_shrinker_fail;*)
+    neg_test_fail_as_expected;
+    neg_test_unexpected_success;
+    neg_test_fail_with_shrinking;
+    pos_test_fails_with_error;
+    neg_test_fail_with_error;
     (* we repeat the following multiple times to check the expected output for duplicate lines *)
     bad_fun_repro;
     bad_fun_repro;
diff --git a/test/core/QCheck_expect_test.expected b/test/core/QCheck_expect_test.expected
index 5bb3d29..2d3d7f0 100644
--- a/test/core/QCheck_expect_test.expected
+++ b/test/core/QCheck_expect_test.expected
@@ -198,6 +198,30 @@ ERROR: uncaught exception in generator for test FAIL_bad_gen after 100 steps:
 Exception: Invalid_argument("Gen.int_bound")
 Backtrace: 
 
+--- Failure --------------------------------------------------------------------
+
+Test int double failed:
+
+Negative test int double succeeded but was expected to fail
+
+=== Error ======================================================================
+
+Test pos fail with error errored on (7 shrink steps):
+
+0
+
+exception QCheck_tests.Overall.Error
+
+
+=== Error ======================================================================
+
+Test neg fail with error errored on (7 shrink steps):
+
+0
+
+exception QCheck_tests.Overall.Error
+
+
 --- Failure --------------------------------------------------------------------
 
 Test char never produces '\255' failed (0 shrink steps):
@@ -1214,7 +1238,7 @@ stats dist:
    4150517416584649600.. 4611686018427387903: #################                                               189
 ================================================================================
 1 warning(s)
-failure (57 tests failed, 1 tests errored, ran 129 tests)
+failure (58 tests failed, 3 tests errored, ran 134 tests)
 random seed: 153870556
 
 +++ Stats for int_dist_empty_bucket ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
diff --git a/test/core/QCheck_tests.ml b/test/core/QCheck_tests.ml
index 558d884..e00dd07 100644
--- a/test/core/QCheck_tests.ml
+++ b/test/core/QCheck_tests.ml
@@ -111,6 +111,22 @@ module Overall = struct
          Gen.int)
       (fun _i -> false)
 
+  let neg_test_fail_as_expected =
+    Test.make_neg ~name:"all ints are even" small_int (fun i -> i mod 2 = 0)
+
+  let neg_test_unexpected_success =
+    Test.make_neg ~name:"int double" small_int (fun i -> i + i = i * 2)
+
+  let neg_test_fail_with_shrinking =
+    Test.make_neg ~name:"list rev concat"
+      (pair (list small_int) (list small_int)) (fun (is,js) -> (List.rev is)@(List.rev js) = List.rev (is@js))
+
+  let pos_test_fails_with_error =
+    Test.make ~name:"pos fail with error" small_int (fun _i -> raise Error)
+
+  let neg_test_fail_with_error =
+    Test.make_neg ~name:"neg fail with error" small_int (fun _i -> raise Error)
+
   (* [apply_n f x n] computes f(f(...f(x))) with n applications of f *)
   let rec apply_n f x n =
     if n=0
@@ -144,6 +160,11 @@ module Overall = struct
     bad_assume_fail;
     bad_gen_fail;
     (*bad_shrinker_fail;*)
+    neg_test_fail_as_expected;
+    neg_test_unexpected_success;
+    neg_test_fail_with_shrinking;
+    pos_test_fails_with_error;
+    neg_test_fail_with_error;
     (* we repeat the following multiple times to check the expected output for duplicate lines *)
     bad_fun_repro;
     bad_fun_repro;
diff --git a/test/core/shrink_benchmark.ml b/test/core/shrink_benchmark.ml
index 50b536c..322ce5d 100644
--- a/test/core/shrink_benchmark.ml
+++ b/test/core/shrink_benchmark.ml
@@ -104,9 +104,7 @@ let rec merge_and_validate xs ys = match xs,ys with
   | t1::xs,t2::ys ->
     if get_name t1 = get_name t2
     then (t1,t2) :: merge_and_validate xs ys
-    else
-      let msg = Printf.sprintf "Found \"%s\" and \"%s\". Are QCheck_tests.Shrink and QCheck2_tests.Shrink not in the same order?" (get_name t1) (get_name t2) in
-      failwith msg
+    else failwith "QCheck_tests.Shrink and QCheck2_tests.Shrink are not in the same order"
 
 let seeds = [1234;(*4321;*)8743;(*9876;*)6789;
              (*2143*) (* ouch: seed 2143 causes test "lists equal to duplication" to segfault *)