Add missing QCheck2 float tests and fix QCheck2.Gen.exponential shrinker

CHANGELOG.md

@@ -83,6 +83,7 @@
   - Add missing `QCheck.Gen.ap` for consistency
 - Add missing `QCheck2.Gen.map_keep_input` for consistency
 - Add `QCheck.no_shrink` for consistency
+- Fix shrinking for `QCheck2.Gen.exponential` which could shrink to `infinity`
 
 
 ## 0.27 (2025-10-31)

src/core/QCheck2.ml

@@ -368,6 +368,18 @@ module Gen = struct
   let make_primitive ~(gen : RS.t -> 'a) ~(shrink : 'a -> 'a Seq.t) : 'a t = fun st ->
     Tree.make_primitive shrink (gen st)
 
+  let delay (f : unit -> 'a t) : 'a t = fun st -> f () st
+
+  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 parse_origin (loc : string) (pp : Format.formatter -> 'a -> unit) ~(origin : 'a) ~(low : 'a) ~(high : 'a) : 'a =
     if origin < low then invalid_arg Format.(asprintf "%s: origin value %a is lower than low value %a" loc pp origin pp low)
     else if origin > high then invalid_arg Format.(asprintf "%s: origin value %a is greater than high value %a" loc pp origin pp high)
@@ -478,8 +490,9 @@ module Gen = struct
 
   let float_exp (mean : float) =
     if Float.is_nan mean then invalid_arg "Gen.float_exp";
-    let unit_gen = float_bound_inclusive 1.0 in
-    map (fun p -> -. mean *. (log p)) unit_gen
+    let unit_gen = no_shrink (float_bound_inclusive 1.0) in
+    let exp_gen = map (fun p -> -. mean *. (log p)) unit_gen in
+    set_shrink (Shrink.float_towards 0.) exp_gen
     (* See https://en.wikipedia.org/wiki/Relationships_among_probability_distributions *)
 
   let exponential = float_exp
@@ -930,18 +943,6 @@ module Gen = struct
   let generate_tree ?(rand=RS.make_self_init()) (gen : 'a t) : 'a Tree.t =
     gen rand
 
-  let delay (f : unit -> 'a t) : 'a t = fun st -> f () st
-
-  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

test/core/QCheck2_expect_test.expected.ocaml4.32

@@ -347,6 +347,132 @@ Test float >= -1e10 failed (722 shrink steps):
 
 --- Failure --------------------------------------------------------------------
 
+Test float is not nan failed (0 shrink steps):
+
+-nan
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_inclusive 1e6 <= 10. failed (25 shrink steps):
+
+10.0001936411
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_inclusive 1e6 <= pi failed (24 shrink steps):
+
+3.14176318497
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_inclusive 1. <= 0.5 failed (8 shrink steps):
+
+0.500002807691
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_inclusive 1. <= min_float failed (1029 shrink steps):
+
+2.22508635315e-308
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_inclusive -1. >= -0.5 failed (8 shrink steps):
+
+-0.500002807691
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_inclusive -1e6 >= -.pi failed (24 shrink steps):
+
+-3.14176318497
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_exclusive 1e6 <= 10. failed (25 shrink steps):
+
+10.0001936411
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_exclusive 1e6 <= pi failed (24 shrink steps):
+
+3.14176318497
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_exclusive 1. <= 0.5 failed (8 shrink steps):
+
+0.500002807691
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_exclusive 1. <= min_float failed (1029 shrink steps):
+
+2.22508635315e-308
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_exclusive -1. >= -0.5 failed (8 shrink steps):
+
+-0.500002807691
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_exclusive -1e6 >= -.pi failed (24 shrink steps):
+
+-3.14176318497
+
+--- Failure --------------------------------------------------------------------
+
+Test float_range 1. 10. <= pi failed (8 shrink steps):
+
+3.14168329529
+
+--- Failure --------------------------------------------------------------------
+
+Test (float_range -10. 10.)^2 <= 2. failed (8 shrink steps):
+
+1.41429229241
+
+--- Failure --------------------------------------------------------------------
+
+Test float_range -10. -1. >= -.pi failed (7 shrink steps):
+
+-3.14165050694
+
+--- Failure --------------------------------------------------------------------
+
+Test float_pos < Float.pi failed (753 shrink steps):
+
+3.14167586353
+
+--- Failure --------------------------------------------------------------------
+
+Test float_pos is not nan failed (0 shrink steps):
+
+nan
+
+--- Failure --------------------------------------------------------------------
+
+Test float_neg > Float.pi failed (753 shrink steps):
+
+-3.14167586353
+
+--- Failure --------------------------------------------------------------------
+
+Test float_neg is not nan failed (0 shrink steps):
+
+-nan
+
+--- Failure --------------------------------------------------------------------
+
+Test float_exp 10. < Float.pi failed (6 shrink steps):
+
+3.1417780719
+
+--- Failure --------------------------------------------------------------------
+
 Test char never produces 'abcdef' failed (1 shrink steps):
 
 'a'
@@ -1889,7 +2015,7 @@ Collect results for test float classify:
  FP_nan:            2 cases   (0.0%)
 ================================================================================
 1 warning(s)
-failure (83 tests failed, 3 tests errored, ran 184 tests)
+failure (104 tests failed, 3 tests errored, ran 208 tests)
 random seed: 153870556
 
 +++ Stats for int_dist_empty_bucket ++++++++++++++++++++++++++++++++++++++++++++++++++++++++

test/core/QCheck2_expect_test.expected.ocaml4.64

@@ -409,6 +409,132 @@ Test float >= -1e10 failed (722 shrink steps):
 
 --- Failure --------------------------------------------------------------------
 
+Test float is not nan failed (0 shrink steps):
+
+-nan
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_inclusive 1e6 <= 10. failed (25 shrink steps):
+
+10.0001936411
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_inclusive 1e6 <= pi failed (24 shrink steps):
+
+3.14176318497
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_inclusive 1. <= 0.5 failed (8 shrink steps):
+
+0.500002807691
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_inclusive 1. <= min_float failed (1029 shrink steps):
+
+2.22508635315e-308
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_inclusive -1. >= -0.5 failed (8 shrink steps):
+
+-0.500002807691
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_inclusive -1e6 >= -.pi failed (24 shrink steps):
+
+-3.14176318497
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_exclusive 1e6 <= 10. failed (25 shrink steps):
+
+10.0001936411
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_exclusive 1e6 <= pi failed (24 shrink steps):
+
+3.14176318497
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_exclusive 1. <= 0.5 failed (8 shrink steps):
+
+0.500002807691
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_exclusive 1. <= min_float failed (1029 shrink steps):
+
+2.22508635315e-308
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_exclusive -1. >= -0.5 failed (8 shrink steps):
+
+-0.500002807691
+
+--- Failure --------------------------------------------------------------------
+
+Test float_bound_exclusive -1e6 >= -.pi failed (24 shrink steps):
+
+-3.14176318497
+
+--- Failure --------------------------------------------------------------------
+
+Test float_range 1. 10. <= pi failed (8 shrink steps):
+
+3.14168329529
+
+--- Failure --------------------------------------------------------------------
+
+Test (float_range -10. 10.)^2 <= 2. failed (8 shrink steps):
+
+1.41429229241
+
+--- Failure --------------------------------------------------------------------
+
+Test float_range -10. -1. >= -.pi failed (7 shrink steps):
+
+-3.14165050694
+
+--- Failure --------------------------------------------------------------------
+
+Test float_pos < Float.pi failed (753 shrink steps):
+
+3.14167586353
+
+--- Failure --------------------------------------------------------------------
+
+Test float_pos is not nan failed (0 shrink steps):
+
+nan
+
+--- Failure --------------------------------------------------------------------
+
+Test float_neg > Float.pi failed (753 shrink steps):
+
+-3.14167586353
+
+--- Failure --------------------------------------------------------------------
+
+Test float_neg is not nan failed (0 shrink steps):
+
+-nan
+
+--- Failure --------------------------------------------------------------------
+
+Test float_exp 10. < Float.pi failed (6 shrink steps):
+
+3.1417780719
+
+--- Failure --------------------------------------------------------------------
+
 Test char never produces 'abcdef' failed (1 shrink steps):
 
 'a'
@@ -1953,7 +2079,7 @@ Collect results for test float classify:
  FP_nan:            2 cases   (0.0%)
 ================================================================================
 1 warning(s)
-failure (83 tests failed, 3 tests errored, ran 184 tests)
+failure (104 tests failed, 3 tests errored, ran 208 tests)
 random seed: 153870556
 
 +++ Stats for int_dist_empty_bucket ++++++++++++++++++++++++++++++++++++++++++++++++++++++++