Fix QCheck2.gen.list_size Stack overflow

src/core/QCheck2.ml

@@ -527,14 +527,16 @@ module Gen = struct
 
   let ui64 : int64 t = map Int64.abs int64
 
+  (* A tail-recursive implementation over Tree.t *)
   let list_size (size : int t) (gen : 'a t) : 'a list t =
-    size >>= fun size ->
-    let rec loop n =
+    fun st ->
+    Tree.bind (size st) @@ fun size ->
+    let rec loop n acc =
       if n <= 0
-      then pure []
-      else liftA2 List.cons gen (loop (n - 1))
+      then acc
+      else (loop [@tailcall]) (n - 1) (Tree.liftA2 List.cons (gen st) acc)
     in
-    loop size
+    loop size (Tree.pure [])
 
   let list (gen : 'a t) : 'a list t = list_size nat gen
 

test/core/QCheck2_expect_test.ml

@@ -143,7 +143,7 @@ module Shrink = struct
 
   let strings_are_empty =
     Test.make ~name:"strings are empty" ~count:1000 ~print:Print.string
-      Gen.string (fun s -> (*Printf.printf "\"%s\"\n" (String.escaped s);*) s = "")
+      Gen.string (fun s -> s = "")
 
   let string_never_has_000_char =
     Test.make ~name:"string never has a \\000 char" ~count:1000 ~print:Print.string
@@ -164,7 +164,7 @@ module Shrink = struct
 
   let list_shorter_10 =
     Test.make ~name:"lists shorter than 10" ~print:Print.(list int)
-      Gen.(list small_int) (fun xs -> (*print_list xs;*) List.length xs < 10)
+      Gen.(list small_int) (fun xs -> List.length xs < 10)
 
   let length_printer xs =
     Printf.sprintf "[...] list length: %i" (List.length xs)
@@ -173,17 +173,17 @@ module Shrink = struct
 
   let list_shorter_432 =
     Test.make ~name:"lists shorter than 432" ~print:length_printer
-      Gen.(list_size size_gen small_int) (*Gen.(list small_int)*)
-      (fun xs -> (*print_list xs;*) List.length xs < 432)
+      Gen.(list_size size_gen small_int)
+      (fun xs -> List.length xs < 432)
 
   let list_shorter_4332 =
     Test.make ~name:"lists shorter than 4332" ~print:length_printer
-      Gen.(list_size size_gen small_int) (*Gen.(list small_int)*)
-      (fun xs -> (*print_list xs;*) List.length xs < 4332)
+      Gen.(list_size size_gen small_int)
+      (fun xs -> List.length xs < 4332)
 
   let list_equal_dupl =
-    Test.make ~name:"lists equal to duplication" ~print:length_printer
-      Gen.(list_size size_gen small_int) (*Gen.(list small_int)*)
+    Test.make ~name:"lists equal to duplication" ~print:Print.(list int)
+      Gen.(list_size size_gen small_int)
       (fun xs -> try xs = xs @ xs
                  with Stack_overflow -> false)
 

test/core/QCheck_expect_test.ml

@@ -137,7 +137,7 @@ module Shrink = struct
 
   let strings_are_empty =
     Test.make ~name:"strings are empty" ~count:1000
-      string (fun s -> (*Printf.printf "\"%s\"\n" (String.escaped s);*) s = "")
+      string (fun s -> s = "")
 
   let string_never_has_000_char =
     Test.make ~name:"string never has a \\000 char" ~count:1000
@@ -157,7 +157,7 @@ module Shrink = struct
 
   let list_shorter_10 =
     Test.make ~name:"lists shorter than 10"
-      (list small_int) (fun xs -> (*print_list xs;*) List.length xs < 10)
+      (list small_int) (fun xs -> List.length xs < 10)
 
   let length_printer xs =
     Printf.sprintf "[...] list length: %i" (List.length xs)
@@ -166,18 +166,17 @@ module Shrink = struct
 
   let list_shorter_432 =
     Test.make ~name:"lists shorter than 432"
-      (set_print length_printer (list_of_size size_gen small_int)) (*(list small_int)*)
-      (fun xs -> (*print_list xs;*) List.length xs < 432)
+      (set_print length_printer (list_of_size size_gen small_int))
+      (fun xs -> List.length xs < 432)
 
   let list_shorter_4332 =
     Test.make ~name:"lists shorter than 4332"
       (set_shrink Shrink.list_spine (set_print length_printer (list_of_size size_gen small_int)))
-      (fun xs -> (*print_list xs;*) List.length xs < 4332)
+      (fun xs -> List.length xs < 4332)
 
   let list_equal_dupl =
     Test.make ~name:"lists equal to duplication"
-      (set_print length_printer (list_of_size size_gen small_int))
-      (*(set_print length_printer (list small_int))*)
+      (list_of_size size_gen small_int)
       (fun xs -> try xs = xs @ xs
                  with Stack_overflow -> false)
 

test/core/qcheck2_output.txt.expected

@@ -316,27 +316,21 @@ Test lists shorter than 10 failed (16 shrink steps):
 
 --- Failure --------------------------------------------------------------------
 
-Test lists shorter than 432 failed:
+Test lists shorter than 432 failed (412 shrink steps):
 
-ERROR: uncaught exception in generator for test lists shorter than 432 after 100 steps:
-Exception: Stack overflow
-Backtrace: 
+[...] list length: 432
 
 --- Failure --------------------------------------------------------------------
 
-Test lists shorter than 4332 failed:
+Test lists shorter than 4332 failed (4022 shrink steps):
 
-ERROR: uncaught exception in generator for test lists shorter than 4332 after 100 steps:
-Exception: Stack overflow
-Backtrace: 
+[...] list length: 4332
 
 --- Failure --------------------------------------------------------------------
 
-Test lists equal to duplication failed:
+Test lists equal to duplication failed (4 shrink steps):
 
-ERROR: uncaught exception in generator for test lists equal to duplication after 100 steps:
-Exception: Stack overflow
-Backtrace: 
+[0]
 
 --- Failure --------------------------------------------------------------------
 

test/core/qcheck_output.txt.expected

@@ -267,7 +267,7 @@ Test lists shorter than 4332 failed (13 shrink steps):
 
 Test lists equal to duplication failed (20 shrink steps):
 
-[...] list length: 1
+[0]
 
 --- Failure --------------------------------------------------------------------