diff --git a/src/core/QCheck2.ml b/src/core/QCheck2.ml index e7936d4b..eaf3b9b9 100644 --- a/src/core/QCheck2.ml +++ b/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 diff --git a/test/core/QCheck2_expect_test.ml b/test/core/QCheck2_expect_test.ml index 970312d9..dfd6d137 100644 --- a/test/core/QCheck2_expect_test.ml +++ b/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) diff --git a/test/core/QCheck_expect_test.ml b/test/core/QCheck_expect_test.ml index 97a8dd28..c33b3d08 100644 --- a/test/core/QCheck_expect_test.ml +++ b/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) diff --git a/test/core/qcheck2_output.txt.expected b/test/core/qcheck2_output.txt.expected index f13574bf..cf52f542 100644 --- a/test/core/qcheck2_output.txt.expected +++ b/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 -------------------------------------------------------------------- diff --git a/test/core/qcheck_output.txt.expected b/test/core/qcheck_output.txt.expected index da58eda8..73a545e5 100644 --- a/test/core/qcheck_output.txt.expected +++ b/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 --------------------------------------------------------------------