Repository: c-cube/qcheck (ocaml)

Issue:
Disable QCheck2 shrinker with a parameter
That'd be cool to disable the shrinker with a boolean in `Test.make` for instance. I don't know if we can already do this or if it's impossible but this might be a really good feature.

It can happen that the test is wrong and since the generated value is really not-trivial, it takes a lot of time to shrink.

Pull request description:
Add [no_shrink] to [QCheck2.Gen]
Closes #232.

I don't know if that's the most convenient solution, but it seems to work. If you have any suggestion to improve this function, I'd be happy to implement it.

Patch:
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 7ea87d5..463f1d0 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,7 +1,11 @@
 # Changes
 
+## 0.20
+
 - add an optional argument with conservative default to `Shrink.string`
 - fix shrinkers in `QCheck.{printable_string,printable_string_of_size,small_printable_string,numeral_string,numeral_string_of_size}` [#257](https://github.com/c-cube/qcheck/issues/257)
+- add `QCheck2.Gen.set_shrink` to modify the generator's shrinker
+- add `QCheck2.Gen.no_shrink` to build a generator with no shrinking
 
 ## 0.19.1
 
diff --git a/src/core/QCheck2.ml b/src/core/QCheck2.ml
index 0a4f1b3..ec34657 100644
--- a/src/core/QCheck2.ml
+++ b/src/core/QCheck2.ml
@@ -750,6 +750,13 @@ module Gen = struct
   let add_shrink_invariant (p : 'a -> bool) (gen : 'a t) : 'a t =
     fun st -> gen st |> Tree.add_shrink_invariant p
 
+  let set_shrink shrink gen =
+    make_primitive
+      ~gen:(fun st -> gen st |> Tree.root)
+      ~shrink
+  
+  let no_shrink (gen: 'a t) : 'a t = set_shrink (fun _ -> Seq.empty) gen
+
   let (let+) = (>|=)
 
   let (and+) = pair
diff --git a/src/core/QCheck2.mli b/src/core/QCheck2.mli
index fee3fd9..f5810ea 100644
--- a/src/core/QCheck2.mli
+++ b/src/core/QCheck2.mli
@@ -373,6 +373,13 @@ module Gen : sig
       keep it and wait for users feedback (hence deprecation to raise attention).
   *)
 
+  val set_shrink : ('a -> 'a Seq.t) -> 'a t -> 'a t
+  (** [set_shrink shrink gen] sets the shrinker to [shrink] for [gen]. *)
+
+  val no_shrink : 'a t -> 'a t
+  (** [no_shrink gen] returns a generator using [gen] but with shrinking
+      disabled *)
+
   (** {3 Ranges} *)
 
   val int_bound : int -> int t


Test patch:
diff --git a/test/core/QCheck2_expect_test.expected.64 b/test/core/QCheck2_expect_test.expected.64
index 08c67ba..803bc65 100644
--- a/test/core/QCheck2_expect_test.expected.64
+++ b/test/core/QCheck2_expect_test.expected.64
@@ -568,6 +568,12 @@ Leaf 0
 
 --- Failure --------------------------------------------------------------------
 
+Test sum list = 0 failed (0 shrink steps):
+
+[7; 1; 42; 1; 8; 5; 3; 9; 5; 38; 3; 3; 0; 1; 98; 1; 4; 13; 9; 2; 6; 9; 47; 6; 5; 8; 8; 6; 0; 9; 7; 2; 8; 6; 62; 6; 4; 31; 19; 1; 41; 60; 6; 5; 8; 1; 1; 4; 7; 7; 0; 5; 5; 71; 14; 26; 47; 5; 1; 6; 34; 9; 4; 2; 37; 3; 8; 4; 31; 6; 2; 1; 0; 7; 5; 1; 0; 15; 6; 1; 8; 13; 0; 6; 2; 4; 2; 6; 6; 1; 4; 1; 9; 79; 0; 87; 6; 8; 8; 62; 1; 4; 62; 6; 31; 1; 5; 6; 5; 9; 3; 3; 1; 79; 4; 3; 2; 67; 5; 7; 12; 70; 8; 8; 6; 1; 3; 14; 15; 1; 61; 4; 1; 4; 1; 7; 4; 4; 4; 2; 8; 8; 7; 5; 4; 27; 0; 9; 80; 25; 1; 8; 1; 3; 7; 4; 3; 5; 5; 6; 5; 5; 31; 7; 0; 3; 3; 6; 71; 76; 28; 60; 6; 2; 6; 3; 0; 4; 1; 0; 5; 7; 0; 28; 86; 4; 7; 51; 36; 0; 5; 0; 1; 4; 3; 6; 0; 1; 1; 8; 18; 4; 2; 8; 8; 1; 4; 7; 1; 0; 93; 5; 3; 0; 80; 1; 7; 7; 8; 8; 5; 7; 8; 9; 24; 4; 25; 8; 8; 5; 4; 90; 4; 6; 8; 4; 4; 0; 60; 8; 9; 7; 44; 5; 1; 2; 9; 74; 7; 7]
+
+--- Failure --------------------------------------------------------------------
+
 Test fail_pred_map_commute failed (122 shrink steps):
 
 ([0], {0 -> 1; 2 -> 0; 20 -> 0; 4 -> 0; 54 -> 0; 6 -> 0; 8 -> 0; 60 -> 0; 12 -> 0; _ -> 0}, {0 -> true; -1487654178632829215 -> false; -2792235260416531278 -> false; 2 -> false; 3324124342680534771 -> false; 20 -> false; 4 -> false; -2849913598173370635 -> false; 54 -> false; 6 -> false; 8 -> false; 815755449952469177 -> false; 4035005642433201833 -> false; -2961585594425353332 -> false; 60 -> false; 12 -> false; 3780670741311086221 -> false; _ -> false})
@@ -1320,7 +1326,7 @@ stats dist:
    4150517416584649600.. 4611686018427387903: #################                                               189
 ================================================================================
 1 warning(s)
-failure (59 tests failed, 3 tests errored, ran 130 tests)
+failure (60 tests failed, 3 tests errored, ran 131 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 118c8bb..ab6c78f 100644
--- a/test/core/QCheck2_tests.ml
+++ b/test/core/QCheck2_tests.ml
@@ -588,6 +588,11 @@ module Shrink = struct
       IntTree.gen_tree
       (fun tree -> IntTree.contains_only_n tree 42)
 
+  let test_gen_no_shrink =
+    Test.make ~name:"sum list = 0" ~print:Print.(list int)
+      Gen.(no_shrink @@ list small_int)
+      (fun xs -> List.fold_left (+) 0 xs = 0)
+
   let tests = [
     (*test_fac_issue59;*)
     big_bound_issue59;
@@ -637,6 +642,7 @@ module Shrink = struct
     (*list_equal_dupl;*)
     list_unique_elems;
     tree_contains_only_42;
+    test_gen_no_shrink;
   ]
 end