Merge pull request #319 from jmid/qcheck2-shrink-improvements

QCheck2 shrinker improvements to list, array, bytes, strings, and functions

CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## NEXT RELEASE
 
+- Improve the `QCheck2.Gen.list` shrinker heuristic and utilize the improved
+  shrinker in other `QCheck2` `{list,array,bytes,string,function}*` shrinkers
 - Use `split` and `copy` in `Random.State` underlying `QCheck2` to
   avoid non-deterministic shrinking behaviour
 - Add missing documentation strings for `QCheck.{Print,Iter,Shrink,Gen}` and `QCheck2.Gen`.

src/core/QCheck2.ml

@@ -52,6 +52,11 @@ let _opt_sum a b = match a, b with
 
 let sum_int = List.fold_left (+) 0
 
+let rec list_split l len acc = match len,l with
+  | _,[]
+  | 0,_ -> List.rev acc, l
+  | _,x::xs -> list_split xs (len-1) (x::acc)
+
 exception Failed_precondition
 (* raised if precondition is false *)
 
@@ -83,6 +88,25 @@ module Seq = struct
 
   let cons x next () = Cons (x, next)
 
+  let rec force_drop n xs =
+    match xs() with
+    | Nil ->
+      Nil
+    | Cons (_, xs) ->
+      let n = n - 1 in
+      if n = 0 then
+        xs()
+      else
+        force_drop n xs
+
+  let drop n xs =
+    if n < 0 then invalid_arg "Seq.drop"
+    else if n = 0 then
+      xs
+    else
+      fun () ->
+        force_drop n xs
+
   (* End of copy of old functions. *)
 
   let is_empty (seq : _ t) : bool = match seq () with
@@ -239,6 +263,31 @@ module Tree = struct
   let rec applicative_take (n : int) (l : 'a t list) : 'a list t = match (n, l) with
     | (0, _) | (_, []) -> pure []
     | (n, (tree :: trees)) -> liftA2 List.cons tree (applicative_take (pred n) trees)
+
+  let rec build_list_shrink_tree (l : 'a t list) : 'a list t Seq.t = match l with
+    | [] -> Seq.empty
+    | [_] ->
+      fun () -> Seq.cons (Tree ([], Seq.empty))   (* [x] leaves only empty list to try *)
+                  (children (sequence_list l)) () (* otherwise, reduce element(s) *)
+    | _::_ ->
+      fun () ->
+        let len = List.length l in
+        let xs,ys = list_split l ((1 + len) / 2) [] in
+        let xs_roots = List.map root xs in
+        let ys_roots = List.map root ys in
+        (* Try reducing a list [1;2;3;4] in halves: [1;2] and [3;4] *)
+        Seq.cons (Tree (xs_roots, build_list_shrink_tree xs))
+          (Seq.cons (Tree (ys_roots, build_list_shrink_tree ys))
+             (fun () ->
+                (if len >= 4
+                 then (* Try dropping an element from either half: [2;3;4] and [1;2;4] *)
+                   let rest = List.tl l in
+                   let rest_roots = List.map root rest in
+                   (Seq.cons (Tree (rest_roots, build_list_shrink_tree rest))
+                      (Seq.cons (Tree (xs_roots@(List.tl ys_roots), build_list_shrink_tree (xs@(List.tl ys))))
+                         (children (sequence_list l))))     (* at bottom: reduce elements *)
+                 else
+                   children (sequence_list l)) ())) ()
 end
 
 module Gen = struct
@@ -583,7 +632,22 @@ module Gen = struct
     in
     loop size []
 
-  let list (gen : 'a t) : 'a list t = list_size nat gen
+  (** [list_ignore_size_tree] is a helper applying its own size shrinking heuristic,
+      and thus using only the root of [size]'s output shrink [Tree]. *)
+  let list_ignore_size_tree (size : int t) (gen : 'a t) : 'a list t = fun st ->
+    let st' = RS.split st in
+    let size = Tree.root (size st) in
+    let st' = RS.copy st' in (* start each loop from same Random.State to recreate same element (prefix) *)
+    let rec loop n acc = (* phase 1: build a list of element trees, tail recursively *)
+      if n <= 0          (* phase 2: build a list shrink Tree of element trees, tail recursively *)
+      then
+        let l = List.rev acc in
+        Tree.Tree (List.map Tree.root l, Tree.build_list_shrink_tree l)
+      else (loop [@tailcall]) (n - 1) ((gen st')::acc)
+    in
+    loop size []
+
+  let list (gen : 'a t) : 'a list t = list_ignore_size_tree nat gen
 
   let list_repeat (n : int) (gen : 'a t) : 'a list t = list_size (pure n) gen
 
@@ -725,31 +789,45 @@ module Gen = struct
   let string_size ?(gen = char) (size : int t) : string t =
     bytes_size ~gen size >|= Bytes.unsafe_to_string
 
-  let bytes : bytes t = bytes_size nat
+  let bytes_of_char_list cs =
+    let b = Buffer.create (List.length cs) in
+    List.iter (fun c -> Buffer.add_char b c) cs;
+    let bytes = Buffer.to_bytes b in
+    Buffer.clear b;
+    bytes
+
+  let bytes : bytes t = list char >|= bytes_of_char_list
+
+  let bytes_of gen = list gen >|= bytes_of_char_list
 
-  let bytes_of gen = bytes_size ~gen nat
+  let bytes_printable = list printable >|= bytes_of_char_list
 
-  let bytes_printable = bytes_size ~gen:printable nat
+  let bytes_small = list_ignore_size_tree small_nat char >|= bytes_of_char_list
 
-  let bytes_small st = bytes_size small_nat st
+  let bytes_small_of gen = list_ignore_size_tree small_nat gen >|= bytes_of_char_list
 
-  let bytes_small_of gen st = bytes_size ~gen small_nat st
+  let string_of_char_list cs =
+    let b = Buffer.create (List.length cs) in
+    List.iter (fun c -> Buffer.add_char b c) cs;
+    let str = Buffer.contents b in
+    Buffer.clear b;
+    str
 
-  let string : string t = string_size nat
+  let string : string t = list char >|= string_of_char_list
 
-  let string_of gen = string_size ~gen nat
+  let string_of gen = list gen >|= string_of_char_list
 
-  let string_printable = string_size ~gen:printable nat
+  let string_printable = list printable >|= string_of_char_list
 
-  let string_small st = string_size small_nat st
+  let string_small = list_ignore_size_tree small_nat char >|= string_of_char_list
 
-  let string_small_of gen st = string_size ~gen small_nat st
+  let string_small_of gen = list_ignore_size_tree small_nat gen >|= string_of_char_list
 
   let small_string ?(gen=char) = string_small_of gen
 
-  let small_list gen = list_size small_nat gen
+  let small_list gen = list_ignore_size_tree small_nat gen
 
-  let small_array gen = array_size small_nat gen
+  let small_array gen = list_ignore_size_tree small_nat gen >|= Array.of_list
 
   let join (gen : 'a t t) : 'a t = gen >>= Fun.id
 
@@ -1200,14 +1278,14 @@ end = struct
       (* This only gets evaluated *after* the test was run for [tbl], meaning it is correctly
          populated with bindings recorded during the test already *)
       let current_bindings : (k * v Tree.t) list = List.rev !(root.p_tree_bindings_rev) in
-      let take_at_most_tree : int Tree.t = Tree.make_primitive (Shrink.int_towards 0) (List.length current_bindings) in
       let current_tree_bindings : (k * v) Tree.t list = List.map (fun (k, tree) -> Tree.map (fun v -> (k, v)) tree) current_bindings in
-      let shrunk_bindings_tree : (k * v) list Tree.t = Tree.bind take_at_most_tree (fun take_at_most -> Tree.applicative_take take_at_most current_tree_bindings) in
+      let shrunk_bindings_tree_seq : (k * v) list Tree.t Seq.t = Tree.build_list_shrink_tree current_tree_bindings in
       (* During shrinking, we don't want to record/add bindings, so [~extend:false]. *)
-      let shrunk_poly_tbl_tree : (k, v) t Tree.t = Tree.map (fun bindings -> List.to_seq bindings |> T.of_seq |> make ~extend:false) shrunk_bindings_tree in
-      (* [shrunk_poly_tbl_tree] is a bit misleading: its root *should* be the same as [root] but because of the required laziness
-         induced by the mutation of bindings, we don't use it, only graft its children to the original [root]. *)
-      Tree.children shrunk_poly_tbl_tree ()
+      let shrunk_poly_tbl_tree_seq : (k, v) t Tree.t Seq.t =
+        Seq.map (fun t -> Tree.map (fun bindings -> List.to_seq bindings |> T.of_seq |> make ~extend:false) t) shrunk_bindings_tree_seq in
+      (* [shrunk_poly_tbl_tree_seq] is a bit misleading: its head *should* be the same as [root] but because of the required laziness
+         induced by the mutation of bindings, we don't use it, only graft its tail to the original [root]. *)
+      Seq.drop 1 shrunk_poly_tbl_tree_seq ()
     in
     Tree.Tree (root, shrinks)
 

test/core/QCheck2_expect_test.expected.ocaml4.32

@@ -69,14 +69,13 @@ random seed: 1234
 1
 0
 [16; 1; 1]
-[]
+[16; 1]
 [16]
 []
 [0]
 [16; 1; 1]
-[]
-[16]
 [16; 1]
+[1]
 [0; 1; 1]
 [0; 0; 1]
 [0; 0; 0]
@@ -279,51 +278,51 @@ Test printable never produces less than '5 failed (1 shrink steps):
 
 --- Failure --------------------------------------------------------------------
 
-Test bytes are empty failed (2 shrink steps):
+Test bytes are empty failed (3 shrink steps):
 
 "a"
 
 --- Failure --------------------------------------------------------------------
 
-Test bytes never has a \000 char failed (198 shrink steps):
+Test bytes never has a \000 char failed (9 shrink steps):
 
-"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\000"
+"\000"
 
 --- Failure --------------------------------------------------------------------
 
-Test bytes never has a \255 char failed (20 shrink steps):
+Test bytes never has a \255 char failed (5 shrink steps):
 
-"aaaaaaaaaaaaaaaaa\255"
+"\255"
 
 --- Failure --------------------------------------------------------------------
 
-Test bytes have unique chars failed (28 shrink steps):
+Test bytes have unique chars failed (31 shrink steps):
 
-"aaaaaaaaaaaaaaaaaaaaaaaaaaa"
+"aaaaaaaaaaa"
 
 --- Failure --------------------------------------------------------------------
 
-Test strings are empty failed (2 shrink steps):
+Test strings are empty failed (3 shrink steps):
 
 "a"
 
 --- Failure --------------------------------------------------------------------
 
-Test string never has a \000 char failed (198 shrink steps):
+Test string never has a \000 char failed (9 shrink steps):
 
-"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\000"
+"\000"
 
 --- Failure --------------------------------------------------------------------
 
-Test string never has a \255 char failed (20 shrink steps):
+Test string never has a \255 char failed (5 shrink steps):
 
-"aaaaaaaaaaaaaaaaa\255"
+"\255"
 
 --- Failure --------------------------------------------------------------------
 
-Test strings have unique chars failed (28 shrink steps):
+Test strings have unique chars failed (31 shrink steps):
 
-"aaaaaaaaaaaaaaaaaaaaaaaaaaa"
+"aaaaaaaaaaa"
 
 --- Failure --------------------------------------------------------------------
 
@@ -369,15 +368,15 @@ Test pairs sum to less than 128 failed (24 shrink steps):
 
 --- Failure --------------------------------------------------------------------
 
-Test pairs lists rev concat failed (34 shrink steps):
+Test pairs lists rev concat failed (35 shrink steps):
 
 ([0], [1])
 
 --- Failure --------------------------------------------------------------------
 
-Test pairs lists no overlap failed (15 shrink steps):
+Test pairs lists no overlap failed (6 shrink steps):
 
-([0], [0; 0; 0; 0; 0; 0; 0; 0; 0; 0])
+([1], [1])
 
 --- Failure --------------------------------------------------------------------
 
@@ -489,13 +488,13 @@ Test bind list_size constant failed (12 shrink steps):
 
 --- Failure --------------------------------------------------------------------
 
-Test lists are empty failed (2 shrink steps):
+Test lists are empty failed (3 shrink steps):
 
 [0]
 
 --- Failure --------------------------------------------------------------------
 
-Test lists shorter than 10 failed (12 shrink steps):
+Test lists shorter than 10 failed (16 shrink steps):
 
 [0; 0; 0; 0; 0; 0; 0; 0; 0; 0]
 
@@ -531,7 +530,7 @@ None
 
 --- Failure --------------------------------------------------------------------
 
-Test (int,string) result are Ok failed (1 shrink steps):
+Test (int,string) result are Ok failed (2 shrink steps):
 
 Error ("")
 
@@ -555,52 +554,52 @@ Test sum list = 0 failed (0 shrink steps):
 
 --- Failure --------------------------------------------------------------------
 
-Test fail_pred_map_commute_int failed (31 shrink steps):
+Test fail_pred_map_commute_int failed (14 shrink steps):
 
-([0; 0; 0; 0; 0; 0], {0 -> -1; 1 -> 0; 2 -> 0; 5 -> 0; 21 -> 0; 7 -> 0; 9 -> 0; 78 -> 0; _ -> 0}, {0 -> true; 998130433 -> false; 1 -> false; 2 -> false; 402927669 -> false; 5 -> false; 21 -> false; 7 -> false; -1041906807 -> false; 9 -> false; -1072173830 -> false; -353172948 -> false; -952635860 -> false; 78 -> false; 286212959 -> false; _ -> false})
+([0], {0 -> -1; _ -> 0}, {0 -> true; _ -> false})
 
 --- Failure --------------------------------------------------------------------
 
-Test fail_pred_map_commute_int32 failed (70 shrink steps):
+Test fail_pred_map_commute_int32 failed (58 shrink steps):
 
-([0l; 0l; 0l; 0l; 0l; 0l], {480624048l -> 0l; -1054565120l -> 0l; 708270421l -> 0l; -1441877194l -> 0l; -239944349l -> 0l; 0l -> 1l; -973889953l -> 0l; 1395009590l -> 0l; _ -> 0l}, {-1990017031l -> false; 443535120l -> false; 480624048l -> false; -1054565120l -> false; 829558403l -> false; -1311148841l -> false; 2084431360l -> false; 708270421l -> false; 79063824l -> false; -1441877194l -> false; -239944349l -> false; 0l -> true; 457187395l -> false; 1395009590l -> false; -973889953l -> false; _ -> false})
+([0l], {0l -> 1l; _ -> 0l}, {0l -> true; _ -> false})
 
 --- Failure --------------------------------------------------------------------
 
-Test fail_pred_map_commute_int64 failed (125 shrink steps):
+Test fail_pred_map_commute_int64 failed (113 shrink steps):
 
-([0L; 0L; 0L; 0L; 0L; 0L], {-5912897149740583042L -> 0L; 2064264570832434420L -> 0L; 8769531915837689755L -> 0L; -1030553128493932961L -> 0L; 0L -> 1L; 6077417419721789289L -> 0L; -4529322700507305930L -> 0L; -6192815392369977003L -> 0L; _ -> 0L}, {-8367471897177334538L -> false; 8952564522059662897L -> false; -5912897149740583042L -> false; -5897649978982613650L -> false; 339576540681650169L -> false; 2064264570832434420L -> false; 1963604910111969040L -> false; 8769531915837689755L -> false; -1030553128493932961L -> false; 0L -> true; 6077417419721789289L -> false; -3575913752036838904L -> false; 3562926213990806743L -> false; -6192815392369977003L -> false; -4529322700507305930L -> false; _ -> false})
+([0L], {0L -> 1L; _ -> 0L}, {0L -> true; _ -> false})
 
 --- Failure --------------------------------------------------------------------
 
-Test fail_pred_strings failed (2 shrink steps):
+Test fail_pred_strings failed (1 shrink steps):
 
-{"some random string" -> true; _ -> false}
+{"some random string" -> true; "some other string" -> false; _ -> false}
 
 --- Failure --------------------------------------------------------------------
 
-Test fold_left fold_right failed (21 shrink steps):
+Test fold_left fold_right failed (10 shrink steps):
 
-(0, [0; 0], {(70, 3) -> 0; (3, 0) -> 0; (0, 6) -> 0; (2, 6) -> 0; (0, 90) -> 0; (3, 26) -> 0; (3, 9) -> 0; (20, 3) -> 0; (3, 2) -> 0; (2, 0) -> 0; (0, 70) -> 1; (4, 3) -> 0; (9, 6) -> 0; (6, 8) -> 0; (0, 3) -> 0; (6, 6) -> 0; (0, 7) -> 0; (0, 0) -> 70; _ -> 0})
+(0, [1], {(1, 0) -> 1; _ -> 0})
 
 +++ Messages ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
 Messages for test fold_left fold_right:
 
-l=[0; 0], fold_left=1, fold_right=0
+l=[1], fold_left=1, fold_right=0
 
 
 --- Failure --------------------------------------------------------------------
 
-Test fold_left fold_right uncurried failed (47 shrink steps):
+Test fold_left fold_right uncurried failed (62 shrink steps):
 
-({(3, 76) -> 0; (9, 3) -> 0; (5, 2) -> 0; (1, 2) -> 1; (34, 1) -> 0; (9, 6) -> 0; (7, 3) -> 0; (3, 8) -> 0; (67, 3) -> 0; (2, 24) -> 0; (1, 1) -> 0; (37, 6) -> 0; (6, 2) -> 0; (5, 8) -> 0; (5, 7) -> 0; (5, 6) -> 0; (4, 8) -> 0; (17, 3) -> 0; (3, 4) -> 0; (84, 79) -> 0; (4, 17) -> 0; (6, 1) -> 0; (7, 6) -> 0; (3, 5) -> 0; (9, 4) -> 0; (1, 9) -> 0; (2, 5) -> 0; _ -> 0}, 1, [2])
+({(5, 2) -> 0; (4, 1) -> 0; (1, 2) -> 1; (79, 4) -> 0; (9, 6) -> 0; (7, 3) -> 0; (3, 8) -> 0; (17, 6) -> 0; (37, 6) -> 0; (4, 8) -> 0; (17, 3) -> 0; (3, 4) -> 0; (84, 79) -> 0; (8, 1) -> 0; (6, 8) -> 0; (4, 17) -> 0; (3, 5) -> 0; (1, 6) -> 0; (9, 4) -> 0; (2, 5) -> 0; (5, 4) -> 0; (3, 76) -> 0; (9, 3) -> 0; (3, 1) -> 0; (8, 3) -> 0; (3, 24) -> 0; (34, 1) -> 0; (3, 3) -> 0; (6, 9) -> 0; (76, 8) -> 0; (67, 3) -> 0; (8, 9) -> 0; (2, 24) -> 0; (1, 1) -> 0; (1, 5) -> 0; (2, 3) -> 0; (6, 2) -> 0; (5, 8) -> 0; (5, 7) -> 0; (5, 6) -> 0; (24, 5) -> 0; (2, 17) -> 0; (6, 1) -> 0; (7, 6) -> 0; (6, 3) -> 0; (2, 4) -> 0; (1, 9) -> 0; _ -> 0}, 1, [2])
 
 --- Failure --------------------------------------------------------------------
 
-Test fold_left fold_right uncurried fun last failed (26 shrink steps):
+Test fold_left fold_right uncurried fun last failed (10 shrink steps):
 
-(0, [0; 0], {(0, 20) -> 0; (90, 3) -> 0; (3, 9) -> 0; (8, 3) -> 0; (3, 2) -> 0; (9, 6) -> 0; (7, 3) -> 0; (6, 20) -> 0; (0, 70) -> 0; (6, 70) -> 0; (3, 0) -> 1; (0, 4) -> 0; (6, 0) -> 0; (0, 0) -> 3; (2, 0) -> 0; (26, 6) -> 0; (6, 3) -> 0; _ -> 0})
+(0, [1], {(0, 1) -> 1; _ -> 0})
 
 --- Failure --------------------------------------------------------------------