Shrinker improvements

example/alcotest/output.txt.expected

@@ -9,30 +9,30 @@ Testing `my test'.
 ┌──────────────────────────────────────────────────────────────────────────────┐
 │ [FAIL]        suite              1   fail_sort_id.                           │
 └──────────────────────────────────────────────────────────────────────────────┘
-test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 20 shrink steps)
-[exception] test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 20 shrink steps)
+test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 11 shrink steps)
+[exception] test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 11 shrink steps)
  ──────────────────────────────────────────────────────────────────────────────
 ┌──────────────────────────────────────────────────────────────────────────────┐
 │ [FAIL]        suite              2   error_raise_exn.                        │
 └──────────────────────────────────────────────────────────────────────────────┘
 test `error_raise_exn`
 raised exception `Error`
-on `0 (after 63 shrink steps)`
+on `0 (after 1 shrink steps)`
 [exception] test `error_raise_exn`
 raised exception `Error`
-on `0 (after 63 shrink steps)`
+on `0 (after 1 shrink steps)`
  ──────────────────────────────────────────────────────────────────────────────
 ┌──────────────────────────────────────────────────────────────────────────────┐
 │ [FAIL]        suite              3   fail_check_err_message.                 │
 └──────────────────────────────────────────────────────────────────────────────┘
 test `fail_check_err_message` failed on ≥ 1 cases:
-0 (after 7 shrink steps)
+0 (after 1 shrink steps)
 this
 will
 always
 fail
 [exception] test `fail_check_err_message` failed on ≥ 1 cases:
-0 (after 7 shrink steps)
+0 (after 1 shrink steps)
 this
 will
 always
@@ -46,15 +46,9 @@ Test debug_shrink successfully shrunk counter example (step 0) to:
 (3, 1)
 ~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Test debug_shrink successfully shrunk counter example (step 1) to:
-(2, 1)
-~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Test debug_shrink successfully shrunk counter example (step 2) to:
-(2, 0)
-~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Test debug_shrink successfully shrunk counter example (step 3) to:
-(1, 0)
+(0, 1)
 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)
+test `debug_shrink` failed on ≥ 1 cases: (0, 1) (after 1 shrink steps)
+[exception] test `debug_shrink` failed on ≥ 1 cases: (0, 1) (after 1 shrink steps)
  ──────────────────────────────────────────────────────────────────────────────
 4 failures! 6 tests run.

example/ounit/output.txt.expected

@@ -6,7 +6,7 @@ Error: tests:2:error_raise_exn (in the log).
 
 
 test `error_raise_exn` raised exception `Dune__exe__QCheck_ounit_test.Error`
-on `0 (after 63 shrink steps)`
+on `0 (after 1 shrink steps)`
 
 ------------------------------------------------------------------------------
 ==============================================================================
@@ -18,7 +18,7 @@ Error: tests:3:fail_check_err_message (in the code).
 
 
 test `fail_check_err_message` failed on ≥ 1 cases:
-0 (after 7 shrink steps)
+0 (after 1 shrink steps)
 this
 will
 always
@@ -35,7 +35,7 @@ Error: tests:1:fail_sort_id (in the log).
 Error: tests:1:fail_sort_id (in the code).
 
 
-test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 20 shrink steps)
+test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 11 shrink steps)
 
 
 ------------------------------------------------------------------------------

example/output.txt.expected

@@ -2,13 +2,13 @@ random seed: 1234
 
 --- Failure --------------------------------------------------------------------
 
-Test should_fail_sort_id failed (18 shrink steps):
+Test should_fail_sort_id failed (11 shrink steps):
 
 [1; 0]
 
 === Error ======================================================================
 
-Test should_error_raise_exn errored on (63 shrink steps):
+Test should_error_raise_exn errored on (1 shrink steps):
 
 0
 
@@ -59,9 +59,9 @@ stats num:
 
 --- Failure --------------------------------------------------------------------
 
-Test FAIL_pred_map_commute failed (107 shrink steps):
+Test FAIL_pred_map_commute failed (116 shrink steps):
 
-([0], {_ -> -21}, {-21 -> true; _ -> false})
+([0], {0 -> -1; _ -> 0}, {0 -> true; _ -> false})
 
 --- Failure --------------------------------------------------------------------
 
@@ -71,34 +71,34 @@ Test FAIL_fun2_pred_strings failed (1 shrink steps):
 
 --- Failure --------------------------------------------------------------------
 
-Test fold_left fold_right failed (24 shrink steps):
+Test fold_left fold_right failed (15 shrink steps):
 
-(0, [1], {(1, 0) -> 1; _ -> 0})
+(0, [1], {(0, 1) -> 1; _ -> 0})
 
 +++ Messages ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
 Messages for test fold_left fold_right:
 
-l=[1], fold_left=1, fold_right=0
+l=[1], fold_left=0, fold_right=1
 
 
 --- Failure --------------------------------------------------------------------
 
-Test fold_left fold_right uncurried failed (97 shrink steps):
+Test fold_left fold_right uncurried failed (39 shrink steps):
 
-({(1, 7) -> 0; _ -> 7}, 0, [1; 0])
+({(0, 7) -> 1; _ -> 0}, 0, [7])
 
 --- Failure --------------------------------------------------------------------
 
-Test long_shrink failed (149 shrink steps):
+Test long_shrink failed (89 shrink steps):
 
 ([0], [-1])
 
 --- Failure --------------------------------------------------------------------
 
-Test mod3_should_fail failed (84 shrink steps):
+Test mod3_should_fail failed (1 shrink steps):
 
--21
+0
 
 +++ Stats for stats_neg ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 

src/core/QCheck.ml

@@ -650,14 +650,17 @@ module Shrink = struct
 
   let unit = nil
 
-  (* balanced shrinker for integers (non-exhaustive) *)
+  (* inspired by QCheck2's int shrinker algorithm (non-exhaustive) *)
   let int x yield =
-    let y = ref x in
+    let curr = ref 0 in (*to return 0 repeatedly *)  (*was: let curr = ref (x/2) *)
     (* try some divisors *)
-    while !y < -2 || !y >2 do y := !y / 2; yield (x - !y); done; (* fast path *)
-    if x>0 then yield (x-1);
-    if x<0 then yield (x+1);
-    ()
+    while !curr <> x do
+      yield !curr;
+      let half_diff = (x - !curr)/2 in (*was: let half_diff = (x/2) - (!curr/2) in *)
+      if half_diff = 0
+      then curr := x
+      else curr := !curr + half_diff
+    done
 
   let int32 x yield =
     let open Int32 in
@@ -694,14 +697,6 @@ module Shrink = struct
     | None -> Iter.empty
     | Some x -> Iter.(return None <+> map (fun y->Some y) (s x))
 
-  let string s yield =
-    for i =0 to String.length s-1 do
-      let s' = Bytes.init (String.length s-1)
-        (fun j -> if j<i then s.[j] else s.[j+1])
-      in
-      yield (Bytes.unsafe_to_string s')
-    done
-
   let array ?shrink a yield =
     let n = Array.length a in
     let chunk_size = ref n in
@@ -727,37 +722,20 @@ module Shrink = struct
           )
         done
 
-  let list_spine l yield =
-    let n = List.length l in
-    let chunk_size = ref ((n+1)/2) in
-
-    (* push the [n] first elements of [l] into [q], return the rest of the list *)
-    let rec fill_queue n l q = match n,l with
-      | 0, _ -> l
-      | _, x::xs ->
-        Queue.push x q;
-        fill_queue (n-1) xs q
-      | _, _ -> assert false
-    in
-
-    (* remove elements from the list, by chunks of size [chunk_size] (bigger
-       chunks first) *)
-    while !chunk_size > 0 do
-      let q = Queue.create () in
-      let l' = fill_queue !chunk_size l q in
-      (* remove [chunk_size] elements in queue *)
-      let rec pos_loop rev_prefix suffix =
-        yield (List.rev_append rev_prefix suffix);
-        match suffix with
-        | [] -> ()
-        | x::xs ->
-          Queue.push x q;
-          let y = Queue.pop q in
-          (pos_loop [@tailcall]) (y::rev_prefix) xs
-      in
-      pos_loop [] l';
-      chunk_size := !chunk_size / 2;
-    done
+  let rec list_spine l yield =
+    let rec split l len acc = match len,l with
+      | _,[]
+      | 0,_ -> List.rev acc, l
+      | _,x::xs -> split xs (len-1) (x::acc) in
+    match l with
+    | [] -> ()
+    | [_] -> yield []
+    | [x;y] -> yield []; yield [x]; yield [y]
+    | _::_ ->
+      let len = List.length l in
+      let xs,ys = split l ((1 + len) / 2) [] in
+          yield xs;
+          list_spine xs (fun xs' -> yield (xs'@ys))
 
   let list_elems shrink l yield =
     (* try to shrink each element of the list *)
@@ -775,6 +753,11 @@ module Shrink = struct
     | None -> ()
     | Some shrink -> list_elems shrink l yield
 
+  let string (*?(shrink=char)*) s yield =
+    list ~shrink:char
+      (List.of_seq (String.to_seq s))
+      (fun cs -> yield (String.of_seq (List.to_seq cs)))
+
   let pair a b (x,y) yield =
     a x (fun x' -> yield (x',y));
     b y (fun y' -> yield (x,y'))
@@ -1348,7 +1331,7 @@ end = struct
             tbl;
         Buffer.contents b);
       p_shrink1=(fun yield ->
-        Shrink.list (tbl_to_list tbl)
+        Shrink.list_spine (tbl_to_list tbl)
           (fun l ->
              yield (make ~extend:false (tbl_of_list l)))
       );
@@ -1419,9 +1402,9 @@ module Fn = struct
       = function
         | Fun_tbl {fun_arb=a; fun_tbl=tbl; fun_default=def} ->
           let sh_v = match a.shrink with None -> Shrink.nil | Some s->s in
-          (Poly_tbl.shrink1 tbl >|= fun tbl' -> mk_repr tbl' a def)
-          <+>
             (sh_v def >|= fun def' -> mk_repr tbl a def')
+          <+>
+            (Poly_tbl.shrink1 tbl >|= fun tbl' -> mk_repr tbl' a def)
           <+>
             (Poly_tbl.shrink2 sh_v tbl >|= fun tbl' -> mk_repr tbl' a def)
         | Fun_map (g, r') ->