Shrinker improvements to QCheck list, string, and function

CHANGELOG.md

@@ -25,6 +25,11 @@
 
 - add a shrinker performance benchmark [#177](https://github.com/c-cube/qcheck/pull/177)
 
+- shrinker changes
+  - recursive list shrinker with better complexity
+  - string shrinker reuses improved list shrinker and adds char shrinking
+  - function shrinker now shrinks default entry first and benefits from list shrinker improvements
+
 - documentation updates:
   - clarify upper bound inclusion in `Gen.int_bound` and `Gen.int_range`
   - clarify `printable_char` and `Gen.printable` distributions

example/alcotest/output.txt.expected

@@ -9,8 +9,8 @@ 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.                        │

example/ounit/output.txt.expected

@@ -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,7 +2,7 @@ random seed: 1234
 
 --- Failure --------------------------------------------------------------------
 
-Test should_fail_sort_id failed (18 shrink steps):
+Test should_fail_sort_id failed (13 shrink steps):
 
 [1; 0]
 
@@ -59,9 +59,9 @@ stats num:
 
 --- Failure --------------------------------------------------------------------
 
-Test FAIL_pred_map_commute failed (107 shrink steps):
+Test FAIL_pred_map_commute failed (77 shrink steps):
 
-([0], {_ -> -21}, {-21 -> true; _ -> false})
+([1], {_ -> 0}, {1 -> true; _ -> false})
 
 --- Failure --------------------------------------------------------------------
 
@@ -71,7 +71,7 @@ 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 (34 shrink steps):
 
 (0, [1], {(1, 0) -> 1; _ -> 0})
 
@@ -84,9 +84,9 @@ l=[1], fold_left=1, fold_right=0
 
 --- Failure --------------------------------------------------------------------
 
-Test fold_left fold_right uncurried failed (97 shrink steps):
+Test fold_left fold_right uncurried failed (44 shrink steps):
 
-({(1, 7) -> 0; _ -> 7}, 0, [1; 0])
+({(0, 7) -> 1; _ -> 0}, 0, [7])
 
 --- Failure --------------------------------------------------------------------
 

src/core/QCheck.ml

@@ -694,14 +694,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 +719,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 +750,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 +1328,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 +1399,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') ->

test/core/QCheck_expect_test.expected

@@ -72,12 +72,14 @@ random seed: 1234
 1
 0
 [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]
-[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]
-[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]
-[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]
-[4; 4; 0; 60; 8; 9; 7; 44; 5; 1; 2; 9; 74; 7; 7]
-[5; 1; 2; 9; 74; 7; 7]
-[74; 7; 7]
+[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]
+[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]
+[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]
+[7; 1; 42; 1; 8; 5; 3; 9; 5; 38; 3; 3; 0; 1; 98; 1]
+[7; 1; 42; 1; 8; 5; 3; 9]
+[7; 1; 42; 1]
+[7; 1]
+[]
 [7]
 []
 [4]
@@ -89,27 +91,28 @@ random seed: 1234
 [0]
 []
 [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]
-[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]
-[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]
-[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]
-[4; 4; 0; 60; 8; 9; 7; 44; 5; 1; 2; 9; 74; 7; 7]
-[5; 1; 2; 9; 74; 7; 7]
-[74; 7; 7]
-[7]
-[74]
-[7; 7]
-[7]
-[7]
-[4; 7]
-[6; 7]
-[6; 7]
-[7; 4]
-[7; 6]
-[7; 6]
+[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]
+[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]
+[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]
+[7; 1; 42; 1; 8; 5; 3; 9; 5; 38; 3; 3; 0; 1; 98; 1]
+[7; 1; 42; 1; 8; 5; 3; 9]
+[7; 1; 42; 1]
+[7; 1]
+[42; 1]
+[7; 42; 1]
+[1; 42; 1]
+[1; 42]
+[1]
+[1; 1]
+[]
+[1]
+[1]
+[0; 1]
+[1; 0]
 
 --- Failure --------------------------------------------------------------------
 
-Test should_fail_sort_id failed (18 shrink steps):
+Test should_fail_sort_id failed (13 shrink steps):
 
 [1; 0]
 
@@ -245,27 +248,27 @@ Test char never produces 'abcdef' failed (0 shrink steps):
 
 --- Failure --------------------------------------------------------------------
 
-Test strings are empty failed (249 shrink steps):
+Test strings are empty failed (145 shrink steps):
 
-"\177"
+"\000"
 
 --- Failure --------------------------------------------------------------------
 
-Test string never has a \000 char failed (25 shrink steps):
+Test string never has a \000 char failed (8 shrink steps):
 
 "\000"
 
 --- Failure --------------------------------------------------------------------
 
-Test string never has a \255 char failed (249 shrink steps):
+Test string never has a \255 char failed (14 shrink steps):
 
 "\255"
 
 --- Failure --------------------------------------------------------------------
 
-Test strings have unique chars failed (248 shrink steps):
+Test strings have unique chars failed (13 shrink steps):
 
-"\206\206"
+"\129\129"
 
 --- Failure --------------------------------------------------------------------
 
@@ -311,13 +314,13 @@ Test pairs sum to less than 128 failed (116 shrink steps):
 
 --- Failure --------------------------------------------------------------------
 
-Test pairs lists rev concat failed (140 shrink steps):
+Test pairs lists rev concat failed (147 shrink steps):
 
 ([0], [1])
 
 --- Failure --------------------------------------------------------------------
 
-Test pairs lists no overlap failed (22 shrink steps):
+Test pairs lists no overlap failed (26 shrink steps):
 
 ([0], [0])
 
@@ -425,25 +428,25 @@ Test bind ordered pairs failed (125 shrink steps):
 
 --- Failure --------------------------------------------------------------------
 
-Test bind list_size constant failed (50 shrink steps):
+Test bind list_size constant failed (49 shrink steps):
 
 (4, [0; 0; 0; 0])
 
 --- Failure --------------------------------------------------------------------
 
-Test lists are empty failed (11 shrink steps):
+Test lists are empty failed (12 shrink steps):
 
 [0]
 
 --- Failure --------------------------------------------------------------------
 
-Test lists shorter than 10 failed (50 shrink steps):
+Test lists shorter than 10 failed (39 shrink steps):
 
 [0; 0; 0; 0; 0; 0; 0; 0; 0; 0]
 
 --- Failure --------------------------------------------------------------------
 
-Test lists shorter than 432 failed (1696 shrink steps):
+Test lists shorter than 432 failed (1632 shrink steps):
 
 [...] list length: 432
 
@@ -455,15 +458,15 @@ Test lists shorter than 4332 failed (13 shrink steps):
 
 --- Failure --------------------------------------------------------------------
 
-Test lists equal to duplication failed (20 shrink steps):
+Test lists equal to duplication failed (26 shrink steps):
 
 [0]
 
 --- Failure --------------------------------------------------------------------
 
-Test lists have unique elems failed (7 shrink steps):
+Test lists have unique elems failed (8 shrink steps):
 
-[7; 7]
+[1; 1]
 
 --- Failure --------------------------------------------------------------------
 
@@ -473,9 +476,9 @@ Leaf 0
 
 --- Failure --------------------------------------------------------------------
 
-Test fail_pred_map_commute failed (107 shrink steps):
+Test fail_pred_map_commute failed (77 shrink steps):
 
-([0], {_ -> -21}, {-21 -> true; _ -> false})
+([1], {_ -> 0}, {1 -> true; _ -> false})
 
 --- Failure --------------------------------------------------------------------
 
@@ -485,7 +488,7 @@ Test fail_pred_strings failed (1 shrink steps):
 
 --- Failure --------------------------------------------------------------------
 
-Test fold_left fold_right failed (24 shrink steps):
+Test fold_left fold_right failed (34 shrink steps):
 
 (0, [1], {(1, 0) -> 1; _ -> 0})
 
@@ -498,21 +501,21 @@ l=[1], fold_left=1, fold_right=0
 
 --- Failure --------------------------------------------------------------------
 
-Test fold_left fold_right uncurried failed (97 shrink steps):
+Test fold_left fold_right uncurried failed (44 shrink steps):
 
-({(1, 7) -> 0; _ -> 7}, 0, [1; 0])
+({(0, 7) -> 1; _ -> 0}, 0, [7])
 
 --- Failure --------------------------------------------------------------------
 
-Test fold_left fold_right uncurried fun last failed (21 shrink steps):
+Test fold_left fold_right uncurried fun last failed (34 shrink steps):
 
-(0, [1], {(0, 1) -> 0; _ -> 1})
+(0, [1], {(1, 0) -> 1; _ -> 0})
 
 --- Failure --------------------------------------------------------------------
 
-Test fold_left test, fun first failed (40 shrink steps):
+Test fold_left test, fun first failed (275 shrink steps):
 
-({_ -> ""}, "z", [], [0])
+({_ -> ""}, "\000", [], [0])
 
 --- Failure --------------------------------------------------------------------
 

test/core/QCheck_unit_tests.ml

@@ -76,7 +76,7 @@ module Check_exn = struct
 
   let test_fail_random () =
     let name = "list is own reverse" in
-    let counterex_str = "[0; -1] (after 126 shrink steps)" in
+    let counterex_str = "[0; 1] (after 123 shrink steps)" in
     let run_test () =
       check_exn
         QCheck.(Test.make ~name (list int) (fun l -> List.rev l = l)) in