From 730a971954b4a5f62a8e65b7af6f126cfc5fb278 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Sat, 11 Sep 2021 19:55:25 +0200 Subject: [PATCH 1/7] rm commented code --- test/core/QCheck2_expect_test.ml | 1 - test/core/QCheck_expect_test.ml | 1 - 2 files changed, 2 deletions(-) diff --git a/test/core/QCheck2_expect_test.ml b/test/core/QCheck2_expect_test.ml index 3c955b3c..13f01523 100644 --- a/test/core/QCheck2_expect_test.ml +++ b/test/core/QCheck2_expect_test.ml @@ -132,7 +132,6 @@ module Generator = struct Test.make ~name:"int triples - associative over +" ~count:1000 ~print:Print.(triple int int int) Gen.(triple small_nat small_nat small_nat) (fun (i,j,k) -> i+(j+k) = (i+j)+k) - (*was: (fun (i,j,k) -> i+(j+k) = (i+j)+i)*) let quad_test = Test.make ~name:"int quadruples - product of sums" ~count:1000 diff --git a/test/core/QCheck_expect_test.ml b/test/core/QCheck_expect_test.ml index 6c43d0c3..b39dda85 100644 --- a/test/core/QCheck_expect_test.ml +++ b/test/core/QCheck_expect_test.ml @@ -147,7 +147,6 @@ module Generator = struct let triple_test = Test.make ~name:"int triples - associative over +" ~count:1000 (triple small_nat small_nat small_nat) (fun (i,j,k) -> i+(j+k) = (i+j)+k) - (*was: (fun (i,j,k) -> i+(j+k) = (i+j)+i)*) let quad_test = Test.make ~name:"int quadruples - product of sums" ~count:1000 From 86858e8949e0ad0f7f6e39a0e808a85455799b7d Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Sun, 12 Sep 2021 02:14:12 +0200 Subject: [PATCH 2/7] adjust tests gens, add a few more tests --- test/core/QCheck2_expect_test.expected | 24 ++++++++++++++++++------ test/core/QCheck2_expect_test.ml | 25 +++++++++++++++++++------ test/core/QCheck_expect_test.expected | 24 ++++++++++++++++++------ test/core/QCheck_expect_test.ml | 25 +++++++++++++++++++------ 4 files changed, 74 insertions(+), 24 deletions(-) diff --git a/test/core/QCheck2_expect_test.expected b/test/core/QCheck2_expect_test.expected index 4e3b8b65..1301e329 100644 --- a/test/core/QCheck2_expect_test.expected +++ b/test/core/QCheck2_expect_test.expected @@ -336,24 +336,36 @@ Test pairs are (0,0) failed (63 shrink steps): --- Failure -------------------------------------------------------------------- -Test pairs are ordered failed (2 shrink steps): +Test pairs are ordered failed (94 shrink steps): -(0, -1) +(1, 0) --- Failure -------------------------------------------------------------------- -Test pairs are ordered reversely failed (63 shrink steps): +Test pairs are ordered reversely failed (62 shrink steps): (0, 1) --- Failure -------------------------------------------------------------------- -Test pairs sum to less than 128 failed (59 shrink steps): +Test pairs sum to less than 128 failed (56 shrink steps): (0, 128) --- Failure -------------------------------------------------------------------- +Test pairs lists rev concat failed (83 shrink steps): + +([0], [1]) + +--- Failure -------------------------------------------------------------------- + +Test pairs lists no overlap failed (27 shrink steps): + +([0], [0; 0; 0; 0]) + +--- Failure -------------------------------------------------------------------- + Test triples have pair-wise different components failed (3 shrink steps): (0, 0, 0) @@ -408,7 +420,7 @@ Test bind ordered pairs failed (1 shrink steps): --- Failure -------------------------------------------------------------------- -Test bind list_size constant failed (15 shrink steps): +Test bind list_size constant failed (12 shrink steps): (4, [0; 0; 0; 0]) @@ -1216,7 +1228,7 @@ stats dist: 4150517416584649600.. 4611686018427387903: ################# 189 ================================================================================ 1 warning(s) -failure (53 tests failed, 1 tests errored, ran 110 tests) +failure (55 tests failed, 1 tests errored, ran 112 tests) random seed: 153870556 +++ Stats for int_dist_empty_bucket ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/test/core/QCheck2_expect_test.ml b/test/core/QCheck2_expect_test.ml index 13f01523..8f5b36bf 100644 --- a/test/core/QCheck2_expect_test.ml +++ b/test/core/QCheck2_expect_test.ml @@ -146,7 +146,8 @@ module Generator = struct let bind_pair_list_length = Test.make ~name:"bind list length" ~count:1000 ~print:Print.(pair int (list int)) - Gen.(int_bound 10_000 >>= fun len -> list_size (return len) int >>= fun xs -> return (len,xs)) + Gen.(int_bound 1000 >>= fun len -> + list_size (return len) (int_bound 10) >>= fun xs -> return (len,xs)) (fun (len,xs) -> len = List.length xs) let list_test = @@ -332,15 +333,25 @@ module Shrink = struct let pair_ordered = Test.make ~name:"pairs are ordered" ~print:Print.(pair int int) - Gen.(pair int int) (fun (i,j) -> i<=j) + Gen.(pair (pint ~origin:0) (pint ~origin:0)) (fun (i,j) -> i<=j) let pair_ordered_rev = Test.make ~name:"pairs are ordered reversely" ~print:Print.(pair int int) - Gen.(pair int int) (fun (i,j) -> i>=j) + Gen.(pair (pint ~origin:0) (pint ~origin:0)) (fun (i,j) -> i>=j) let pair_sum_lt_128 = Test.make ~name:"pairs sum to less than 128" ~print:Print.(pair int int) - Gen.(pair int int) (fun (i,j) -> i+j<128) + Gen.(pair (pint ~origin:0) (pint ~origin:0)) (fun (i,j) -> i+j<128) + + let pair_lists_rev_concat = + Test.make ~name:"pairs lists rev concat" ~print:Print.(pair (list int) (list int)) + Gen.(pair (list (pint ~origin:0)) (list (pint ~origin:0))) + (fun (xs,ys) -> List.rev (xs@ys) = (List.rev xs)@(List.rev ys)) + + let pair_lists_no_overlap = + Test.make ~name:"pairs lists no overlap" ~print:Print.(pair (list int) (list int)) + Gen.(pair (list small_nat) (list small_nat)) + (fun (xs,ys) -> List.for_all (fun x -> not (List.mem x ys)) xs) let triple_diff = Test.make ~name:"triples have pair-wise different components" ~print:Print.(triple int int int) @@ -381,8 +392,8 @@ module Shrink = struct let bind_pair_list_size = Test.make ~name:"bind list_size constant" ~print:Print.(pair int (list int)) - Gen.(int_bound 10_000 >>= fun len -> - list_size (return len) int >>= fun xs -> return (len,xs)) + Gen.(int_bound 1000 >>= fun len -> + list_size (return len) (int_bound 1000) >>= fun xs -> return (len,xs)) (fun (len,xs) -> let len' = List.length xs in len=len' && len' < 4) (* tests from issue #64 *) @@ -503,6 +514,8 @@ module Shrink = struct pair_ordered; pair_ordered_rev; pair_sum_lt_128; + pair_lists_rev_concat; + pair_lists_no_overlap; triple_diff; triple_same; triple_ordered; diff --git a/test/core/QCheck_expect_test.expected b/test/core/QCheck_expect_test.expected index 74b8a220..634374f4 100644 --- a/test/core/QCheck_expect_test.expected +++ b/test/core/QCheck_expect_test.expected @@ -271,24 +271,36 @@ Test pairs are (0,0) failed (125 shrink steps): --- Failure -------------------------------------------------------------------- -Test pairs are ordered failed (125 shrink steps): +Test pairs are ordered failed (827 shrink steps): -(0, -1) +(1, 0) --- Failure -------------------------------------------------------------------- -Test pairs are ordered reversely failed (125 shrink steps): +Test pairs are ordered reversely failed (124 shrink steps): (0, 1) --- Failure -------------------------------------------------------------------- -Test pairs sum to less than 128 failed (121 shrink steps): +Test pairs sum to less than 128 failed (116 shrink steps): (0, 128) --- Failure -------------------------------------------------------------------- +Test pairs lists rev concat failed (140 shrink steps): + +([0], [1]) + +--- Failure -------------------------------------------------------------------- + +Test pairs lists no overlap failed (22 shrink steps): + +([0], [0]) + +--- Failure -------------------------------------------------------------------- + Test triples have pair-wise different components failed (7 shrink steps): (0, 7, 7) @@ -343,7 +355,7 @@ Test bind ordered pairs failed (123 shrink steps): --- Failure -------------------------------------------------------------------- -Test bind list_size constant failed (261 shrink steps): +Test bind list_size constant failed (50 shrink steps): (4, [0; 0; 0; 0]) @@ -1177,7 +1189,7 @@ stats dist: 4150517416584649600.. 4611686018427387903: ################# 189 ================================================================================ 1 warning(s) -failure (53 tests failed, 1 tests errored, ran 117 tests) +failure (55 tests failed, 1 tests errored, ran 119 tests) random seed: 153870556 +++ Stats for int_dist_empty_bucket ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/test/core/QCheck_expect_test.ml b/test/core/QCheck_expect_test.ml index b39dda85..da0bfe7e 100644 --- a/test/core/QCheck_expect_test.ml +++ b/test/core/QCheck_expect_test.ml @@ -160,7 +160,8 @@ module Generator = struct let bind_pair_list_length = Test.make ~name:"bind list length" ~count:1000 - (make Gen.(int_bound 10_000 >>= fun len -> list_size (return len) int >>= fun xs -> return (len,xs))) + (make Gen.(int_bound 1000 >>= fun len -> + list_size (return len) (int_bound 1000) >>= fun xs -> return (len,xs))) (fun (len,xs) -> len = List.length xs) let list_test = @@ -420,13 +421,23 @@ module Shrink = struct Test.make ~name:"pairs are (0,0)" (pair int int) (fun (i,j) -> i=0 && j=0) let pair_ordered = - Test.make ~name:"pairs are ordered" (pair int int) (fun (i,j) -> i<=j) + Test.make ~name:"pairs are ordered" (pair pos_int pos_int) (fun (i,j) -> i<=j) let pair_ordered_rev = - Test.make ~name:"pairs are ordered reversely" (pair int int) (fun (i,j) -> i>=j) + Test.make ~name:"pairs are ordered reversely" (pair pos_int pos_int) (fun (i,j) -> i>=j) let pair_sum_lt_128 = - Test.make ~name:"pairs sum to less than 128" (pair int int) (fun (i,j) -> i+j<128) + Test.make ~name:"pairs sum to less than 128" (pair pos_int pos_int) (fun (i,j) -> i+j<128) + + let pair_lists_rev_concat = + Test.make ~name:"pairs lists rev concat" + (pair (list pos_int) (list pos_int)) + (fun (xs,ys) -> List.rev (xs@ys) = (List.rev xs)@(List.rev ys)) + + let pair_lists_no_overlap = + Test.make ~name:"pairs lists no overlap" + (pair (list small_nat) (list small_nat)) + (fun (xs,ys) -> List.for_all (fun x -> not (List.mem x ys)) xs) let triple_diff = Test.make ~name:"triples have pair-wise different components" @@ -472,8 +483,8 @@ module Shrink = struct Iter.map (fun xs' -> (List.length xs',xs')) Shrink.(list ~shrink:int xs) in Test.make ~name:"bind list_size constant" (make ~print:Print.(pair int (list int)) ~shrink - Gen.(int_bound 10_000 >>= fun len -> - list_size (return len) int >>= fun xs -> return (len,xs))) + Gen.(int_bound 1000 >>= fun len -> + list_size (return len) (int_bound 1000) >>= fun xs -> return (len,xs))) (fun (len,xs) -> let len' = List.length xs in len=len' && len' < 4) let print_list xs = print_endline Print.(list int xs) @@ -586,6 +597,8 @@ module Shrink = struct pair_ordered; pair_ordered_rev; pair_sum_lt_128; + pair_lists_rev_concat; + pair_lists_no_overlap; triple_diff; triple_same; triple_ordered; From a465ac99fa297a194affe6b733ba63580b1860cb Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Sun, 12 Sep 2021 02:39:13 +0200 Subject: [PATCH 3/7] factor tests into reusable module --- test/core/QCheck2_expect_test.expected | 2 +- test/core/QCheck2_expect_test.ml | 760 +--------------------- test/core/QCheck2_tests.ml | 754 ++++++++++++++++++++++ test/core/QCheck_expect_test.expected | 2 +- test/core/QCheck_expect_test.ml | 844 +------------------------ test/core/QCheck_tests.ml | 841 ++++++++++++++++++++++++ test/core/dune | 21 +- 7 files changed, 1617 insertions(+), 1607 deletions(-) create mode 100644 test/core/QCheck2_tests.ml create mode 100644 test/core/QCheck_tests.ml diff --git a/test/core/QCheck2_expect_test.expected b/test/core/QCheck2_expect_test.expected index 1301e329..4e6a0bd9 100644 --- a/test/core/QCheck2_expect_test.expected +++ b/test/core/QCheck2_expect_test.expected @@ -176,7 +176,7 @@ Test should_error_raise_exn errored on (1 shrink steps): 0 -exception Dune__exe__QCheck2_expect_test.Overall.Error +exception QCheck2_tests.Overall.Error +++ Collect ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/test/core/QCheck2_expect_test.ml b/test/core/QCheck2_expect_test.ml index 8f5b36bf..66a88a5d 100644 --- a/test/core/QCheck2_expect_test.ml +++ b/test/core/QCheck2_expect_test.ml @@ -1,761 +1,4 @@ -(** QCheck2 tests **) - -(** Module representing a integer tree data structure, used in tests *) -module IntTree = struct - type tree = Leaf of int | Node of tree * tree - - let leaf x = Leaf x - let node x y = Node (x,y) - - let rec depth = function - | Leaf _ -> 1 - | Node (x, y) -> 1 + max (depth x) (depth y) - - let rec print_tree = function - | Leaf x -> Printf.sprintf "Leaf %d" x - | Node (x, y) -> Printf.sprintf "Node (%s, %s)" (print_tree x) (print_tree y) - - let gen_tree = QCheck2.Gen.(sized @@ fix - (fun self n -> match n with - | 0 -> map leaf nat - | n -> - frequency - [1, map leaf nat; - 2, map2 node (self (n/2)) (self (n/2))] - )) - - let rec rev_tree = function - | Node (x, y) -> Node (rev_tree y, rev_tree x) - | Leaf x -> Leaf x - - let rec contains_only_n tree n = match tree with - | Leaf n' -> n = n' - | Node (x, y) -> contains_only_n x n && contains_only_n y n -end - -(* tests of overall functionality *) -module Overall = struct - open QCheck2 - - let passing = - Test.make ~name:"list_rev_is_involutive" ~count:100 ~long_factor:100 - ~print:Print.(list int) - Gen.(list small_int) (fun l -> List.rev (List.rev l) = l) - - let failing = - Test.make ~name:"should_fail_sort_id" ~count:10 ~print:Print.(list int) - Gen.(small_list small_int) (fun l -> l = List.sort compare l) - - exception Error - - let error = - Test.make ~name:"should_error_raise_exn" ~count:10 ~print:Print.int - Gen.int (fun _ -> raise Error) - - let collect = - Test.make ~name:"collect_results" ~count:100 ~long_factor:100 - ~print:Print.int ~collect:string_of_int - (Gen.int_bound 4) (fun _ -> true) - - let stats = - Test.make ~name:"with_stats" ~count:100 ~long_factor:100 ~print:Print.int - ~stats:[ - "mod4", (fun i->i mod 4); - "num", (fun i->i); - ] - (Gen.int_bound 120) (fun _ -> true) - - let retries = - Test.make ~name:"with shrinking retries" ~retries:10 ~print:Print.int - Gen.small_nat (fun i -> Printf.printf "%i %!" i; i mod 3 <> 1) - - let bad_assume_warn = - Test.make ~name:"WARN_unlikely_precond" ~count:2_000 ~print:Print.int - Gen.int - (fun x -> - QCheck.assume (x mod 100 = 1); - true) - - let bad_assume_fail = - Test.make ~name:"FAIL_unlikely_precond" ~count:2_000 - ~if_assumptions_fail:(`Fatal, 0.1) ~print:Print.int - Gen.int - (fun x -> - QCheck.assume (x mod 100 = 1); - true) - - let tests = [ - passing; - failing; - error; - collect; - stats; - retries; - bad_assume_warn; - bad_assume_fail; - ] - -end - -(* positive tests of the various generators *) -module Generator = struct - open QCheck2 - - (* example from issue #23 *) - let char_dist_issue_23 = - Test.make ~name:"char never produces '\\255'" ~count:1_000_000 - ~print:Print.char - Gen.char (fun c -> c <> '\255') - - let char_test = - Test.make ~name:"char has right range'" ~count:1000 ~print:Print.char - Gen.char (fun c -> '\000' <= c && c <= '\255') - - let nat_test = - Test.make ~name:"nat has right range" ~count:1000 ~print:Print.int - Gen.nat (fun n -> 0 <= n && n < 10000) - - let string_test = - Test.make ~name:"string has right length and content" ~count:1000 ~print:Print.string - Gen.string - (fun s -> - let len = String.length s in - 0 <= len && len < 10000 - && String.to_seq s |> - Seq.fold_left (fun acc c -> acc && '\000' <= c && c <= '\255') true) - - let pair_test = - Test.make ~name:"int pairs - commute over +" ~count:1000 ~print:Print.(pair int int) - Gen.(pair small_nat small_nat) (fun (i,j) -> i+j = j+i) - - let triple_test = - Test.make ~name:"int triples - associative over +" ~count:1000 - ~print:Print.(triple int int int) - Gen.(triple small_nat small_nat small_nat) (fun (i,j,k) -> i+(j+k) = (i+j)+k) - - let quad_test = - Test.make ~name:"int quadruples - product of sums" ~count:1000 - ~print:Print.(quad int int int int) - Gen.(quad small_nat small_nat small_nat small_nat) - (fun (h,i,j,k) -> (h+i)*(j+k) = h*j + h*k + i*j + i*k) - - let bind_test = - Test.make ~name:"bind test for ordered pairs" ~count:1000 ~print:Print.(pair int int) - Gen.(small_nat >>= fun j -> int_bound j >>= fun i -> return (i,j)) - (fun (i,j) -> i<=j) - - let bind_pair_list_length = - Test.make ~name:"bind list length" ~count:1000 ~print:Print.(pair int (list int)) - Gen.(int_bound 1000 >>= fun len -> - list_size (return len) (int_bound 10) >>= fun xs -> return (len,xs)) - (fun (len,xs) -> len = List.length xs) - - let list_test = - Test.make ~name:"list has right length" ~count:1000 - ~print:Print.(list unit) - Gen.(list unit) (fun l -> let len = List.length l in 0 <= len && len < 10_000) - - let list_repeat_test = - Test.make ~name:"list_repeat has constant length" ~count:1000 - ~print:Print.(pair int (list unit)) - Gen.(small_nat >>= fun i -> list_repeat i unit >>= fun l -> return (i,l)) - (fun (i,l) -> List.length l = i) - - let array_repeat_test = - Test.make ~name:"array_repeat has constant length" ~count:1000 - ~print:Print.(pair int (array unit)) - Gen.(small_nat >>= fun i -> array_repeat i unit >>= fun l -> return (i,l)) - (fun (i,l) -> Array.length l = i) - - let passing_tree_rev = - Test.make ~name:"tree_rev_is_involutive" ~count:1000 - IntTree.gen_tree - (fun tree -> IntTree.(rev_tree (rev_tree tree)) = tree) - - let test_tup2 = - Test.make ~count:10 - ~name:"forall x in (0, 1): x = (0, 1)" - Gen.(tup2 (pure 0) (pure 1)) - (fun x -> x = (0, 1)) - - let test_tup3 = - Test.make ~count:10 - ~name:"forall x in (0, 1, 2): x = (0, 1, 2)" - Gen.(tup3 (pure 0) (pure 1) (pure 2)) - (fun x -> x = (0, 1, 2)) - - let test_tup4 = - Test.make ~count:10 - ~name:"forall x in (0, 1, 2, 3): x = (0, 1, 2, 3)" - Gen.(tup4 (pure 0) (pure 1) (pure 2) (pure 3)) - (fun x -> x = (0, 1, 2, 3)) - - let test_tup5 = - Test.make ~count:10 - ~name:"forall x in (0, 1, 2, 3, 4): x = (0, 1, 2, 3, 4)" - Gen.(tup5 (pure 0) (pure 1) (pure 2) (pure 3) (pure 4)) - (fun x -> x = (0, 1, 2, 3, 4)) - - let test_tup6 = - Test.make ~count:10 - ~name:"forall x in (0, 1, 2, 3, 4, 5): x = (0, 1, 2, 3, 4, 5)" - Gen.(tup6 (pure 0) (pure 1) (pure 2) (pure 3) (pure 4) (pure 5)) - (fun x -> x = (0, 1, 2, 3, 4, 5)) - - let test_tup7 = - Test.make ~count:10 - ~name:"forall x in (0, 1, 2, 3, 4, 5, 6): x = (0, 1, 2, 3, 4, 5, 6)" - Gen.(tup7 - (pure 0) (pure 1) (pure 2) (pure 3) (pure 4) - (pure 5) (pure 6)) - (fun x -> x = (0, 1, 2, 3, 4, 5, 6)) - - let test_tup8 = - Test.make ~count:10 - ~name:"forall x in (0, 1, 2, 3, 4, 5, 6, 7): x = (0, 1, 2, 3, 4, 5, 6, 7)" - Gen.(tup8 - (pure 0) (pure 1) (pure 2) (pure 3) (pure 4) - (pure 5) (pure 6) (pure 7)) - (fun x -> x = (0, 1, 2, 3, 4, 5, 6, 7)) - - let test_tup9 = - Test.make ~count:10 - ~name:"forall x in (0, 1, 2, 3, 4, 5, 6, 7, 8): x = (0, 1, 2, 3, 4, 5, 6, 7, 8)" - Gen.(tup9 - (pure 0) (pure 1) (pure 2) (pure 3) (pure 4) - (pure 5) (pure 6) (pure 7) (pure 8)) - (fun x -> x = (0, 1, 2, 3, 4, 5, 6, 7, 8)) - - let tests = [ - char_dist_issue_23; - char_test; - nat_test; - string_test; - pair_test; - triple_test; - quad_test; - bind_test; - bind_pair_list_length; - list_test; - list_repeat_test; - array_repeat_test; - passing_tree_rev; - test_tup2; - test_tup3; - test_tup4; - test_tup5; - test_tup6; - test_tup7; - test_tup8; - test_tup9; - ] -end - -(* negative tests that exercise shrinking behaviour *) -module Shrink = struct - open QCheck2 - - let rec fac n = match n with - | 0 -> 1 - | n -> n * fac (n - 1) - - (* example from issue #59 *) - let test_fac_issue59 = - Test.make ~name:"test fac issue59" - (Gen.make_primitive ~gen:(fun st -> Gen.generate1 ~rand:st (Gen.small_int_corners ())) ~shrink:(fun _ -> Seq.empty)) - (fun n -> try (fac n) mod n = 0 - with - (*| Stack_overflow -> false*) - | Division_by_zero -> (n=0)) - - let big_bound_issue59 = - Test.make ~name:"big bound issue59" ~print:Print.int - (Gen.small_int_corners()) (fun i -> i < 209609) - - let long_shrink = - let listgen = Gen.(list_size (int_range 1000 10000) int) in - Test.make ~name:"long_shrink" ~print:Print.(pair (list int) (list int)) - (Gen.pair listgen listgen) - (fun (xs,ys) -> List.rev (xs@ys) = (List.rev xs)@(List.rev ys)) - - (* test from issue #36 *) - let ints_arent_0_mod_3 = - Test.make ~name:"ints arent 0 mod 3" ~count:1000 ~print:Print.int - Gen.int (fun i -> i mod 3 <> 0) - - let ints_are_0 = - Test.make ~name:"ints are 0" ~count:1000 ~print:Print.int - Gen.int (fun i -> Printf.printf "%i\n" i; i = 0) - - (* test from issue #59 *) - let ints_smaller_209609 = - Test.make ~name:"ints < 209609" ~print:Print.int - (Gen.small_int_corners()) (fun i -> i < 209609) - - let nats_smaller_5001 = - Test.make ~name:"nat < 5001" ~count:1000 ~print:Print.int - Gen.nat (fun n -> n < 5001) - - let char_is_never_abcdef = - Test.make ~name:"char is never produces 'abcdef'" ~count:1000 ~print:Print.char - Gen.char (fun c -> not (List.mem c ['a';'b';'c';'d';'e';'f'])) - - let strings_are_empty = - Test.make ~name:"strings are empty" ~count:1000 ~print:Print.string - 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 - Gen.string - (fun s -> String.to_seq s |> Seq.fold_left (fun acc c -> acc && c <> '\000') true) - - let string_never_has_255_char = - Test.make ~name:"string never has a \\255 char" ~count:1000 ~print:Print.string - Gen.string - (fun s -> String.to_seq s |> Seq.fold_left (fun acc c -> acc && c <> '\255') true) - - (* test from issue #167 *) - let pair_diff_issue_64 = - Test.make ~name:"pairs have different components" ~print:Print.(pair int int) - Gen.(pair small_int small_int) (fun (i,j) -> i<>j) - - let pair_same = - Test.make ~name:"pairs have same components" ~print:Print.(pair int int) - Gen.(pair int int) (fun (i,j) -> i=j) - - let pair_one_zero = - Test.make ~name:"pairs have a zero component" ~print:Print.(pair int int) - Gen.(pair int int) (fun (i,j) -> i=0 || j=0) - - let pair_all_zero = - Test.make ~name:"pairs are (0,0)" ~print:Print.(pair int int) - Gen.(pair int int) (fun (i,j) -> i=0 && j=0) - - let pair_ordered = - Test.make ~name:"pairs are ordered" ~print:Print.(pair int int) - Gen.(pair (pint ~origin:0) (pint ~origin:0)) (fun (i,j) -> i<=j) - - let pair_ordered_rev = - Test.make ~name:"pairs are ordered reversely" ~print:Print.(pair int int) - Gen.(pair (pint ~origin:0) (pint ~origin:0)) (fun (i,j) -> i>=j) - - let pair_sum_lt_128 = - Test.make ~name:"pairs sum to less than 128" ~print:Print.(pair int int) - Gen.(pair (pint ~origin:0) (pint ~origin:0)) (fun (i,j) -> i+j<128) - - let pair_lists_rev_concat = - Test.make ~name:"pairs lists rev concat" ~print:Print.(pair (list int) (list int)) - Gen.(pair (list (pint ~origin:0)) (list (pint ~origin:0))) - (fun (xs,ys) -> List.rev (xs@ys) = (List.rev xs)@(List.rev ys)) - - let pair_lists_no_overlap = - Test.make ~name:"pairs lists no overlap" ~print:Print.(pair (list int) (list int)) - Gen.(pair (list small_nat) (list small_nat)) - (fun (xs,ys) -> List.for_all (fun x -> not (List.mem x ys)) xs) - - let triple_diff = - Test.make ~name:"triples have pair-wise different components" ~print:Print.(triple int int int) - Gen.(triple small_int small_int small_int) (fun (i,j,k) -> i<>j && j<>k) - - let triple_same = - Test.make ~name:"triples have same components" ~print:Print.(triple int int int) - Gen.(triple int int int) (fun (i,j,k) -> i=j || j=k) - - let triple_ordered = - Test.make ~name:"triples are ordered" ~print:Print.(triple int int int) - Gen.(triple int int int) (fun (i,j,k) -> i<=j && j<=k) - - let triple_ordered_rev = - Test.make ~name:"triples are ordered reversely" ~print:Print.(triple int int int) - Gen.(triple int int int) (fun (i,j,k) -> i>=j && j>=k) - - let quad_diff = - Test.make ~name:"quadruples have pair-wise different components" ~print:Print.(quad int int int int) - Gen.(quad small_int small_int small_int small_int) (fun (h,i,j,k) -> h<>i && i<>j && j<>k) - - let quad_same = - Test.make ~name:"quadruples have same components" ~print:Print.(quad int int int int) - Gen.(quad int int int int) (fun (h,i,j,k) -> h=i || i=j || j=k) - - let quad_ordered = - Test.make ~name:"quadruples are ordered" ~print:Print.(quad int int int int) - Gen.(quad int int int int) (fun (h,i,j,k) -> h <= i && i <= j && j <= k) - - let quad_ordered_rev = - Test.make ~name:"quadruples are ordered reversely" ~print:Print.(quad int int int int) - Gen.(quad int int int int) (fun (h,i,j,k) -> h >= i && i >= j && j >= k) - - let bind_pair_ordered = - Test.make ~name:"bind ordered pairs" ~print:Print.(pair int int) - Gen.(int >>= fun j -> int_bound j >>= fun i -> return (i,j)) - (fun (_i,_j) -> false) - - let bind_pair_list_size = - Test.make ~name:"bind list_size constant" ~print:Print.(pair int (list int)) - Gen.(int_bound 1000 >>= fun len -> - list_size (return len) (int_bound 1000) >>= fun xs -> return (len,xs)) - (fun (len,xs) -> let len' = List.length xs in len=len' && len' < 4) - - (* tests from issue #64 *) - let print_list xs = print_endline Print.(list int xs) - - let lists_are_empty_issue_64 = - Test.make ~name:"lists are empty" ~print:Print.(list int) - Gen.(list small_int) (fun xs -> print_list xs; xs = []) - - let list_shorter_10 = - Test.make ~name:"lists shorter than 10" ~print:Print.(list int) - Gen.(list small_int) (fun xs -> List.length xs < 10) - - let length_printer xs = - Printf.sprintf "[...] list length: %i" (List.length xs) - - let size_gen = Gen.(oneof [small_nat; int_bound 750_000]) - - let list_shorter_432 = - Test.make ~name:"lists shorter than 432" ~print:length_printer - 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) - (fun xs -> List.length xs < 4332) - - let list_equal_dupl = - 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) - - let list_unique_elems = - Test.make ~name:"lists have unique elems" ~print:Print.(list int) - Gen.(list small_int) - (fun xs -> let ys = List.sort_uniq Int.compare xs in - print_list xs; List.length xs = List.length ys) - - let tree_contains_only_42 = - Test.make ~name:"tree contains only 42" ~print:IntTree.print_tree - IntTree.gen_tree - (fun tree -> IntTree.contains_only_n tree 42) - - let test_tup2 = - Test.make - ~print:Print.(tup2 int int) - ~name:"forall (a, b) in nat: a < b" - Gen.(tup2 small_int small_int) - (fun (a, b) -> a < b) - - let test_tup3 = - Test.make - ~print:Print.(tup3 int int int) - ~name:"forall (a, b, c) in nat: a < b < c" - Gen.(tup3 small_int small_int small_int) - (fun (a, b, c) -> a < b && b < c) - - let test_tup4 = - Test.make - ~print:Print.(tup4 int int int int) - ~name:"forall (a, b, c, d) in nat: a < b < c < d" - Gen.(tup4 small_int small_int small_int small_int) - (fun (a, b, c, d) -> a < b && b < c && c < d) - - let test_tup5 = - Test.make - ~print:Print.(tup5 int int int int int) - ~name:"forall (a, b, c, d, e) in nat: a < b < c < d < e" - Gen.(tup5 small_int small_int small_int small_int small_int) - (fun (a, b, c, d, e) -> a < b && b < c && c < d && d < e) - - let test_tup6 = - Test.make - ~print:Print.(tup6 int int int int int int) - ~name:"forall (a, b, c, d, e, f) in nat: a < b < c < d < e < f" - Gen.(tup6 small_int small_int small_int small_int small_int small_int) - (fun (a, b, c, d, e, f) -> a < b && b < c && c < d && d < e && e < f) - - let test_tup7 = - Test.make - ~print:Print.(tup7 int int int int int int int) - ~name:"forall (a, b, c, d, e, f, g) in nat: a < b < c < d < e < f < g" - Gen.(tup7 small_int small_int small_int small_int small_int small_int small_int) - (fun (a, b, c, d, e, f, g) -> a < b && b < c && c < d && d < e && e < f && f < g) - - let test_tup8 = - Test.make - ~print:Print.(tup8 int int int int int int int int) - ~name:"forall (a, b, c, d, e, f, g, h) in nat: a < b < c < d < e < f < g < h" - Gen.(tup8 small_int small_int small_int small_int small_int small_int small_int small_int) - (fun (a, b, c, d, e, f, g, h) -> a < b && b < c && c < d && d < e && e < f && f < g && g < h) - - let test_tup9 = - Test.make - ~print:Print.(tup9 int int int int int int int int int) - ~name:"forall (a, b, c, d, e, f, g, h, i) in nat: a < b < c < d < e < f < g < h < i" - Gen.(tup9 small_int small_int small_int small_int small_int small_int small_int small_int small_int) - (fun (a, b, c, d, e, f, g, h, i) -> a < b && b < c && c < d && d < e && e < f && f < g && g < h && h < i) - - let tests = [ - (*test_fac_issue59;*) - big_bound_issue59; - long_shrink; - ints_arent_0_mod_3; - ints_are_0; - ints_smaller_209609; - nats_smaller_5001; - char_is_never_abcdef; - strings_are_empty; - string_never_has_000_char; - string_never_has_255_char; - pair_diff_issue_64; - pair_same; - pair_one_zero; - pair_all_zero; - pair_ordered; - pair_ordered_rev; - pair_sum_lt_128; - pair_lists_rev_concat; - pair_lists_no_overlap; - triple_diff; - triple_same; - triple_ordered; - triple_ordered_rev; - quad_diff; - quad_same; - quad_ordered; - quad_ordered_rev; - bind_pair_ordered; - bind_pair_list_size; - lists_are_empty_issue_64; - list_shorter_10; - list_shorter_432; - list_shorter_4332; - list_equal_dupl; - list_unique_elems; - tree_contains_only_42; - test_tup2; - test_tup3; - test_tup4; - test_tup5; - test_tup6; - test_tup7; - test_tup8; - test_tup9; - ] -end - -(* tests function generator and shrinker *) -module Function = struct - open QCheck2 - - let fail_pred_map_commute = - Test.make ~name:"fail_pred_map_commute" ~count:100 ~long_factor:100 - ~print:Print.(triple (list int) Fn.print Fn.print) - Gen.(triple - (small_list small_int) - (fun1 ~print:Print.int Observable.int int) - (fun1 ~print:Print.bool Observable.int bool)) - (fun (l,Fun (_,f),Fun (_,p)) -> - List.filter p (List.map f l) = List.map f (List.filter p l)) - - let fail_pred_strings = - Test.make ~name:"fail_pred_strings" ~count:100 ~print:Fn.print - (fun1 Observable.string ~print:Print.bool Gen.bool) - (fun (Fun (_,p)) -> not (p "some random string") || p "some other string") - - let int_gen = Gen.small_nat (* int *) - - (* Another example (false) property *) - let prop_foldleft_foldright = - Test.make ~name:"fold_left fold_right" ~count:1000 ~long_factor:20 - ~print:Print.(triple int (list int) Fn.print) - Gen.(triple - int_gen - (list int_gen) - (fun2 ~print:Print.int Observable.int Observable.int int_gen)) - (fun (z,xs,f) -> - let l1 = List.fold_right (Fn.apply f) xs z in - let l2 = List.fold_left (Fn.apply f) z xs in - if l1=l2 then true - else Test.fail_reportf "l=%s, fold_left=%s, fold_right=%s@." - (Print.(list int) xs) - (Print.int l1) - (Print.int l2) - ) - - (* Another example (false) property *) - let prop_foldleft_foldright_uncurry = - Test.make ~name:"fold_left fold_right uncurried" ~count:1000 ~long_factor:20 - ~print:Print.(triple Fn.print int (list int)) - Gen.(triple - (fun1 ~print:Print.int Observable.(pair int int) int_gen) - int_gen - (list int_gen)) - (fun (f,z,xs) -> - List.fold_right (fun x y -> Fn.apply f (x,y)) xs z = - List.fold_left (fun x y -> Fn.apply f (x,y)) z xs) - - (* Same as the above (false) property, but generating+shrinking functions last *) - let prop_foldleft_foldright_uncurry_funlast = - Test.make ~name:"fold_left fold_right uncurried fun last" ~count:1000 ~long_factor:20 - ~print:Print.(triple int (list int) Fn.print) - Gen.(triple - int_gen - (list int_gen) - (fun1 ~print:Print.int Observable.(pair int int) int_gen)) - (fun (z,xs,f) -> - List.fold_right (fun x y -> Fn.apply f (x,y)) xs z = - List.fold_left (fun x y -> Fn.apply f (x,y)) z xs) - - (* test from issue #64 *) - let fold_left_test = - Test.make ~name:"fold_left test, fun first" ~print:Print.(quad Fn.print string (list int) (list int)) - Gen.(quad (* string -> int -> string *) - (fun2 ~print:Print.string Observable.string Observable.int (small_string ~gen:char)) - (small_string ~gen:char) - (list small_int) - (list small_int)) - (fun (f,acc,is,js) -> - let f = Fn.apply f in - List.fold_left f acc (is @ js) - = List.fold_left f (List.fold_left f acc is) is) (*Typo*) - - let tests = [ - fail_pred_map_commute; - fail_pred_strings; - prop_foldleft_foldright; - prop_foldleft_foldright_uncurry; - prop_foldleft_foldright_uncurry_funlast; - fold_left_test; - ] -end - -(* tests of (inner) find_example(_gen) behaviour *) -module FindExample = struct - open QCheck2 - - let find_ex = - Test.make ~name:"find_example" ~print:Print.int - Gen.(2--50) - (fun n -> - let st = Random.State.make [| 0 |] in - let f m = n < m && m < 2 * n in - try - let m = find_example_gen ~rand:st ~count:100_000 ~f Gen.(0 -- 1000) in - f m - with No_example_found _ -> false) - - let find_ex_uncaught_issue_99_1_fail = - let rs = (find_example ~count:10 ~f:(fun _ -> false) Gen.int) in - Test.make ~name:"FAIL_#99_1" rs (fun _ -> true) - - let find_ex_uncaught_issue_99_2_succeed = - Test.make ~name:"should_succeed_#99_2" ~count:10 - Gen.int (fun i -> i <= max_int) - - let tests = [ - find_ex; - find_ex_uncaught_issue_99_1_fail; - find_ex_uncaught_issue_99_2_succeed; - ] -end - -(* tests of statistics and histogram display *) -module Stats = struct - open QCheck2 - - let bool_dist = - Test.make ~name:"bool dist" ~count:500_000 ~collect:Bool.to_string Gen.bool (fun _ -> true) - - let char_dist = - Test.make ~name:"char code dist" ~count:500_000 ~stats:[("char code", Char.code)] Gen.char (fun _ -> true) - - let string_len_tests = - let len = ("len",String.length) in - [ - Test.make ~name:"string_size len dist" ~count:5_000 ~stats:[len] Gen.(string_size (int_range 5 10)) (fun _ -> true); - Test.make ~name:"string len dist" ~count:5_000 ~stats:[len] Gen.string (fun _ -> true); - Test.make ~name:"string_of len dist" ~count:5_000 ~stats:[len] Gen.(string_of (return 'a')) (fun _ -> true); - Test.make ~name:"string_printable len dist" ~count:5_000 ~stats:[len] Gen.string_printable (fun _ -> true); - Test.make ~name:"small_string len dist" ~count:5_000 ~stats:[len] Gen.(small_string ~gen:char)(*ugh*)(fun _ -> true); - ] - - let pair_dist = - Test.make ~name:"pair dist" ~count:500_000 ~stats:[("pair sum", (fun (i,j) -> i+j))] - Gen.(pair (int_bound 100) (int_bound 100)) (fun _ -> true) - - let triple_dist = - Test.make ~name:"triple dist" ~count:500_000 ~stats:[("triple sum", (fun (i,j,k) -> i+j+k))] - Gen.(triple (int_bound 100) (int_bound 100) (int_bound 100)) (fun _ -> true) - - let quad_dist = - Test.make ~name:"quad dist" ~count:500_000 ~stats:[("quad sum", (fun (h,i,j,k) -> h+i+j+k))] - Gen.(quad (int_bound 100) (int_bound 100) (int_bound 100) (int_bound 100)) (fun _ -> true) - - let bind_dist = - Test.make ~name:"bind dist" ~count:1_000_000 - ~stats:[("ordered pair difference", (fun (i,j) -> j-i));("ordered pair sum", (fun (i,j) -> i+j))] - Gen.(int_bound 100 >>= fun j -> int_bound j >>= fun i -> return (i,j)) (fun _ -> true) - - let list_len_tests = - let len = ("len",List.length) in - [ (* test from issue #30 *) - Test.make ~name:"list len dist" ~count:5_000 ~stats:[len] Gen.(list int) (fun _ -> true); - Test.make ~name:"small_list len dist" ~count:5_000 ~stats:[len] Gen.(small_list int) (fun _ -> true); - Test.make ~name:"list_size len dist" ~count:5_000 ~stats:[len] Gen.(list_size (int_range 5 10) int) (fun _ -> true); - Test.make ~name:"list_repeat len dist" ~count:5_000 ~stats:[len] Gen.(list_repeat 42 int) (fun _ -> true); - ] - - let array_len_tests = - let len = ("len",Array.length) in - [ - Test.make ~name:"array len dist" ~count:5_000 ~stats:[len] Gen.(array int) (fun _ -> true); - Test.make ~name:"small_array len dist" ~count:5_000 ~stats:[len] Gen.(small_array int) (fun _ -> true); - Test.make ~name:"array_size len dist" ~count:5_000 ~stats:[len] Gen.(array_size (int_range 5 10) int) (fun _ -> true); - Test.make ~name:"array_repeat len dist" ~count:5_000 ~stats:[len] Gen.(array_repeat 42 int) (fun _ -> true); - ] - - let int_dist_tests = - let dist = ("dist",fun x -> x) in - [ - (* test from issue #40 *) - Test.make ~name:"int_stats_neg" ~count:5000 ~stats:[dist] Gen.small_signed_int (fun _ -> true); - (* distribution tests from PR #45 *) - Test.make ~name:"small_signed_int dist" ~count:1000 ~stats:[dist] Gen.small_signed_int (fun _ -> true); - Test.make ~name:"small_nat dist" ~count:1000 ~stats:[dist] Gen.small_nat (fun _ -> true); - Test.make ~name:"nat dist" ~count:1000 ~stats:[dist] Gen.nat (fun _ -> true); - Test.make ~name:"int_range (-43643) 435434 dist" ~count:1000 ~stats:[dist] (Gen.int_range (-43643) 435434) (fun _ -> true); - Test.make ~name:"int_range (-40000) 40000 dist" ~count:1000 ~stats:[dist] (Gen.int_range (-40000) 40000) (fun _ -> true); - Test.make ~name:"int_range (-4) 4 dist" ~count:1000 ~stats:[dist] (Gen.int_range (-4) 4) (fun _ -> true); - Test.make ~name:"int_range (-4) 17 dist" ~count:1000 ~stats:[dist] (Gen.int_range (-4) 17) (fun _ -> true); - Test.make ~name:"int dist" ~count:100000 ~stats:[dist] Gen.int (fun _ -> true); - Test.make ~name:"oneof int dist" ~count:1000 ~stats:[dist] (Gen.oneofl[min_int;-1;0;1;max_int]) (fun _ -> true); - ] - - let int_dist_empty_bucket = - Test.make ~name:"int_dist_empty_bucket" ~count:1_000 ~stats:[("dist",fun x -> x)] - Gen.(oneof [small_int_corners ();int]) (fun _ -> true) - - let tree_depth_test = - let depth = ("depth", IntTree.depth) in - Test.make ~name:"tree's depth" ~count:1000 ~stats:[depth] IntTree.gen_tree (fun _ -> true) - - let tests = - [ - bool_dist; - char_dist; - tree_depth_test - ] - @ string_len_tests - @ [pair_dist; - triple_dist; - quad_dist; - bind_dist;] - @ list_len_tests - @ array_len_tests - @ int_dist_tests - -end +open QCheck2_tests (* Calling runners *) @@ -771,4 +14,3 @@ let _ = let () = QCheck_base_runner.set_seed 153870556 let _ = QCheck_base_runner.run_tests ~colors:false [Stats.int_dist_empty_bucket] - diff --git a/test/core/QCheck2_tests.ml b/test/core/QCheck2_tests.ml new file mode 100644 index 00000000..f53b2e64 --- /dev/null +++ b/test/core/QCheck2_tests.ml @@ -0,0 +1,754 @@ +(** QCheck2 tests **) + +(** Module representing a integer tree data structure, used in tests *) +module IntTree = struct + type tree = Leaf of int | Node of tree * tree + + let leaf x = Leaf x + let node x y = Node (x,y) + + let rec depth = function + | Leaf _ -> 1 + | Node (x, y) -> 1 + max (depth x) (depth y) + + let rec print_tree = function + | Leaf x -> Printf.sprintf "Leaf %d" x + | Node (x, y) -> Printf.sprintf "Node (%s, %s)" (print_tree x) (print_tree y) + + let gen_tree = QCheck2.Gen.(sized @@ fix + (fun self n -> match n with + | 0 -> map leaf nat + | n -> + frequency + [1, map leaf nat; + 2, map2 node (self (n/2)) (self (n/2))] + )) + + let rec rev_tree = function + | Node (x, y) -> Node (rev_tree y, rev_tree x) + | Leaf x -> Leaf x + + let rec contains_only_n tree n = match tree with + | Leaf n' -> n = n' + | Node (x, y) -> contains_only_n x n && contains_only_n y n +end + +(* tests of overall functionality *) +module Overall = struct + open QCheck2 + + let passing = + Test.make ~name:"list_rev_is_involutive" ~count:100 ~long_factor:100 + ~print:Print.(list int) + Gen.(list small_int) (fun l -> List.rev (List.rev l) = l) + + let failing = + Test.make ~name:"should_fail_sort_id" ~count:10 ~print:Print.(list int) + Gen.(small_list small_int) (fun l -> l = List.sort compare l) + + exception Error + + let error = + Test.make ~name:"should_error_raise_exn" ~count:10 ~print:Print.int + Gen.int (fun _ -> raise Error) + + let collect = + Test.make ~name:"collect_results" ~count:100 ~long_factor:100 + ~print:Print.int ~collect:string_of_int + (Gen.int_bound 4) (fun _ -> true) + + let stats = + Test.make ~name:"with_stats" ~count:100 ~long_factor:100 ~print:Print.int + ~stats:[ + "mod4", (fun i->i mod 4); + "num", (fun i->i); + ] + (Gen.int_bound 120) (fun _ -> true) + + let retries = + Test.make ~name:"with shrinking retries" ~retries:10 ~print:Print.int + Gen.small_nat (fun i -> Printf.printf "%i %!" i; i mod 3 <> 1) + + let bad_assume_warn = + Test.make ~name:"WARN_unlikely_precond" ~count:2_000 ~print:Print.int + Gen.int + (fun x -> + QCheck.assume (x mod 100 = 1); + true) + + let bad_assume_fail = + Test.make ~name:"FAIL_unlikely_precond" ~count:2_000 + ~if_assumptions_fail:(`Fatal, 0.1) ~print:Print.int + Gen.int + (fun x -> + QCheck.assume (x mod 100 = 1); + true) + + let tests = [ + passing; + failing; + error; + collect; + stats; + retries; + bad_assume_warn; + bad_assume_fail; + ] +end + +(* positive tests of the various generators *) +module Generator = struct + open QCheck2 + + (* example from issue #23 *) + let char_dist_issue_23 = + Test.make ~name:"char never produces '\\255'" ~count:1_000_000 + ~print:Print.char + Gen.char (fun c -> c <> '\255') + + let char_test = + Test.make ~name:"char has right range'" ~count:1000 ~print:Print.char + Gen.char (fun c -> '\000' <= c && c <= '\255') + + let nat_test = + Test.make ~name:"nat has right range" ~count:1000 ~print:Print.int + Gen.nat (fun n -> 0 <= n && n < 10000) + + let string_test = + Test.make ~name:"string has right length and content" ~count:1000 ~print:Print.string + Gen.string + (fun s -> + let len = String.length s in + 0 <= len && len < 10000 + && String.to_seq s |> + Seq.fold_left (fun acc c -> acc && '\000' <= c && c <= '\255') true) + + let pair_test = + Test.make ~name:"int pairs - commute over +" ~count:1000 ~print:Print.(pair int int) + Gen.(pair small_nat small_nat) (fun (i,j) -> i+j = j+i) + + let triple_test = + Test.make ~name:"int triples - associative over +" ~count:1000 + ~print:Print.(triple int int int) + Gen.(triple small_nat small_nat small_nat) (fun (i,j,k) -> i+(j+k) = (i+j)+k) + + let quad_test = + Test.make ~name:"int quadruples - product of sums" ~count:1000 + ~print:Print.(quad int int int int) + Gen.(quad small_nat small_nat small_nat small_nat) + (fun (h,i,j,k) -> (h+i)*(j+k) = h*j + h*k + i*j + i*k) + + let bind_test = + Test.make ~name:"bind test for ordered pairs" ~count:1000 ~print:Print.(pair int int) + Gen.(small_nat >>= fun j -> int_bound j >>= fun i -> return (i,j)) + (fun (i,j) -> i<=j) + + let bind_pair_list_length = + Test.make ~name:"bind list length" ~count:1000 ~print:Print.(pair int (list int)) + Gen.(int_bound 1000 >>= fun len -> + list_size (return len) (int_bound 10) >>= fun xs -> return (len,xs)) + (fun (len,xs) -> len = List.length xs) + + let list_test = + Test.make ~name:"list has right length" ~count:1000 + ~print:Print.(list unit) + Gen.(list unit) (fun l -> let len = List.length l in 0 <= len && len < 10_000) + + let list_repeat_test = + Test.make ~name:"list_repeat has constant length" ~count:1000 + ~print:Print.(pair int (list unit)) + Gen.(small_nat >>= fun i -> list_repeat i unit >>= fun l -> return (i,l)) + (fun (i,l) -> List.length l = i) + + let array_repeat_test = + Test.make ~name:"array_repeat has constant length" ~count:1000 + ~print:Print.(pair int (array unit)) + Gen.(small_nat >>= fun i -> array_repeat i unit >>= fun l -> return (i,l)) + (fun (i,l) -> Array.length l = i) + + let passing_tree_rev = + Test.make ~name:"tree_rev_is_involutive" ~count:1000 + IntTree.gen_tree + (fun tree -> IntTree.(rev_tree (rev_tree tree)) = tree) + + let test_tup2 = + Test.make ~count:10 + ~name:"forall x in (0, 1): x = (0, 1)" + Gen.(tup2 (pure 0) (pure 1)) + (fun x -> x = (0, 1)) + + let test_tup3 = + Test.make ~count:10 + ~name:"forall x in (0, 1, 2): x = (0, 1, 2)" + Gen.(tup3 (pure 0) (pure 1) (pure 2)) + (fun x -> x = (0, 1, 2)) + + let test_tup4 = + Test.make ~count:10 + ~name:"forall x in (0, 1, 2, 3): x = (0, 1, 2, 3)" + Gen.(tup4 (pure 0) (pure 1) (pure 2) (pure 3)) + (fun x -> x = (0, 1, 2, 3)) + + let test_tup5 = + Test.make ~count:10 + ~name:"forall x in (0, 1, 2, 3, 4): x = (0, 1, 2, 3, 4)" + Gen.(tup5 (pure 0) (pure 1) (pure 2) (pure 3) (pure 4)) + (fun x -> x = (0, 1, 2, 3, 4)) + + let test_tup6 = + Test.make ~count:10 + ~name:"forall x in (0, 1, 2, 3, 4, 5): x = (0, 1, 2, 3, 4, 5)" + Gen.(tup6 (pure 0) (pure 1) (pure 2) (pure 3) (pure 4) (pure 5)) + (fun x -> x = (0, 1, 2, 3, 4, 5)) + + let test_tup7 = + Test.make ~count:10 + ~name:"forall x in (0, 1, 2, 3, 4, 5, 6): x = (0, 1, 2, 3, 4, 5, 6)" + Gen.(tup7 + (pure 0) (pure 1) (pure 2) (pure 3) (pure 4) + (pure 5) (pure 6)) + (fun x -> x = (0, 1, 2, 3, 4, 5, 6)) + + let test_tup8 = + Test.make ~count:10 + ~name:"forall x in (0, 1, 2, 3, 4, 5, 6, 7): x = (0, 1, 2, 3, 4, 5, 6, 7)" + Gen.(tup8 + (pure 0) (pure 1) (pure 2) (pure 3) (pure 4) + (pure 5) (pure 6) (pure 7)) + (fun x -> x = (0, 1, 2, 3, 4, 5, 6, 7)) + + let test_tup9 = + Test.make ~count:10 + ~name:"forall x in (0, 1, 2, 3, 4, 5, 6, 7, 8): x = (0, 1, 2, 3, 4, 5, 6, 7, 8)" + Gen.(tup9 + (pure 0) (pure 1) (pure 2) (pure 3) (pure 4) + (pure 5) (pure 6) (pure 7) (pure 8)) + (fun x -> x = (0, 1, 2, 3, 4, 5, 6, 7, 8)) + + let tests = [ + char_dist_issue_23; + char_test; + nat_test; + string_test; + pair_test; + triple_test; + quad_test; + bind_test; + bind_pair_list_length; + list_test; + list_repeat_test; + array_repeat_test; + passing_tree_rev; + test_tup2; + test_tup3; + test_tup4; + test_tup5; + test_tup6; + test_tup7; + test_tup8; + test_tup9; + ] +end + +(* negative tests that exercise shrinking behaviour *) +module Shrink = struct + open QCheck2 + + let rec fac n = match n with + | 0 -> 1 + | n -> n * fac (n - 1) + + (* example from issue #59 *) + let test_fac_issue59 = + Test.make ~name:"test fac issue59" + (Gen.make_primitive ~gen:(fun st -> Gen.generate1 ~rand:st (Gen.small_int_corners ())) ~shrink:(fun _ -> Seq.empty)) + (fun n -> try (fac n) mod n = 0 + with + (*| Stack_overflow -> false*) + | Division_by_zero -> (n=0)) + + let big_bound_issue59 = + Test.make ~name:"big bound issue59" ~print:Print.int + (Gen.small_int_corners()) (fun i -> i < 209609) + + let long_shrink = + let listgen = Gen.(list_size (int_range 1000 10000) int) in + Test.make ~name:"long_shrink" ~print:Print.(pair (list int) (list int)) + (Gen.pair listgen listgen) + (fun (xs,ys) -> List.rev (xs@ys) = (List.rev xs)@(List.rev ys)) + + (* test from issue #36 *) + let ints_arent_0_mod_3 = + Test.make ~name:"ints arent 0 mod 3" ~count:1000 ~print:Print.int + Gen.int (fun i -> i mod 3 <> 0) + + let ints_are_0 = + Test.make ~name:"ints are 0" ~count:1000 ~print:Print.int + Gen.int (fun i -> Printf.printf "%i\n" i; i = 0) + + (* test from issue #59 *) + let ints_smaller_209609 = + Test.make ~name:"ints < 209609" ~print:Print.int + (Gen.small_int_corners()) (fun i -> i < 209609) + + let nats_smaller_5001 = + Test.make ~name:"nat < 5001" ~count:1000 ~print:Print.int + Gen.nat (fun n -> n < 5001) + + let char_is_never_abcdef = + Test.make ~name:"char is never produces 'abcdef'" ~count:1000 ~print:Print.char + Gen.char (fun c -> not (List.mem c ['a';'b';'c';'d';'e';'f'])) + + let strings_are_empty = + Test.make ~name:"strings are empty" ~count:1000 ~print:Print.string + 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 + Gen.string + (fun s -> String.to_seq s |> Seq.fold_left (fun acc c -> acc && c <> '\000') true) + + let string_never_has_255_char = + Test.make ~name:"string never has a \\255 char" ~count:1000 ~print:Print.string + Gen.string + (fun s -> String.to_seq s |> Seq.fold_left (fun acc c -> acc && c <> '\255') true) + + (* test from issue #167 *) + let pair_diff_issue_64 = + Test.make ~name:"pairs have different components" ~print:Print.(pair int int) + Gen.(pair small_int small_int) (fun (i,j) -> i<>j) + + let pair_same = + Test.make ~name:"pairs have same components" ~print:Print.(pair int int) + Gen.(pair int int) (fun (i,j) -> i=j) + + let pair_one_zero = + Test.make ~name:"pairs have a zero component" ~print:Print.(pair int int) + Gen.(pair int int) (fun (i,j) -> i=0 || j=0) + + let pair_all_zero = + Test.make ~name:"pairs are (0,0)" ~print:Print.(pair int int) + Gen.(pair int int) (fun (i,j) -> i=0 && j=0) + + let pair_ordered = + Test.make ~name:"pairs are ordered" ~print:Print.(pair int int) + Gen.(pair (pint ~origin:0) (pint ~origin:0)) (fun (i,j) -> i<=j) + + let pair_ordered_rev = + Test.make ~name:"pairs are ordered reversely" ~print:Print.(pair int int) + Gen.(pair (pint ~origin:0) (pint ~origin:0)) (fun (i,j) -> i>=j) + + let pair_sum_lt_128 = + Test.make ~name:"pairs sum to less than 128" ~print:Print.(pair int int) + Gen.(pair (pint ~origin:0) (pint ~origin:0)) (fun (i,j) -> i+j<128) + + let pair_lists_rev_concat = + Test.make ~name:"pairs lists rev concat" ~print:Print.(pair (list int) (list int)) + Gen.(pair (list (pint ~origin:0)) (list (pint ~origin:0))) + (fun (xs,ys) -> List.rev (xs@ys) = (List.rev xs)@(List.rev ys)) + + let pair_lists_no_overlap = + Test.make ~name:"pairs lists no overlap" ~print:Print.(pair (list int) (list int)) + Gen.(pair (list small_nat) (list small_nat)) + (fun (xs,ys) -> List.for_all (fun x -> not (List.mem x ys)) xs) + + let triple_diff = + Test.make ~name:"triples have pair-wise different components" ~print:Print.(triple int int int) + Gen.(triple small_int small_int small_int) (fun (i,j,k) -> i<>j && j<>k) + + let triple_same = + Test.make ~name:"triples have same components" ~print:Print.(triple int int int) + Gen.(triple int int int) (fun (i,j,k) -> i=j || j=k) + + let triple_ordered = + Test.make ~name:"triples are ordered" ~print:Print.(triple int int int) + Gen.(triple int int int) (fun (i,j,k) -> i<=j && j<=k) + + let triple_ordered_rev = + Test.make ~name:"triples are ordered reversely" ~print:Print.(triple int int int) + Gen.(triple int int int) (fun (i,j,k) -> i>=j && j>=k) + + let quad_diff = + Test.make ~name:"quadruples have pair-wise different components" ~print:Print.(quad int int int int) + Gen.(quad small_int small_int small_int small_int) (fun (h,i,j,k) -> h<>i && i<>j && j<>k) + + let quad_same = + Test.make ~name:"quadruples have same components" ~print:Print.(quad int int int int) + Gen.(quad int int int int) (fun (h,i,j,k) -> h=i || i=j || j=k) + + let quad_ordered = + Test.make ~name:"quadruples are ordered" ~print:Print.(quad int int int int) + Gen.(quad int int int int) (fun (h,i,j,k) -> h <= i && i <= j && j <= k) + + let quad_ordered_rev = + Test.make ~name:"quadruples are ordered reversely" ~print:Print.(quad int int int int) + Gen.(quad int int int int) (fun (h,i,j,k) -> h >= i && i >= j && j >= k) + + let bind_pair_ordered = + Test.make ~name:"bind ordered pairs" ~print:Print.(pair int int) + Gen.(int >>= fun j -> int_bound j >>= fun i -> return (i,j)) + (fun (_i,_j) -> false) + + let bind_pair_list_size = + Test.make ~name:"bind list_size constant" ~print:Print.(pair int (list int)) + Gen.(int_bound 1000 >>= fun len -> + list_size (return len) (int_bound 1000) >>= fun xs -> return (len,xs)) + (fun (len,xs) -> let len' = List.length xs in len=len' && len' < 4) + + (* tests from issue #64 *) + let print_list xs = print_endline Print.(list int xs) + + let lists_are_empty_issue_64 = + Test.make ~name:"lists are empty" ~print:Print.(list int) + Gen.(list small_int) (fun xs -> print_list xs; xs = []) + + let list_shorter_10 = + Test.make ~name:"lists shorter than 10" ~print:Print.(list int) + Gen.(list small_int) (fun xs -> List.length xs < 10) + + let length_printer xs = + Printf.sprintf "[...] list length: %i" (List.length xs) + + let size_gen = Gen.(oneof [small_nat; int_bound 750_000]) + + let list_shorter_432 = + Test.make ~name:"lists shorter than 432" ~print:length_printer + 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) + (fun xs -> List.length xs < 4332) + + let list_equal_dupl = + 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) + + let list_unique_elems = + Test.make ~name:"lists have unique elems" ~print:Print.(list int) + Gen.(list small_int) + (fun xs -> let ys = List.sort_uniq Int.compare xs in + print_list xs; List.length xs = List.length ys) + + let tree_contains_only_42 = + Test.make ~name:"tree contains only 42" ~print:IntTree.print_tree + IntTree.gen_tree + (fun tree -> IntTree.contains_only_n tree 42) + + let test_tup2 = + Test.make + ~print:Print.(tup2 int int) + ~name:"forall (a, b) in nat: a < b" + Gen.(tup2 small_int small_int) + (fun (a, b) -> a < b) + + let test_tup3 = + Test.make + ~print:Print.(tup3 int int int) + ~name:"forall (a, b, c) in nat: a < b < c" + Gen.(tup3 small_int small_int small_int) + (fun (a, b, c) -> a < b && b < c) + + let test_tup4 = + Test.make + ~print:Print.(tup4 int int int int) + ~name:"forall (a, b, c, d) in nat: a < b < c < d" + Gen.(tup4 small_int small_int small_int small_int) + (fun (a, b, c, d) -> a < b && b < c && c < d) + + let test_tup5 = + Test.make + ~print:Print.(tup5 int int int int int) + ~name:"forall (a, b, c, d, e) in nat: a < b < c < d < e" + Gen.(tup5 small_int small_int small_int small_int small_int) + (fun (a, b, c, d, e) -> a < b && b < c && c < d && d < e) + + let test_tup6 = + Test.make + ~print:Print.(tup6 int int int int int int) + ~name:"forall (a, b, c, d, e, f) in nat: a < b < c < d < e < f" + Gen.(tup6 small_int small_int small_int small_int small_int small_int) + (fun (a, b, c, d, e, f) -> a < b && b < c && c < d && d < e && e < f) + + let test_tup7 = + Test.make + ~print:Print.(tup7 int int int int int int int) + ~name:"forall (a, b, c, d, e, f, g) in nat: a < b < c < d < e < f < g" + Gen.(tup7 small_int small_int small_int small_int small_int small_int small_int) + (fun (a, b, c, d, e, f, g) -> a < b && b < c && c < d && d < e && e < f && f < g) + + let test_tup8 = + Test.make + ~print:Print.(tup8 int int int int int int int int) + ~name:"forall (a, b, c, d, e, f, g, h) in nat: a < b < c < d < e < f < g < h" + Gen.(tup8 small_int small_int small_int small_int small_int small_int small_int small_int) + (fun (a, b, c, d, e, f, g, h) -> a < b && b < c && c < d && d < e && e < f && f < g && g < h) + + let test_tup9 = + Test.make + ~print:Print.(tup9 int int int int int int int int int) + ~name:"forall (a, b, c, d, e, f, g, h, i) in nat: a < b < c < d < e < f < g < h < i" + Gen.(tup9 small_int small_int small_int small_int small_int small_int small_int small_int small_int) + (fun (a, b, c, d, e, f, g, h, i) -> a < b && b < c && c < d && d < e && e < f && f < g && g < h && h < i) + + let tests = [ + (*test_fac_issue59;*) + big_bound_issue59; + long_shrink; + ints_arent_0_mod_3; + ints_are_0; + ints_smaller_209609; + nats_smaller_5001; + char_is_never_abcdef; + strings_are_empty; + string_never_has_000_char; + string_never_has_255_char; + pair_diff_issue_64; + pair_same; + pair_one_zero; + pair_all_zero; + pair_ordered; + pair_ordered_rev; + pair_sum_lt_128; + pair_lists_rev_concat; + pair_lists_no_overlap; + triple_diff; + triple_same; + triple_ordered; + triple_ordered_rev; + quad_diff; + quad_same; + quad_ordered; + quad_ordered_rev; + bind_pair_ordered; + bind_pair_list_size; + lists_are_empty_issue_64; + list_shorter_10; + list_shorter_432; + list_shorter_4332; + list_equal_dupl; + list_unique_elems; + tree_contains_only_42; + test_tup2; + test_tup3; + test_tup4; + test_tup5; + test_tup6; + test_tup7; + test_tup8; + test_tup9; + ] +end + +(* tests function generator and shrinker *) +module Function = struct + open QCheck2 + + let fail_pred_map_commute = + Test.make ~name:"fail_pred_map_commute" ~count:100 ~long_factor:100 + ~print:Print.(triple (list int) Fn.print Fn.print) + Gen.(triple + (small_list small_int) + (fun1 ~print:Print.int Observable.int int) + (fun1 ~print:Print.bool Observable.int bool)) + (fun (l,Fun (_,f),Fun (_,p)) -> + List.filter p (List.map f l) = List.map f (List.filter p l)) + + let fail_pred_strings = + Test.make ~name:"fail_pred_strings" ~count:100 ~print:Fn.print + (fun1 Observable.string ~print:Print.bool Gen.bool) + (fun (Fun (_,p)) -> not (p "some random string") || p "some other string") + + let int_gen = Gen.small_nat (* int *) + + (* Another example (false) property *) + let prop_foldleft_foldright = + Test.make ~name:"fold_left fold_right" ~count:1000 ~long_factor:20 + ~print:Print.(triple int (list int) Fn.print) + Gen.(triple + int_gen + (list int_gen) + (fun2 ~print:Print.int Observable.int Observable.int int_gen)) + (fun (z,xs,f) -> + let l1 = List.fold_right (Fn.apply f) xs z in + let l2 = List.fold_left (Fn.apply f) z xs in + if l1=l2 then true + else Test.fail_reportf "l=%s, fold_left=%s, fold_right=%s@." + (Print.(list int) xs) + (Print.int l1) + (Print.int l2) + ) + + (* Another example (false) property *) + let prop_foldleft_foldright_uncurry = + Test.make ~name:"fold_left fold_right uncurried" ~count:1000 ~long_factor:20 + ~print:Print.(triple Fn.print int (list int)) + Gen.(triple + (fun1 ~print:Print.int Observable.(pair int int) int_gen) + int_gen + (list int_gen)) + (fun (f,z,xs) -> + List.fold_right (fun x y -> Fn.apply f (x,y)) xs z = + List.fold_left (fun x y -> Fn.apply f (x,y)) z xs) + + (* Same as the above (false) property, but generating+shrinking functions last *) + let prop_foldleft_foldright_uncurry_funlast = + Test.make ~name:"fold_left fold_right uncurried fun last" ~count:1000 ~long_factor:20 + ~print:Print.(triple int (list int) Fn.print) + Gen.(triple + int_gen + (list int_gen) + (fun1 ~print:Print.int Observable.(pair int int) int_gen)) + (fun (z,xs,f) -> + List.fold_right (fun x y -> Fn.apply f (x,y)) xs z = + List.fold_left (fun x y -> Fn.apply f (x,y)) z xs) + + (* test from issue #64 *) + let fold_left_test = + Test.make ~name:"fold_left test, fun first" ~print:Print.(quad Fn.print string (list int) (list int)) + Gen.(quad (* string -> int -> string *) + (fun2 ~print:Print.string Observable.string Observable.int (small_string ~gen:char)) + (small_string ~gen:char) + (list small_int) + (list small_int)) + (fun (f,acc,is,js) -> + let f = Fn.apply f in + List.fold_left f acc (is @ js) + = List.fold_left f (List.fold_left f acc is) is) (*Typo*) + + let tests = [ + fail_pred_map_commute; + fail_pred_strings; + prop_foldleft_foldright; + prop_foldleft_foldright_uncurry; + prop_foldleft_foldright_uncurry_funlast; + fold_left_test; + ] +end + +(* tests of (inner) find_example(_gen) behaviour *) +module FindExample = struct + open QCheck2 + + let find_ex = + Test.make ~name:"find_example" ~print:Print.int + Gen.(2--50) + (fun n -> + let st = Random.State.make [| 0 |] in + let f m = n < m && m < 2 * n in + try + let m = find_example_gen ~rand:st ~count:100_000 ~f Gen.(0 -- 1000) in + f m + with No_example_found _ -> false) + + let find_ex_uncaught_issue_99_1_fail = + let rs = (find_example ~count:10 ~f:(fun _ -> false) Gen.int) in + Test.make ~name:"FAIL_#99_1" rs (fun _ -> true) + + let find_ex_uncaught_issue_99_2_succeed = + Test.make ~name:"should_succeed_#99_2" ~count:10 + Gen.int (fun i -> i <= max_int) + + let tests = [ + find_ex; + find_ex_uncaught_issue_99_1_fail; + find_ex_uncaught_issue_99_2_succeed; + ] +end + +(* tests of statistics and histogram display *) +module Stats = struct + open QCheck2 + + let bool_dist = + Test.make ~name:"bool dist" ~count:500_000 ~collect:Bool.to_string Gen.bool (fun _ -> true) + + let char_dist = + Test.make ~name:"char code dist" ~count:500_000 ~stats:[("char code", Char.code)] Gen.char (fun _ -> true) + + let string_len_tests = + let len = ("len",String.length) in + [ + Test.make ~name:"string_size len dist" ~count:5_000 ~stats:[len] Gen.(string_size (int_range 5 10)) (fun _ -> true); + Test.make ~name:"string len dist" ~count:5_000 ~stats:[len] Gen.string (fun _ -> true); + Test.make ~name:"string_of len dist" ~count:5_000 ~stats:[len] Gen.(string_of (return 'a')) (fun _ -> true); + Test.make ~name:"string_printable len dist" ~count:5_000 ~stats:[len] Gen.string_printable (fun _ -> true); + Test.make ~name:"small_string len dist" ~count:5_000 ~stats:[len] Gen.(small_string ~gen:char)(*ugh*)(fun _ -> true); + ] + + let pair_dist = + Test.make ~name:"pair dist" ~count:500_000 ~stats:[("pair sum", (fun (i,j) -> i+j))] + Gen.(pair (int_bound 100) (int_bound 100)) (fun _ -> true) + + let triple_dist = + Test.make ~name:"triple dist" ~count:500_000 ~stats:[("triple sum", (fun (i,j,k) -> i+j+k))] + Gen.(triple (int_bound 100) (int_bound 100) (int_bound 100)) (fun _ -> true) + + let quad_dist = + Test.make ~name:"quad dist" ~count:500_000 ~stats:[("quad sum", (fun (h,i,j,k) -> h+i+j+k))] + Gen.(quad (int_bound 100) (int_bound 100) (int_bound 100) (int_bound 100)) (fun _ -> true) + + let bind_dist = + Test.make ~name:"bind dist" ~count:1_000_000 + ~stats:[("ordered pair difference", (fun (i,j) -> j-i));("ordered pair sum", (fun (i,j) -> i+j))] + Gen.(int_bound 100 >>= fun j -> int_bound j >>= fun i -> return (i,j)) (fun _ -> true) + + let list_len_tests = + let len = ("len",List.length) in + [ (* test from issue #30 *) + Test.make ~name:"list len dist" ~count:5_000 ~stats:[len] Gen.(list int) (fun _ -> true); + Test.make ~name:"small_list len dist" ~count:5_000 ~stats:[len] Gen.(small_list int) (fun _ -> true); + Test.make ~name:"list_size len dist" ~count:5_000 ~stats:[len] Gen.(list_size (int_range 5 10) int) (fun _ -> true); + Test.make ~name:"list_repeat len dist" ~count:5_000 ~stats:[len] Gen.(list_repeat 42 int) (fun _ -> true); + ] + + let array_len_tests = + let len = ("len",Array.length) in + [ + Test.make ~name:"array len dist" ~count:5_000 ~stats:[len] Gen.(array int) (fun _ -> true); + Test.make ~name:"small_array len dist" ~count:5_000 ~stats:[len] Gen.(small_array int) (fun _ -> true); + Test.make ~name:"array_size len dist" ~count:5_000 ~stats:[len] Gen.(array_size (int_range 5 10) int) (fun _ -> true); + Test.make ~name:"array_repeat len dist" ~count:5_000 ~stats:[len] Gen.(array_repeat 42 int) (fun _ -> true); + ] + + let int_dist_tests = + let dist = ("dist",fun x -> x) in + [ + (* test from issue #40 *) + Test.make ~name:"int_stats_neg" ~count:5000 ~stats:[dist] Gen.small_signed_int (fun _ -> true); + (* distribution tests from PR #45 *) + Test.make ~name:"small_signed_int dist" ~count:1000 ~stats:[dist] Gen.small_signed_int (fun _ -> true); + Test.make ~name:"small_nat dist" ~count:1000 ~stats:[dist] Gen.small_nat (fun _ -> true); + Test.make ~name:"nat dist" ~count:1000 ~stats:[dist] Gen.nat (fun _ -> true); + Test.make ~name:"int_range (-43643) 435434 dist" ~count:1000 ~stats:[dist] (Gen.int_range (-43643) 435434) (fun _ -> true); + Test.make ~name:"int_range (-40000) 40000 dist" ~count:1000 ~stats:[dist] (Gen.int_range (-40000) 40000) (fun _ -> true); + Test.make ~name:"int_range (-4) 4 dist" ~count:1000 ~stats:[dist] (Gen.int_range (-4) 4) (fun _ -> true); + Test.make ~name:"int_range (-4) 17 dist" ~count:1000 ~stats:[dist] (Gen.int_range (-4) 17) (fun _ -> true); + Test.make ~name:"int dist" ~count:100000 ~stats:[dist] Gen.int (fun _ -> true); + Test.make ~name:"oneof int dist" ~count:1000 ~stats:[dist] (Gen.oneofl[min_int;-1;0;1;max_int]) (fun _ -> true); + ] + + let tree_depth_test = + let depth = ("depth", IntTree.depth) in + Test.make ~name:"tree's depth" ~count:1000 ~stats:[depth] IntTree.gen_tree (fun _ -> true) + + let int_dist_empty_bucket = + Test.make ~name:"int_dist_empty_bucket" ~count:1_000 ~stats:[("dist",fun x -> x)] + Gen.(oneof [small_int_corners ();int]) (fun _ -> true) + + let tests = + [ bool_dist; + char_dist; + tree_depth_test;] + @ string_len_tests + @ [pair_dist; + triple_dist; + quad_dist; + bind_dist;] + @ list_len_tests + @ array_len_tests + @ int_dist_tests +end diff --git a/test/core/QCheck_expect_test.expected b/test/core/QCheck_expect_test.expected index 634374f4..d67b9311 100644 --- a/test/core/QCheck_expect_test.expected +++ b/test/core/QCheck_expect_test.expected @@ -111,7 +111,7 @@ Test should_error_raise_exn errored on (63 shrink steps): 0 -exception Dune__exe__QCheck_expect_test.Overall.Error +exception QCheck_tests.Overall.Error +++ Collect ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/test/core/QCheck_expect_test.ml b/test/core/QCheck_expect_test.ml index da0bfe7e..b7ba799b 100644 --- a/test/core/QCheck_expect_test.ml +++ b/test/core/QCheck_expect_test.ml @@ -1,846 +1,4 @@ -(** QCheck(1) tests **) - -(** Module representing a tree data structure, used in tests *) -module IntTree = struct - open QCheck - - type tree = Leaf of int | Node of tree * tree - - let leaf x = Leaf x - let node x y = Node (x,y) - - let rec depth = function - | Leaf _ -> 1 - | Node (x, y) -> 1 + max (depth x) (depth y) - - let rec print_tree = function - | Leaf x -> Printf.sprintf "Leaf %d" x - | Node (x, y) -> Printf.sprintf "Node (%s, %s)" (print_tree x) (print_tree y) - - let gen_tree = Gen.(sized @@ fix - (fun self n -> match n with - | 0 -> map leaf nat - | n -> - frequency - [1, map leaf nat; - 2, map2 node (self (n/2)) (self (n/2))] - )) - - let rec shrink_tree t = match t with - | Leaf l -> Iter.map (fun l' -> Leaf l') (Shrink.int l) - | Node (x,y) -> - let open Iter in - of_list [x;y] - <+> map (fun x' -> Node (x',y)) (shrink_tree x) - <+> map (fun y' -> Node (x,y')) (shrink_tree y) - - let rec rev_tree = function - | Node (x, y) -> Node (rev_tree y, rev_tree x) - | Leaf x -> Leaf x - - let rec contains_only_n tree n = match tree with - | Leaf n' -> n = n' - | Node (x, y) -> contains_only_n x n && contains_only_n y n -end - -(* tests of overall functionality *) -module Overall = struct - open QCheck - - let passing = - Test.make ~name:"list_rev_is_involutive" ~count:100 ~long_factor:100 - (list small_int) (fun l -> List.rev (List.rev l) = l) - - let failing = - Test.make ~name:"should_fail_sort_id" ~count:10 - (small_list small_int) (fun l -> l = List.sort compare l) - - exception Error - - let error = - Test.make ~name:"should_error_raise_exn" ~count:10 - int (fun _ -> raise Error) - - let collect = - Test.make ~name:"collect_results" ~count:100 ~long_factor:100 - (make ~collect:string_of_int (Gen.int_bound 4)) - (fun _ -> true) - - let stats = - Test.make ~name:"with_stats" ~count:100 ~long_factor:100 - (make (Gen.int_bound 120) - ~stats:[ - "mod4", (fun i->i mod 4); - "num", (fun i->i); - ]) - (fun _ -> true) - - let retries = - Test.make ~name:"with shrinking retries" ~retries:10 - small_nat (fun i -> Printf.printf "%i %!" i; i mod 3 <> 1) - - let bad_assume_warn = - Test.make ~name:"WARN_unlikely_precond" ~count:2_000 - int - (fun x -> - QCheck.assume (x mod 100 = 1); - true) - - let bad_assume_fail = - Test.make ~name:"FAIL_unlikely_precond" ~count:2_000 - ~if_assumptions_fail:(`Fatal, 0.1) - int - (fun x -> - QCheck.assume (x mod 100 = 1); - true) - - let tests = [ - passing; - failing; - error; - collect; - stats; - retries; - bad_assume_warn; - bad_assume_fail; - ] -end - -(* positive tests of the various generators - - Note: it is important to disable shrinking for these tests, as the - shrinkers will suggest inputs that are coming from the generator - themselves -- which we want to test -- so their reduced - counter-example are confusing rather than helpful. - - This is achieved by using (Test.make ~print ...), without a ~shrink - argument. -*) -module Generator = struct - open QCheck - - (* example from issue #23 *) - let char_dist_issue_23 = - Test.make ~name:"char never produces '\\255'" ~count:1_000_000 char (fun c -> c <> '\255') - - let char_test = - Test.make ~name:"char has right range'" ~count:1000 - char (fun c -> '\000' <= c && c <= '\255') - - let nat_test = - Test.make ~name:"nat has right range" ~count:1000 - (make ~print:Print.int Gen.nat) (fun n -> 0 <= n && n < 10000) - - let string_test = - Test.make ~name:"string has right length and content" ~count:1000 - string - (fun s -> - let len = String.length s in - 0 <= len && len < 10000 - && String.to_seq s |> - Seq.fold_left (fun acc c -> acc && '\000' <= c && c <= '\255') true) - - let pair_test = - Test.make ~name:"int pairs - commute over +" ~count:1000 - (pair small_nat small_nat) (fun (i,j) -> i+j = j+i) - - let triple_test = - Test.make ~name:"int triples - associative over +" ~count:1000 - (triple small_nat small_nat small_nat) (fun (i,j,k) -> i+(j+k) = (i+j)+k) - - let quad_test = - Test.make ~name:"int quadruples - product of sums" ~count:1000 - (quad small_nat small_nat small_nat small_nat) - (fun (h,i,j,k) -> (h+i)*(j+k) = h*j + h*k + i*j + i*k) - - let bind_test = - Test.make ~name:"bind test for ordered pairs" ~count:1000 - (make Gen.(small_nat >>= fun j -> int_bound j >>= fun i -> return (i,j))) - (fun (i,j) -> i<=j) - - let bind_pair_list_length = - Test.make ~name:"bind list length" ~count:1000 - (make Gen.(int_bound 1000 >>= fun len -> - list_size (return len) (int_bound 1000) >>= fun xs -> return (len,xs))) - (fun (len,xs) -> len = List.length xs) - - let list_test = - Test.make ~name:"list has right length" ~count:1000 - (list unit) (fun l -> let len = List.length l in 0 <= len && len < 10_000) - - let list_repeat_test = - let gen = Gen.(small_nat >>= fun i -> list_repeat i unit >>= fun l -> return (i,l)) in - Test.make ~name:"list_repeat has constant length" ~count:1000 - (make ~print:Print.(pair int (list unit)) gen) (fun (i,l) -> List.length l = i) - - let array_repeat_test = - let gen = Gen.(small_nat >>= fun i -> array_repeat i unit >>= fun l -> return (i,l)) in - Test.make ~name:"array_repeat has constant length" ~count:1000 - (make ~print:Print.(pair int (array unit)) gen) (fun (i,l) -> Array.length l = i) - - let passing_tree_rev = - Test.make ~name:"tree_rev_is_involutive" ~count:1000 - (make IntTree.gen_tree) - (fun tree -> IntTree.(rev_tree (rev_tree tree)) = tree) - - let nat_split2_spec = - Test.make ~name:"nat_split2 spec" - (make - ~print:Print.(pair int (pair int int)) - Gen.(small_nat >>= fun n -> - pair (return n) (nat_split2 n))) - (fun (n, (a, b)) -> - 0 <= a && 0 <= b && a + b = n) - - let pos_split2_spec = - Test.make ~name:"pos_split2 spec" - (make - ~print:Print.(pair int (pair int int)) - Gen.(small_nat >>= fun n -> - (* we need n > 2 *) - let n = n + 2 in - pair (return n) (pos_split2 n))) - (fun (n, (a, b)) -> - (0 < a && 0 < b && a + b = n)) - - let range_subset_spec = - Test.make ~name:"range_subset_spec" - (make - ~print:Print.(quad int int int (array int)) - Gen.(pair small_nat small_nat >>= fun (m, n) -> - (* we must guarantee [low <= high] - and [size <= high - low + 1] *) - let low = m and high = m + n in - int_range 0 (high - low + 1) >>= fun size -> - quad (return size) (return low) (return high) - (range_subset ~size low high))) - (fun (size, low, high, arr) -> - if size = 0 then arr = [||] - else - Array.length arr = size - && low <= arr.(0) - && Array.for_all (fun (a, b) -> a < b) - (Array.init (size - 1) (fun k -> arr.(k), arr.(k+1))) - && arr.(size - 1) <= high) - - let nat_split_n_way = - Test.make ~name:"nat_split n-way" - (make - ~print:Print.(pair int (array int)) - Gen.(small_nat >>= fun n -> - pair (return n) (nat_split ~size:n n))) - (fun (n, arr) -> - Array.length arr = n - && Array.for_all (fun k -> 0 <= k) arr - && Array.fold_left (+) 0 arr = n) - - let nat_split_smaller = - Test.make ~name:"nat_split smaller" - (make - ~print:Print.(triple int int (array int)) - Gen.(small_nat >>= fun size -> - int_bound size >>= fun n -> - triple (return size) (return n) (nat_split ~size n))) - (fun (m, n, arr) -> - Array.length arr = m - && Array.for_all (fun k -> 0 <= k) arr - && Array.fold_left (+) 0 arr = n) - - let pos_split = - Test.make ~name:"pos_split" - (make - ~print:Print.(triple int int (array int)) - Gen.(pair small_nat small_nat >>= fun (m, n) -> - (* we need both size>0 and n>0 and size <= n *) - let size = 1 + min m n and n = 1 + max m n in - triple (return size) (return n) (pos_split ~size n))) - (fun (m, n, arr) -> - Array.length arr = m - && Array.for_all (fun k -> 0 < k) arr - && Array.fold_left (+) 0 arr = n) - - let test_tup2 = - Test.make ~count:10 - ~name:"forall x in (0, 1): x = (0, 1)" - (tup2 (always 0) (always 1)) - (fun x -> x = (0, 1)) - - let test_tup3 = - Test.make ~count:10 - ~name:"forall x in (0, 1, 2): x = (0, 1, 2)" - (tup3 (always 0) (always 1) (always 2)) - (fun x -> x = (0, 1, 2)) - - let test_tup4 = - Test.make ~count:10 - ~name:"forall x in (0, 1, 2, 3): x = (0, 1, 2, 3)" - (tup4 (always 0) (always 1) (always 2) (always 3)) - (fun x -> x = (0, 1, 2, 3)) - - let test_tup5 = - Test.make ~count:10 - ~name:"forall x in (0, 1, 2, 3, 4): x = (0, 1, 2, 3, 4)" - (tup5 (always 0) (always 1) (always 2) (always 3) (always 4)) - (fun x -> x = (0, 1, 2, 3, 4)) - - let test_tup6 = - Test.make ~count:10 - ~name:"forall x in (0, 1, 2, 3, 4, 5): x = (0, 1, 2, 3, 4, 5)" - (tup6 (always 0) (always 1) (always 2) (always 3) (always 4) (always 5)) - (fun x -> x = (0, 1, 2, 3, 4, 5)) - - let test_tup7 = - Test.make ~count:10 - ~name:"forall x in (0, 1, 2, 3, 4, 5, 6): x = (0, 1, 2, 3, 4, 5, 6)" - (tup7 - (always 0) (always 1) (always 2) (always 3) (always 4) - (always 5) (always 6)) - (fun x -> x = (0, 1, 2, 3, 4, 5, 6)) - - let test_tup8 = - Test.make ~count:10 - ~name:"forall x in (0, 1, 2, 3, 4, 5, 6, 7): x = (0, 1, 2, 3, 4, 5, 6, 7)" - (tup8 - (always 0) (always 1) (always 2) (always 3) (always 4) - (always 5) (always 6) (always 7)) - (fun x -> x = (0, 1, 2, 3, 4, 5, 6, 7)) - - let test_tup9 = - Test.make ~count:10 - ~name:"forall x in (0, 1, 2, 3, 4, 5, 6, 7, 8): x = (0, 1, 2, 3, 4, 5, 6, 7, 8)" - (tup9 - (always 0) (always 1) (always 2) (always 3) (always 4) - (always 5) (always 6) (always 7) (always 8)) - (fun x -> x = (0, 1, 2, 3, 4, 5, 6, 7, 8)) - - let tests = [ - char_dist_issue_23; - char_test; - nat_test; - string_test; - pair_test; - triple_test; - quad_test; - bind_test; - bind_pair_list_length; - list_test; - list_repeat_test; - array_repeat_test; - passing_tree_rev; - nat_split2_spec; - pos_split2_spec; - range_subset_spec; - nat_split_n_way; - nat_split_smaller; - pos_split; - test_tup2; - test_tup3; - test_tup4; - test_tup5; - test_tup6; - test_tup7; - test_tup8; - test_tup9; - ] -end - -(* negative tests that exercise shrinking behaviour *) -module Shrink = struct - open QCheck - - let rec fac n = match n with - | 0 -> 1 - | n -> n * fac (n - 1) - - (* example from issue #59 *) - let test_fac_issue59 = - Test.make ~name:"test fac issue59" - (set_shrink Shrink.nil (small_int_corners ())) - (fun n -> try (fac n) mod n = 0 - with - (*| Stack_overflow -> false*) - | Division_by_zero -> (n=0)) - - let big_bound_issue59 = - Test.make ~name:"big bound issue59" - (small_int_corners()) (fun i -> i < 209609) - - let long_shrink = - let listgen = list_of_size (Gen.int_range 1000 10000) int in - Test.make ~name:"long_shrink" (pair listgen listgen) - (fun (xs,ys) -> List.rev (xs@ys) = (List.rev xs)@(List.rev ys)) - - (* test from issue 36 *) - let ints_arent_0_mod_3 = - Test.make ~name:"ints arent 0 mod 3" ~count:1000 - int (fun i -> i mod 3 <> 0) - - let ints_are_0 = - Test.make ~name:"ints are 0" ~count:1000 - int (fun i -> Printf.printf "%i\n" i; i = 0) - - (* test from issue #59 *) - let ints_smaller_209609 = - Test.make ~name:"ints < 209609" - (small_int_corners()) (fun i -> i < 209609) - - let nats_smaller_5001 = - Test.make ~name:"nat < 5001" ~count:1000 - (make ~print:Print.int ~shrink:Shrink.int Gen.nat) (fun n -> n < 5001) - - let char_is_never_abcdef = - Test.make ~name:"char is never produces 'abcdef'" ~count:1000 - char (fun c -> not (List.mem c ['a';'b';'c';'d';'e';'f'])) - - let strings_are_empty = - Test.make ~name:"strings are empty" ~count:1000 - string (fun s -> s = "") - - let string_never_has_000_char = - Test.make ~name:"string never has a \\000 char" ~count:1000 - string - (fun s -> String.to_seq s |> Seq.fold_left (fun acc c -> acc && c <> '\000') true) - - let string_never_has_255_char = - Test.make ~name:"string never has a \\255 char" ~count:1000 - string - (fun s -> String.to_seq s |> Seq.fold_left (fun acc c -> acc && c <> '\255') true) - - (* test from issue #167 *) - let pair_diff_issue_64 = - Test.make ~name:"pairs have different components" - (pair small_int small_int) (fun (i,j) -> i<>j) - - let pair_same = - Test.make ~name:"pairs have same components" (pair int int) (fun (i,j) -> i=j) - - let pair_one_zero = - Test.make ~name:"pairs have a zero component" (pair int int) (fun (i,j) -> i=0 || j=0) - - let pair_all_zero = - Test.make ~name:"pairs are (0,0)" (pair int int) (fun (i,j) -> i=0 && j=0) - - let pair_ordered = - Test.make ~name:"pairs are ordered" (pair pos_int pos_int) (fun (i,j) -> i<=j) - - let pair_ordered_rev = - Test.make ~name:"pairs are ordered reversely" (pair pos_int pos_int) (fun (i,j) -> i>=j) - - let pair_sum_lt_128 = - Test.make ~name:"pairs sum to less than 128" (pair pos_int pos_int) (fun (i,j) -> i+j<128) - - let pair_lists_rev_concat = - Test.make ~name:"pairs lists rev concat" - (pair (list pos_int) (list pos_int)) - (fun (xs,ys) -> List.rev (xs@ys) = (List.rev xs)@(List.rev ys)) - - let pair_lists_no_overlap = - Test.make ~name:"pairs lists no overlap" - (pair (list small_nat) (list small_nat)) - (fun (xs,ys) -> List.for_all (fun x -> not (List.mem x ys)) xs) - - let triple_diff = - Test.make ~name:"triples have pair-wise different components" - (triple small_int small_int small_int) (fun (i,j,k) -> i<>j && j<>k) - - let triple_same = - Test.make ~name:"triples have same components" - (triple int int int) (fun (i,j,k) -> i=j || j=k) - - let triple_ordered = - Test.make ~name:"triples are ordered" - (triple int int int) (fun (i,j,k) -> i<=j && j<=k) - - let triple_ordered_rev = - Test.make ~name:"triples are ordered reversely" - (triple int int int) (fun (i,j,k) -> i>=j && j>=k) - - let quad_diff = - Test.make ~name:"quadruples have pair-wise different components" - (quad small_int small_int small_int small_int) (fun (h,i,j,k) -> h<>i && i<>j && j<>k) - - let quad_same = - Test.make ~name:"quadruples have same components" - (quad int int int int) (fun (h,i,j,k) -> h=i || i=j || j=k) - - let quad_ordered = - Test.make ~name:"quadruples are ordered" - (quad int int int int) (fun (h,i,j,k) -> h <= i && i <= j && j <= k) - - let quad_ordered_rev = - Test.make ~name:"quadruples are ordered reversely" - (quad int int int int) (fun (h,i,j,k) -> h >= i && i >= j && j >= k) - - let bind_pair_ordered = - Test.make ~name:"bind ordered pairs" - (make ~print:Print.(pair int int) - ~shrink:Shrink.(filter (fun (i,j) -> i<=j) (pair int int)) - Gen.(int >>= fun j -> int_bound j >>= fun i -> return (i,j))) - (fun (_i,_j) -> false) - - let bind_pair_list_size = - let shrink (_l,xs) = - Iter.map (fun xs' -> (List.length xs',xs')) Shrink.(list ~shrink:int xs) in - Test.make ~name:"bind list_size constant" - (make ~print:Print.(pair int (list int)) ~shrink - Gen.(int_bound 1000 >>= fun len -> - list_size (return len) (int_bound 1000) >>= fun xs -> return (len,xs))) - (fun (len,xs) -> let len' = List.length xs in len=len' && len' < 4) - - let print_list xs = print_endline Print.(list int xs) - - (* test from issue #64 *) - let lists_are_empty_issue_64 = - Test.make ~name:"lists are empty" - (list small_int) (fun xs -> print_list xs; xs = []) - - let list_shorter_10 = - Test.make ~name:"lists shorter than 10" - (list small_int) (fun xs -> List.length xs < 10) - - let length_printer xs = - Printf.sprintf "[...] list length: %i" (List.length xs) - - let size_gen = Gen.(oneof [small_nat; int_bound 750_000]) - - let list_shorter_432 = - Test.make ~name:"lists shorter than 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 -> List.length xs < 4332) - - let list_equal_dupl = - Test.make ~name:"lists equal to duplication" - (list_of_size size_gen small_int) - (fun xs -> try xs = xs @ xs - with Stack_overflow -> false) - - let list_unique_elems = - Test.make ~name:"lists have unique elems" - (list small_int) - (fun xs -> let ys = List.sort_uniq Int.compare xs in - print_list xs; List.length xs = List.length ys) - - let test_tup2 = - Test.make - ~name:"forall (a, b) in nat: a < b" - (tup2 small_int small_int) - (fun (a, b) -> a < b) - - let test_tup3 = - Test.make - ~name:"forall (a, b, c) in nat: a < b < c" - (tup3 small_int small_int small_int) - (fun (a, b, c) -> a < b && b < c) - - let test_tup4 = - Test.make - ~name:"forall (a, b, c, d) in nat: a < b < c < d" - (tup4 small_int small_int small_int small_int) - (fun (a, b, c, d) -> a < b && b < c && c < d) - - let test_tup5 = - Test.make - ~name:"forall (a, b, c, d, e) in nat: a < b < c < d < e" - (tup5 small_int small_int small_int small_int small_int) - (fun (a, b, c, d, e) -> a < b && b < c && c < d && d < e) - - let test_tup6 = - Test.make - ~name:"forall (a, b, c, d, e, f) in nat: a < b < c < d < e < f" - (tup6 small_int small_int small_int small_int small_int small_int) - (fun (a, b, c, d, e, f) -> a < b && b < c && c < d && d < e && e < f) - - let test_tup7 = - Test.make - ~name:"forall (a, b, c, d, e, f, g) in nat: a < b < c < d < e < f < g" - (tup7 small_int small_int small_int small_int small_int small_int small_int) - (fun (a, b, c, d, e, f, g) -> a < b && b < c && c < d && d < e && e < f && f < g) - - let test_tup8 = - Test.make - ~name:"forall (a, b, c, d, e, f, g, h) in nat: a < b < c < d < e < f < g < h" - (tup8 small_int small_int small_int small_int small_int small_int small_int small_int) - (fun (a, b, c, d, e, f, g, h) -> a < b && b < c && c < d && d < e && e < f && f < g && g < h) - - let test_tup9 = - Test.make - ~name:"forall (a, b, c, d, e, f, g, h, i) in nat: a < b < c < d < e < f < g < h < i" - (tup9 small_int small_int small_int small_int small_int small_int small_int small_int small_int) - (fun (a, b, c, d, e, f, g, h, i) -> a < b && b < c && c < d && d < e && e < f && f < g && g < h && h < i) - - let tree_contains_only_42 = - Test.make ~name:"tree contains only 42" - IntTree.(make ~print:print_tree ~shrink:shrink_tree gen_tree) - (fun tree -> IntTree.contains_only_n tree 42) - - let tests = [ - (*test_fac_issue59;*) - big_bound_issue59; - long_shrink; - ints_arent_0_mod_3; - ints_are_0; - ints_smaller_209609; - nats_smaller_5001; - char_is_never_abcdef; - strings_are_empty; - string_never_has_000_char; - string_never_has_255_char; - pair_diff_issue_64; - pair_same; - pair_one_zero; - pair_all_zero; - pair_ordered; - pair_ordered_rev; - pair_sum_lt_128; - pair_lists_rev_concat; - pair_lists_no_overlap; - triple_diff; - triple_same; - triple_ordered; - triple_ordered_rev; - quad_diff; - quad_same; - quad_ordered; - quad_ordered_rev; - bind_pair_ordered; - bind_pair_list_size; - lists_are_empty_issue_64; - list_shorter_10; - list_shorter_432; - list_shorter_4332; - list_equal_dupl; - list_unique_elems; - test_tup2; - test_tup3; - test_tup4; - test_tup5; - test_tup6; - test_tup7; - test_tup8; - test_tup9; - tree_contains_only_42; - ] -end - -(* tests function generator and shrinker *) -module Function = struct - open QCheck - - let fail_pred_map_commute = - Test.make ~name:"fail_pred_map_commute" ~count:100 ~long_factor:100 - (triple - (small_list small_int) - (fun1 Observable.int int) - (fun1 Observable.int bool)) - (fun (l,Fun (_,f),Fun (_,p)) -> - List.filter p (List.map f l) = List.map f (List.filter p l)) - - let fail_pred_strings = - Test.make ~name:"fail_pred_strings" ~count:100 - (fun1 Observable.string bool) - (fun (Fun (_,p)) -> not (p "some random string") || p "some other string") - - let int_gen = small_nat (* int *) - - (* Another example (false) property *) - let prop_foldleft_foldright = - Test.make ~name:"fold_left fold_right" ~count:1000 ~long_factor:20 - (triple - int_gen - (list int_gen) - (fun2 Observable.int Observable.int int_gen)) - (fun (z,xs,f) -> - let l1 = List.fold_right (Fn.apply f) xs z in - let l2 = List.fold_left (Fn.apply f) z xs in - if l1=l2 then true - else Test.fail_reportf "l=%s, fold_left=%s, fold_right=%s@." - (Print.(list int) xs) - (Print.int l1) - (Print.int l2) - ) - - (* Another example (false) property *) - let prop_foldleft_foldright_uncurry = - Test.make ~name:"fold_left fold_right uncurried" ~count:1000 ~long_factor:20 - (triple - (fun1 Observable.(pair int int) int_gen) - int_gen - (list int_gen)) - (fun (f,z,xs) -> - List.fold_right (fun x y -> Fn.apply f (x,y)) xs z = - List.fold_left (fun x y -> Fn.apply f (x,y)) z xs) - - (* Same as the above (false) property, but generating+shrinking functions last *) - let prop_foldleft_foldright_uncurry_funlast = - Test.make ~name:"fold_left fold_right uncurried fun last" ~count:1000 ~long_factor:20 - (triple - int_gen - (list int_gen) - (fun1 Observable.(pair int int) int_gen)) - (fun (z,xs,f) -> - List.fold_right (fun x y -> Fn.apply f (x,y)) xs z = - List.fold_left (fun x y -> Fn.apply f (x,y)) z xs) - - (* test from issue #64 *) - let fold_left_test = - Test.make ~name:"false fold, fun first" - (quad (* string -> int -> string *) - (fun2 Observable.string Observable.int small_string) - small_string - (list small_int) - (list small_int)) - (fun (f,acc,is,js) -> - let f = Fn.apply f in - List.fold_left f acc (is @ js) - = List.fold_left f (List.fold_left f acc is) is) (*Typo*) - - let tests = [ - fail_pred_map_commute; - fail_pred_strings; - prop_foldleft_foldright; - prop_foldleft_foldright_uncurry; - prop_foldleft_foldright_uncurry_funlast; - fold_left_test; - ] -end - -(* tests of (inner) find_example(_gen) behaviour *) -module FindExample = struct - open QCheck - - let find_ex = - Test.make ~name:"find_example" (2--50) - (fun n -> - let st = Random.State.make [| 0 |] in - let f m = n < m && m < 2 * n in - try - let m = find_example_gen ~rand:st ~count:100_000 ~f Gen.(0 -- 1000) in - f m - with No_example_found _ -> false) - - let find_ex_uncaught_issue_99_1_fail = - let rs = make (find_example ~count:10 ~f:(fun _ -> false) Gen.int) in - Test.make ~name:"FAIL_#99_1" rs (fun _ -> true) - - let find_ex_uncaught_issue_99_2_succeed = - Test.make ~name:"should_succeed_#99_2" ~count:10 - int (fun i -> i <= max_int) - - let tests = [ - find_ex; - find_ex_uncaught_issue_99_1_fail; - find_ex_uncaught_issue_99_2_succeed; - ] -end - -(* tests of statistics and histogram display *) -module Stats = struct - open QCheck - - let bool_dist = - Test.make ~name:"bool dist" ~count:500_000 (set_collect Bool.to_string bool) (fun _ -> true) - - let char_dist = - Test.make ~name:"char code dist" ~count:500_000 (add_stat ("char code", Char.code) char) (fun _ -> true) - - let string_len_tests = - let len = ("len",String.length) in - [ - Test.make ~name:"string_size len dist" ~count:5_000 (add_stat len (string_of_size (Gen.int_range 5 10))) (fun _ -> true); - Test.make ~name:"string len dist" ~count:5_000 (add_stat len string) (fun _ -> true); - Test.make ~name:"string_of len dist" ~count:5_000 (add_stat len (string_gen (Gen.return 'a'))) (fun _ -> true); - Test.make ~name:"printable_string len dist" ~count:5_000 (add_stat len printable_string) (fun _ -> true); - Test.make ~name:"small_string len dist" ~count:5_000 (add_stat len small_string) (fun _ -> true); - ] - - let pair_dist = - Test.make ~name:"pair dist" ~count:500_000 - (add_stat ("pair sum", (fun (i,j) -> i+j)) - (pair (int_bound 100) (int_bound 100))) (fun _ -> true) - - let triple_dist = - Test.make ~name:"triple dist" ~count:500_000 - (add_stat ("triple sum", (fun (i,j,k) -> i+j+k)) - (triple (int_bound 100) (int_bound 100) (int_bound 100))) (fun _ -> true) - - let quad_dist = - Test.make ~name:"quad dist" ~count:500_000 - (add_stat ("quad sum", (fun (h,i,j,k) -> h+i+j+k)) - (quad (int_bound 100) (int_bound 100) (int_bound 100) (int_bound 100))) (fun _ -> true) - - let bind_dist = - Test.make ~name:"bind dist" ~count:1_000_000 - (make ~stats:[("ordered pair difference", (fun (i,j) -> j-i));("ordered pair sum", (fun (i,j) -> i+j))] - Gen.(int_bound 100 >>= fun j -> int_bound j >>= fun i -> return (i,j))) (fun _ -> true) - - let list_len_tests = - let len = ("len",List.length) in - [ (* test from issue #30 *) - Test.make ~name:"list len dist" ~count:5_000 (add_stat len (list int)) (fun _ -> true); - Test.make ~name:"small_list len dist" ~count:5_000 (add_stat len (small_list int)) (fun _ -> true); - Test.make ~name:"list_of_size len dist" ~count:5_000 (add_stat len (list_of_size (Gen.int_range 5 10) int)) (fun _ -> true); - Test.make ~name:"list_repeat len dist" ~count:5_000 (add_stat len (make Gen.(list_repeat 42 int))) (fun _ -> true); - ] - - let array_len_tests = - let len = ("len",Array.length) in - [ - Test.make ~name:"array len dist" ~count:5_000 (add_stat len (array int)) (fun _ -> true); - Test.make ~name:"small_array len dist" ~count:5_000 (add_stat len (make Gen.(small_array int))) (fun _ -> true); - Test.make ~name:"array_of_size len dist" ~count:5_000 (add_stat len (array_of_size (Gen.int_range 5 10) int)) (fun _ -> true); - Test.make ~name:"array_repeat len dist" ~count:5_000 (add_stat len (make Gen.(array_repeat 42 int))) (fun _ -> true); - ] - - let int_dist_tests = - let dist = ("dist",fun x -> x) in - [ (* test from issue #40 *) - Test.make ~name:"int_stats_neg" ~count:5000 (add_stat dist small_signed_int) (fun _ -> true); - (* distribution tests from PR #45 *) - Test.make ~name:"small_signed_int dist" ~count:1000 (add_stat dist small_signed_int) (fun _ -> true); - Test.make ~name:"small_nat dist" ~count:1000 (add_stat dist small_nat) (fun _ -> true); - Test.make ~name:"nat dist" ~count:1000 (add_stat dist (make Gen.nat)) (fun _ -> true); - Test.make ~name:"int_range (-43643) 435434 dist" ~count:1000 (add_stat dist (int_range (-43643) 435434)) (fun _ -> true); - Test.make ~name:"int_range (-40000) 40000 dist" ~count:1000 (add_stat dist (int_range (-40000) 40000)) (fun _ -> true); - Test.make ~name:"int_range (-4) 4 dist" ~count:1000 (add_stat dist (int_range (-4) 4)) (fun _ -> true); - Test.make ~name:"int_range (-4) 17 dist" ~count:1000 (add_stat dist (int_range (-4) 17)) (fun _ -> true); - Test.make ~name:"int dist" ~count:100000 (add_stat dist int) (fun _ -> true); - Test.make ~name:"oneof int dist" ~count:1000 (add_stat dist (oneofl[min_int;-1;0;1;max_int])) (fun _ -> true); - ] - - let int_dist_empty_bucket = - Test.make ~name:"int_dist_empty_bucket" ~count:1_000 - (add_stat ("dist",fun x -> x) (oneof [small_int_corners ();int])) (fun _ -> true) - - let tree_depth_test = - let depth = ("depth", IntTree.depth) in - Test.make ~name:"tree's depth" ~count:1000 (add_stat depth (make IntTree.gen_tree)) (fun _ -> true) - - let range_subset_test = - Test.make ~name:"range_subset_spec" ~count:5_000 - (add_stat ("dist", fun a -> a.(0)) (make (Gen.range_subset ~size:1 0 20))) - (fun a -> Array.length a = 1) - - let tests = - [ - bool_dist; - char_dist; - tree_depth_test; - range_subset_test - ] - @ string_len_tests - @ [pair_dist; - triple_dist; - quad_dist; - bind_dist;] - @ list_len_tests - @ array_len_tests - @ int_dist_tests -end +open QCheck_tests (* Calling runners *) diff --git a/test/core/QCheck_tests.ml b/test/core/QCheck_tests.ml new file mode 100644 index 00000000..f0e39ab1 --- /dev/null +++ b/test/core/QCheck_tests.ml @@ -0,0 +1,841 @@ +(** QCheck(1) tests **) + +(** Module representing a tree data structure, used in tests *) +module IntTree = struct + open QCheck + + type tree = Leaf of int | Node of tree * tree + + let leaf x = Leaf x + let node x y = Node (x,y) + + let rec depth = function + | Leaf _ -> 1 + | Node (x, y) -> 1 + max (depth x) (depth y) + + let rec print_tree = function + | Leaf x -> Printf.sprintf "Leaf %d" x + | Node (x, y) -> Printf.sprintf "Node (%s, %s)" (print_tree x) (print_tree y) + + let gen_tree = Gen.(sized @@ fix + (fun self n -> match n with + | 0 -> map leaf nat + | n -> + frequency + [1, map leaf nat; + 2, map2 node (self (n/2)) (self (n/2))] + )) + + let rec shrink_tree t = match t with + | Leaf l -> Iter.map (fun l' -> Leaf l') (Shrink.int l) + | Node (x,y) -> + let open Iter in + of_list [x;y] + <+> map (fun x' -> Node (x',y)) (shrink_tree x) + <+> map (fun y' -> Node (x,y')) (shrink_tree y) + + let rec rev_tree = function + | Node (x, y) -> Node (rev_tree y, rev_tree x) + | Leaf x -> Leaf x + + let rec contains_only_n tree n = match tree with + | Leaf n' -> n = n' + | Node (x, y) -> contains_only_n x n && contains_only_n y n +end + +(* tests of overall functionality *) +module Overall = struct + open QCheck + + let passing = + Test.make ~name:"list_rev_is_involutive" ~count:100 ~long_factor:100 + (list small_int) (fun l -> List.rev (List.rev l) = l) + + let failing = + Test.make ~name:"should_fail_sort_id" ~count:10 + (small_list small_int) (fun l -> l = List.sort compare l) + + exception Error + + let error = + Test.make ~name:"should_error_raise_exn" ~count:10 + int (fun _ -> raise Error) + + let collect = + Test.make ~name:"collect_results" ~count:100 ~long_factor:100 + (make ~collect:string_of_int (Gen.int_bound 4)) + (fun _ -> true) + + let stats = + Test.make ~name:"with_stats" ~count:100 ~long_factor:100 + (make (Gen.int_bound 120) + ~stats:[ + "mod4", (fun i->i mod 4); + "num", (fun i->i); + ]) + (fun _ -> true) + + let retries = + Test.make ~name:"with shrinking retries" ~retries:10 + small_nat (fun i -> Printf.printf "%i %!" i; i mod 3 <> 1) + + let bad_assume_warn = + Test.make ~name:"WARN_unlikely_precond" ~count:2_000 + int + (fun x -> + QCheck.assume (x mod 100 = 1); + true) + + let bad_assume_fail = + Test.make ~name:"FAIL_unlikely_precond" ~count:2_000 + ~if_assumptions_fail:(`Fatal, 0.1) + int + (fun x -> + QCheck.assume (x mod 100 = 1); + true) + + let tests = [ + passing; + failing; + error; + collect; + stats; + retries; + bad_assume_warn; + bad_assume_fail; + ] +end + +(* positive tests of the various generators + + Note: it is important to disable shrinking for these tests, as the + shrinkers will suggest inputs that are coming from the generators + themselves -- which we want to test -- so their reduced + counter-example are confusing rather than helpful. + + This is achieved by using (Test.make ~print ...), without a ~shrink + argument. +*) +module Generator = struct + open QCheck + + (* example from issue #23 *) + let char_dist_issue_23 = + Test.make ~name:"char never produces '\\255'" ~count:1_000_000 char (fun c -> c <> '\255') + + let char_test = + Test.make ~name:"char has right range'" ~count:1000 + char (fun c -> '\000' <= c && c <= '\255') + + let nat_test = + Test.make ~name:"nat has right range" ~count:1000 + (make ~print:Print.int Gen.nat) (fun n -> 0 <= n && n < 10000) + + let string_test = + Test.make ~name:"string has right length and content" ~count:1000 + string + (fun s -> + let len = String.length s in + 0 <= len && len < 10000 + && String.to_seq s |> + Seq.fold_left (fun acc c -> acc && '\000' <= c && c <= '\255') true) + + let pair_test = + Test.make ~name:"int pairs - commute over +" ~count:1000 + (pair small_nat small_nat) (fun (i,j) -> i+j = j+i) + + let triple_test = + Test.make ~name:"int triples - associative over +" ~count:1000 + (triple small_nat small_nat small_nat) (fun (i,j,k) -> i+(j+k) = (i+j)+k) + + let quad_test = + Test.make ~name:"int quadruples - product of sums" ~count:1000 + (quad small_nat small_nat small_nat small_nat) + (fun (h,i,j,k) -> (h+i)*(j+k) = h*j + h*k + i*j + i*k) + + let bind_test = + Test.make ~name:"bind test for ordered pairs" ~count:1000 + (make Gen.(small_nat >>= fun j -> int_bound j >>= fun i -> return (i,j))) + (fun (i,j) -> i<=j) + + let bind_pair_list_length = + Test.make ~name:"bind list length" ~count:1000 + (make Gen.(int_bound 1000 >>= fun len -> + list_size (return len) (int_bound 1000) >>= fun xs -> return (len,xs))) + (fun (len,xs) -> len = List.length xs) + + let list_test = + Test.make ~name:"list has right length" ~count:1000 + (list unit) (fun l -> let len = List.length l in 0 <= len && len < 10_000) + + let list_repeat_test = + let gen = Gen.(small_nat >>= fun i -> list_repeat i unit >>= fun l -> return (i,l)) in + Test.make ~name:"list_repeat has constant length" ~count:1000 + (make ~print:Print.(pair int (list unit)) gen) (fun (i,l) -> List.length l = i) + + let array_repeat_test = + let gen = Gen.(small_nat >>= fun i -> array_repeat i unit >>= fun l -> return (i,l)) in + Test.make ~name:"array_repeat has constant length" ~count:1000 + (make ~print:Print.(pair int (array unit)) gen) (fun (i,l) -> Array.length l = i) + + let passing_tree_rev = + Test.make ~name:"tree_rev_is_involutive" ~count:1000 + (make IntTree.gen_tree) + (fun tree -> IntTree.(rev_tree (rev_tree tree)) = tree) + + let nat_split2_spec = + Test.make ~name:"nat_split2 spec" + (make + ~print:Print.(pair int (pair int int)) + Gen.(small_nat >>= fun n -> + pair (return n) (nat_split2 n))) + (fun (n, (a, b)) -> + 0 <= a && 0 <= b && a + b = n) + + let pos_split2_spec = + Test.make ~name:"pos_split2 spec" + (make + ~print:Print.(pair int (pair int int)) + Gen.(small_nat >>= fun n -> + (* we need n > 2 *) + let n = n + 2 in + pair (return n) (pos_split2 n))) + (fun (n, (a, b)) -> + (0 < a && 0 < b && a + b = n)) + + let range_subset_spec = + Test.make ~name:"range_subset_spec" + (make + ~print:Print.(quad int int int (array int)) + Gen.(pair small_nat small_nat >>= fun (m, n) -> + (* we must guarantee [low <= high] + and [size <= high - low + 1] *) + let low = m and high = m + n in + int_range 0 (high - low + 1) >>= fun size -> + quad (return size) (return low) (return high) + (range_subset ~size low high))) + (fun (size, low, high, arr) -> + if size = 0 then arr = [||] + else + Array.length arr = size + && low <= arr.(0) + && Array.for_all (fun (a, b) -> a < b) + (Array.init (size - 1) (fun k -> arr.(k), arr.(k+1))) + && arr.(size - 1) <= high) + + let nat_split_n_way = + Test.make ~name:"nat_split n-way" + (make + ~print:Print.(pair int (array int)) + Gen.(small_nat >>= fun n -> + pair (return n) (nat_split ~size:n n))) + (fun (n, arr) -> + Array.length arr = n + && Array.for_all (fun k -> 0 <= k) arr + && Array.fold_left (+) 0 arr = n) + + let nat_split_smaller = + Test.make ~name:"nat_split smaller" + (make + ~print:Print.(triple int int (array int)) + Gen.(small_nat >>= fun size -> + int_bound size >>= fun n -> + triple (return size) (return n) (nat_split ~size n))) + (fun (m, n, arr) -> + Array.length arr = m + && Array.for_all (fun k -> 0 <= k) arr + && Array.fold_left (+) 0 arr = n) + + let pos_split = + Test.make ~name:"pos_split" + (make + ~print:Print.(triple int int (array int)) + Gen.(pair small_nat small_nat >>= fun (m, n) -> + (* we need both size>0 and n>0 and size <= n *) + let size = 1 + min m n and n = 1 + max m n in + triple (return size) (return n) (pos_split ~size n))) + (fun (m, n, arr) -> + Array.length arr = m + && Array.for_all (fun k -> 0 < k) arr + && Array.fold_left (+) 0 arr = n) + + let test_tup2 = + Test.make ~count:10 + ~name:"forall x in (0, 1): x = (0, 1)" + (tup2 (always 0) (always 1)) + (fun x -> x = (0, 1)) + + let test_tup3 = + Test.make ~count:10 + ~name:"forall x in (0, 1, 2): x = (0, 1, 2)" + (tup3 (always 0) (always 1) (always 2)) + (fun x -> x = (0, 1, 2)) + + let test_tup4 = + Test.make ~count:10 + ~name:"forall x in (0, 1, 2, 3): x = (0, 1, 2, 3)" + (tup4 (always 0) (always 1) (always 2) (always 3)) + (fun x -> x = (0, 1, 2, 3)) + + let test_tup5 = + Test.make ~count:10 + ~name:"forall x in (0, 1, 2, 3, 4): x = (0, 1, 2, 3, 4)" + (tup5 (always 0) (always 1) (always 2) (always 3) (always 4)) + (fun x -> x = (0, 1, 2, 3, 4)) + + let test_tup6 = + Test.make ~count:10 + ~name:"forall x in (0, 1, 2, 3, 4, 5): x = (0, 1, 2, 3, 4, 5)" + (tup6 (always 0) (always 1) (always 2) (always 3) (always 4) (always 5)) + (fun x -> x = (0, 1, 2, 3, 4, 5)) + + let test_tup7 = + Test.make ~count:10 + ~name:"forall x in (0, 1, 2, 3, 4, 5, 6): x = (0, 1, 2, 3, 4, 5, 6)" + (tup7 + (always 0) (always 1) (always 2) (always 3) (always 4) + (always 5) (always 6)) + (fun x -> x = (0, 1, 2, 3, 4, 5, 6)) + + let test_tup8 = + Test.make ~count:10 + ~name:"forall x in (0, 1, 2, 3, 4, 5, 6, 7): x = (0, 1, 2, 3, 4, 5, 6, 7)" + (tup8 + (always 0) (always 1) (always 2) (always 3) (always 4) + (always 5) (always 6) (always 7)) + (fun x -> x = (0, 1, 2, 3, 4, 5, 6, 7)) + + let test_tup9 = + Test.make ~count:10 + ~name:"forall x in (0, 1, 2, 3, 4, 5, 6, 7, 8): x = (0, 1, 2, 3, 4, 5, 6, 7, 8)" + (tup9 + (always 0) (always 1) (always 2) (always 3) (always 4) + (always 5) (always 6) (always 7) (always 8)) + (fun x -> x = (0, 1, 2, 3, 4, 5, 6, 7, 8)) + + let tests = [ + char_dist_issue_23; + char_test; + nat_test; + string_test; + pair_test; + triple_test; + quad_test; + bind_test; + bind_pair_list_length; + list_test; + list_repeat_test; + array_repeat_test; + passing_tree_rev; + nat_split2_spec; + pos_split2_spec; + range_subset_spec; + nat_split_n_way; + nat_split_smaller; + pos_split; + test_tup2; + test_tup3; + test_tup4; + test_tup5; + test_tup6; + test_tup7; + test_tup8; + test_tup9; + ] +end + +(* negative tests that exercise shrinking behaviour *) +module Shrink = struct + open QCheck + + let rec fac n = match n with + | 0 -> 1 + | n -> n * fac (n - 1) + + (* example from issue #59 *) + let test_fac_issue59 = + Test.make ~name:"test fac issue59" + (set_shrink Shrink.nil (small_int_corners ())) + (fun n -> try (fac n) mod n = 0 + with + (*| Stack_overflow -> false*) + | Division_by_zero -> (n=0)) + + let big_bound_issue59 = + Test.make ~name:"big bound issue59" + (small_int_corners()) (fun i -> i < 209609) + + let long_shrink = + let listgen = list_of_size (Gen.int_range 1000 10000) int in + Test.make ~name:"long_shrink" (pair listgen listgen) + (fun (xs,ys) -> List.rev (xs@ys) = (List.rev xs)@(List.rev ys)) + + (* test from issue #36 *) + let ints_arent_0_mod_3 = + Test.make ~name:"ints arent 0 mod 3" ~count:1000 + int (fun i -> i mod 3 <> 0) + + let ints_are_0 = + Test.make ~name:"ints are 0" ~count:1000 + int (fun i -> Printf.printf "%i\n" i; i = 0) + + (* test from issue #59 *) + let ints_smaller_209609 = + Test.make ~name:"ints < 209609" + (small_int_corners()) (fun i -> i < 209609) + + let nats_smaller_5001 = + Test.make ~name:"nat < 5001" ~count:1000 + (make ~print:Print.int ~shrink:Shrink.int Gen.nat) (fun n -> n < 5001) + + let char_is_never_abcdef = + Test.make ~name:"char is never produces 'abcdef'" ~count:1000 + char (fun c -> not (List.mem c ['a';'b';'c';'d';'e';'f'])) + + let strings_are_empty = + Test.make ~name:"strings are empty" ~count:1000 + string (fun s -> s = "") + + let string_never_has_000_char = + Test.make ~name:"string never has a \\000 char" ~count:1000 + string + (fun s -> String.to_seq s |> Seq.fold_left (fun acc c -> acc && c <> '\000') true) + + let string_never_has_255_char = + Test.make ~name:"string never has a \\255 char" ~count:1000 + string + (fun s -> String.to_seq s |> Seq.fold_left (fun acc c -> acc && c <> '\255') true) + + (* test from issue #167 *) + let pair_diff_issue_64 = + Test.make ~name:"pairs have different components" + (pair small_int small_int) (fun (i,j) -> i<>j) + + let pair_same = + Test.make ~name:"pairs have same components" (pair int int) (fun (i,j) -> i=j) + + let pair_one_zero = + Test.make ~name:"pairs have a zero component" (pair int int) (fun (i,j) -> i=0 || j=0) + + let pair_all_zero = + Test.make ~name:"pairs are (0,0)" (pair int int) (fun (i,j) -> i=0 && j=0) + + let pair_ordered = + Test.make ~name:"pairs are ordered" (pair pos_int pos_int) (fun (i,j) -> i<=j) + + let pair_ordered_rev = + Test.make ~name:"pairs are ordered reversely" (pair pos_int pos_int) (fun (i,j) -> i>=j) + + let pair_sum_lt_128 = + Test.make ~name:"pairs sum to less than 128" (pair pos_int pos_int) (fun (i,j) -> i+j<128) + + let pair_lists_rev_concat = + Test.make ~name:"pairs lists rev concat" + (pair (list pos_int) (list pos_int)) + (fun (xs,ys) -> List.rev (xs@ys) = (List.rev xs)@(List.rev ys)) + + let pair_lists_no_overlap = + Test.make ~name:"pairs lists no overlap" + (pair (list small_nat) (list small_nat)) + (fun (xs,ys) -> List.for_all (fun x -> not (List.mem x ys)) xs) + + let triple_diff = + Test.make ~name:"triples have pair-wise different components" + (triple small_int small_int small_int) (fun (i,j,k) -> i<>j && j<>k) + + let triple_same = + Test.make ~name:"triples have same components" + (triple int int int) (fun (i,j,k) -> i=j || j=k) + + let triple_ordered = + Test.make ~name:"triples are ordered" + (triple int int int) (fun (i,j,k) -> i<=j && j<=k) + + let triple_ordered_rev = + Test.make ~name:"triples are ordered reversely" + (triple int int int) (fun (i,j,k) -> i>=j && j>=k) + + let quad_diff = + Test.make ~name:"quadruples have pair-wise different components" + (quad small_int small_int small_int small_int) (fun (h,i,j,k) -> h<>i && i<>j && j<>k) + + let quad_same = + Test.make ~name:"quadruples have same components" + (quad int int int int) (fun (h,i,j,k) -> h=i || i=j || j=k) + + let quad_ordered = + Test.make ~name:"quadruples are ordered" + (quad int int int int) (fun (h,i,j,k) -> h <= i && i <= j && j <= k) + + let quad_ordered_rev = + Test.make ~name:"quadruples are ordered reversely" + (quad int int int int) (fun (h,i,j,k) -> h >= i && i >= j && j >= k) + + let bind_pair_ordered = + Test.make ~name:"bind ordered pairs" + (make ~print:Print.(pair int int) + ~shrink:Shrink.(filter (fun (i,j) -> i<=j) (pair int int)) + Gen.(int >>= fun j -> int_bound j >>= fun i -> return (i,j))) + (fun (_i,_j) -> false) + + let bind_pair_list_size = + let shrink (_l,xs) = + Iter.map (fun xs' -> (List.length xs',xs')) Shrink.(list ~shrink:int xs) in + Test.make ~name:"bind list_size constant" + (make ~print:Print.(pair int (list int)) ~shrink + Gen.(int_bound 1000 >>= fun len -> + list_size (return len) (int_bound 1000) >>= fun xs -> return (len,xs))) + (fun (len,xs) -> let len' = List.length xs in len=len' && len' < 4) + + let print_list xs = print_endline Print.(list int xs) + + (* test from issue #64 *) + let lists_are_empty_issue_64 = + Test.make ~name:"lists are empty" + (list small_int) (fun xs -> print_list xs; xs = []) + + let list_shorter_10 = + Test.make ~name:"lists shorter than 10" + (list small_int) (fun xs -> List.length xs < 10) + + let length_printer xs = + Printf.sprintf "[...] list length: %i" (List.length xs) + + let size_gen = Gen.(oneof [small_nat; int_bound 750_000]) + + let list_shorter_432 = + Test.make ~name:"lists shorter than 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 -> List.length xs < 4332) + + let list_equal_dupl = + Test.make ~name:"lists equal to duplication" + (list_of_size size_gen small_int) + (fun xs -> try xs = xs @ xs + with Stack_overflow -> false) + + let list_unique_elems = + Test.make ~name:"lists have unique elems" + (list small_int) + (fun xs -> let ys = List.sort_uniq Int.compare xs in + print_list xs; List.length xs = List.length ys) + + let test_tup2 = + Test.make + ~name:"forall (a, b) in nat: a < b" + (tup2 small_int small_int) + (fun (a, b) -> a < b) + + let test_tup3 = + Test.make + ~name:"forall (a, b, c) in nat: a < b < c" + (tup3 small_int small_int small_int) + (fun (a, b, c) -> a < b && b < c) + + let test_tup4 = + Test.make + ~name:"forall (a, b, c, d) in nat: a < b < c < d" + (tup4 small_int small_int small_int small_int) + (fun (a, b, c, d) -> a < b && b < c && c < d) + + let test_tup5 = + Test.make + ~name:"forall (a, b, c, d, e) in nat: a < b < c < d < e" + (tup5 small_int small_int small_int small_int small_int) + (fun (a, b, c, d, e) -> a < b && b < c && c < d && d < e) + + let test_tup6 = + Test.make + ~name:"forall (a, b, c, d, e, f) in nat: a < b < c < d < e < f" + (tup6 small_int small_int small_int small_int small_int small_int) + (fun (a, b, c, d, e, f) -> a < b && b < c && c < d && d < e && e < f) + + let test_tup7 = + Test.make + ~name:"forall (a, b, c, d, e, f, g) in nat: a < b < c < d < e < f < g" + (tup7 small_int small_int small_int small_int small_int small_int small_int) + (fun (a, b, c, d, e, f, g) -> a < b && b < c && c < d && d < e && e < f && f < g) + + let test_tup8 = + Test.make + ~name:"forall (a, b, c, d, e, f, g, h) in nat: a < b < c < d < e < f < g < h" + (tup8 small_int small_int small_int small_int small_int small_int small_int small_int) + (fun (a, b, c, d, e, f, g, h) -> a < b && b < c && c < d && d < e && e < f && f < g && g < h) + + let test_tup9 = + Test.make + ~name:"forall (a, b, c, d, e, f, g, h, i) in nat: a < b < c < d < e < f < g < h < i" + (tup9 small_int small_int small_int small_int small_int small_int small_int small_int small_int) + (fun (a, b, c, d, e, f, g, h, i) -> a < b && b < c && c < d && d < e && e < f && f < g && g < h && h < i) + + let tree_contains_only_42 = + Test.make ~name:"tree contains only 42" + IntTree.(make ~print:print_tree ~shrink:shrink_tree gen_tree) + (fun tree -> IntTree.contains_only_n tree 42) + + let tests = [ + (*test_fac_issue59;*) + big_bound_issue59; + long_shrink; + ints_arent_0_mod_3; + ints_are_0; + ints_smaller_209609; + nats_smaller_5001; + char_is_never_abcdef; + strings_are_empty; + string_never_has_000_char; + string_never_has_255_char; + pair_diff_issue_64; + pair_same; + pair_one_zero; + pair_all_zero; + pair_ordered; + pair_ordered_rev; + pair_sum_lt_128; + pair_lists_rev_concat; + pair_lists_no_overlap; + triple_diff; + triple_same; + triple_ordered; + triple_ordered_rev; + quad_diff; + quad_same; + quad_ordered; + quad_ordered_rev; + bind_pair_ordered; + bind_pair_list_size; + lists_are_empty_issue_64; + list_shorter_10; + list_shorter_432; + list_shorter_4332; + list_equal_dupl; + list_unique_elems; + test_tup2; + test_tup3; + test_tup4; + test_tup5; + test_tup6; + test_tup7; + test_tup8; + test_tup9; + tree_contains_only_42; + ] +end + +(* tests function generator and shrinker *) +module Function = struct + open QCheck + + let fail_pred_map_commute = + Test.make ~name:"fail_pred_map_commute" ~count:100 ~long_factor:100 + (triple + (small_list small_int) + (fun1 Observable.int int) + (fun1 Observable.int bool)) + (fun (l,Fun (_,f),Fun (_,p)) -> + List.filter p (List.map f l) = List.map f (List.filter p l)) + + let fail_pred_strings = + Test.make ~name:"fail_pred_strings" ~count:100 + (fun1 Observable.string bool) + (fun (Fun (_,p)) -> not (p "some random string") || p "some other string") + + let int_gen = small_nat (* int *) + + (* Another example (false) property *) + let prop_foldleft_foldright = + Test.make ~name:"fold_left fold_right" ~count:1000 ~long_factor:20 + (triple + int_gen + (list int_gen) + (fun2 Observable.int Observable.int int_gen)) + (fun (z,xs,f) -> + let l1 = List.fold_right (Fn.apply f) xs z in + let l2 = List.fold_left (Fn.apply f) z xs in + if l1=l2 then true + else Test.fail_reportf "l=%s, fold_left=%s, fold_right=%s@." + (Print.(list int) xs) + (Print.int l1) + (Print.int l2) + ) + + (* Another example (false) property *) + let prop_foldleft_foldright_uncurry = + Test.make ~name:"fold_left fold_right uncurried" ~count:1000 ~long_factor:20 + (triple + (fun1 Observable.(pair int int) int_gen) + int_gen + (list int_gen)) + (fun (f,z,xs) -> + List.fold_right (fun x y -> Fn.apply f (x,y)) xs z = + List.fold_left (fun x y -> Fn.apply f (x,y)) z xs) + + (* Same as the above (false) property, but generating+shrinking functions last *) + let prop_foldleft_foldright_uncurry_funlast = + Test.make ~name:"fold_left fold_right uncurried fun last" ~count:1000 ~long_factor:20 + (triple + int_gen + (list int_gen) + (fun1 Observable.(pair int int) int_gen)) + (fun (z,xs,f) -> + List.fold_right (fun x y -> Fn.apply f (x,y)) xs z = + List.fold_left (fun x y -> Fn.apply f (x,y)) z xs) + + (* test from issue #64 *) + let fold_left_test = + Test.make ~name:"false fold, fun first" + (quad (* string -> int -> string *) + (fun2 Observable.string Observable.int small_string) + small_string + (list small_int) + (list small_int)) + (fun (f,acc,is,js) -> + let f = Fn.apply f in + List.fold_left f acc (is @ js) + = List.fold_left f (List.fold_left f acc is) is) (*Typo*) + + let tests = [ + fail_pred_map_commute; + fail_pred_strings; + prop_foldleft_foldright; + prop_foldleft_foldright_uncurry; + prop_foldleft_foldright_uncurry_funlast; + fold_left_test; + ] +end + +(* tests of (inner) find_example(_gen) behaviour *) +module FindExample = struct + open QCheck + + let find_ex = + Test.make ~name:"find_example" (2--50) + (fun n -> + let st = Random.State.make [| 0 |] in + let f m = n < m && m < 2 * n in + try + let m = find_example_gen ~rand:st ~count:100_000 ~f Gen.(0 -- 1000) in + f m + with No_example_found _ -> false) + + let find_ex_uncaught_issue_99_1_fail = + let rs = make (find_example ~count:10 ~f:(fun _ -> false) Gen.int) in + Test.make ~name:"FAIL_#99_1" rs (fun _ -> true) + + let find_ex_uncaught_issue_99_2_succeed = + Test.make ~name:"should_succeed_#99_2" ~count:10 + int (fun i -> i <= max_int) + + let tests = [ + find_ex; + find_ex_uncaught_issue_99_1_fail; + find_ex_uncaught_issue_99_2_succeed; + ] +end + +(* tests of statistics and histogram display *) +module Stats = struct + open QCheck + + let bool_dist = + Test.make ~name:"bool dist" ~count:500_000 (set_collect Bool.to_string bool) (fun _ -> true) + + let char_dist = + Test.make ~name:"char code dist" ~count:500_000 (add_stat ("char code", Char.code) char) (fun _ -> true) + + let string_len_tests = + let len = ("len",String.length) in + [ + Test.make ~name:"string_size len dist" ~count:5_000 (add_stat len (string_of_size (Gen.int_range 5 10))) (fun _ -> true); + Test.make ~name:"string len dist" ~count:5_000 (add_stat len string) (fun _ -> true); + Test.make ~name:"string_of len dist" ~count:5_000 (add_stat len (string_gen (Gen.return 'a'))) (fun _ -> true); + Test.make ~name:"printable_string len dist" ~count:5_000 (add_stat len printable_string) (fun _ -> true); + Test.make ~name:"small_string len dist" ~count:5_000 (add_stat len small_string) (fun _ -> true); + ] + + let pair_dist = + Test.make ~name:"pair dist" ~count:500_000 + (add_stat ("pair sum", (fun (i,j) -> i+j)) + (pair (int_bound 100) (int_bound 100))) (fun _ -> true) + + let triple_dist = + Test.make ~name:"triple dist" ~count:500_000 + (add_stat ("triple sum", (fun (i,j,k) -> i+j+k)) + (triple (int_bound 100) (int_bound 100) (int_bound 100))) (fun _ -> true) + + let quad_dist = + Test.make ~name:"quad dist" ~count:500_000 + (add_stat ("quad sum", (fun (h,i,j,k) -> h+i+j+k)) + (quad (int_bound 100) (int_bound 100) (int_bound 100) (int_bound 100))) (fun _ -> true) + + let bind_dist = + Test.make ~name:"bind dist" ~count:1_000_000 + (make ~stats:[("ordered pair difference", (fun (i,j) -> j-i));("ordered pair sum", (fun (i,j) -> i+j))] + Gen.(int_bound 100 >>= fun j -> int_bound j >>= fun i -> return (i,j))) (fun _ -> true) + + let list_len_tests = + let len = ("len",List.length) in + [ (* test from issue #30 *) + Test.make ~name:"list len dist" ~count:5_000 (add_stat len (list int)) (fun _ -> true); + Test.make ~name:"small_list len dist" ~count:5_000 (add_stat len (small_list int)) (fun _ -> true); + Test.make ~name:"list_of_size len dist" ~count:5_000 (add_stat len (list_of_size (Gen.int_range 5 10) int)) (fun _ -> true); + Test.make ~name:"list_repeat len dist" ~count:5_000 (add_stat len (make Gen.(list_repeat 42 int))) (fun _ -> true); + ] + + let array_len_tests = + let len = ("len",Array.length) in + [ + Test.make ~name:"array len dist" ~count:5_000 (add_stat len (array int)) (fun _ -> true); + Test.make ~name:"small_array len dist" ~count:5_000 (add_stat len (make Gen.(small_array int))) (fun _ -> true); + Test.make ~name:"array_of_size len dist" ~count:5_000 (add_stat len (array_of_size (Gen.int_range 5 10) int)) (fun _ -> true); + Test.make ~name:"array_repeat len dist" ~count:5_000 (add_stat len (make Gen.(array_repeat 42 int))) (fun _ -> true); + ] + + let int_dist_tests = + let dist = ("dist",fun x -> x) in + [ (* test from issue #40 *) + Test.make ~name:"int_stats_neg" ~count:5000 (add_stat dist small_signed_int) (fun _ -> true); + (* distribution tests from PR #45 *) + Test.make ~name:"small_signed_int dist" ~count:1000 (add_stat dist small_signed_int) (fun _ -> true); + Test.make ~name:"small_nat dist" ~count:1000 (add_stat dist small_nat) (fun _ -> true); + Test.make ~name:"nat dist" ~count:1000 (add_stat dist (make Gen.nat)) (fun _ -> true); + Test.make ~name:"int_range (-43643) 435434 dist" ~count:1000 (add_stat dist (int_range (-43643) 435434)) (fun _ -> true); + Test.make ~name:"int_range (-40000) 40000 dist" ~count:1000 (add_stat dist (int_range (-40000) 40000)) (fun _ -> true); + Test.make ~name:"int_range (-4) 4 dist" ~count:1000 (add_stat dist (int_range (-4) 4)) (fun _ -> true); + Test.make ~name:"int_range (-4) 17 dist" ~count:1000 (add_stat dist (int_range (-4) 17)) (fun _ -> true); + Test.make ~name:"int dist" ~count:100000 (add_stat dist int) (fun _ -> true); + Test.make ~name:"oneof int dist" ~count:1000 (add_stat dist (oneofl[min_int;-1;0;1;max_int])) (fun _ -> true); + ] + + let tree_depth_test = + let depth = ("depth", IntTree.depth) in + Test.make ~name:"tree's depth" ~count:1000 (add_stat depth (make IntTree.gen_tree)) (fun _ -> true) + + let range_subset_test = + Test.make ~name:"range_subset_spec" ~count:5_000 + (add_stat ("dist", fun a -> a.(0)) (make (Gen.range_subset ~size:1 0 20))) + (fun a -> Array.length a = 1) + + let int_dist_empty_bucket = + Test.make ~name:"int_dist_empty_bucket" ~count:1_000 + (add_stat ("dist",fun x -> x) (oneof [small_int_corners ();int])) (fun _ -> true) + + let tests = + [ bool_dist; + char_dist; + tree_depth_test; + range_subset_test;] + @ string_len_tests + @ [pair_dist; + triple_dist; + quad_dist; + bind_dist;] + @ list_len_tests + @ array_len_tests + @ int_dist_tests +end diff --git a/test/core/dune b/test/core/dune index 94523bb9..6f5b9499 100644 --- a/test/core/dune +++ b/test/core/dune @@ -1,7 +1,22 @@ +(library + (name QCheck_tests) + (modules QCheck_tests) + (libraries qcheck-core)) + +(library + (name QCheck2_tests) + (modules QCheck2_tests) + (libraries qcheck-core)) + +(tests + (names QCheck_expect_test) + (modules QCheck_expect_test) + (libraries qcheck-core qcheck-core.runner QCheck_tests)) + (tests - (names QCheck_expect_test QCheck2_expect_test) - (modules QCheck_expect_test QCheck2_expect_test) - (libraries qcheck-core qcheck-core.runner)) + (names QCheck2_expect_test) + (modules QCheck2_expect_test) + (libraries qcheck-core qcheck-core.runner QCheck2_tests)) (tests (names QCheck_unit_tests QCheck2_unit_tests) From 19edcc37c599524f77ffe6212344e5d3f4cc5294 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Sun, 12 Sep 2021 23:29:37 +0200 Subject: [PATCH 4/7] fix bind_pair_ordered + add variant w/gen exception --- test/core/QCheck2_expect_test.expected | 10 +++++++++- test/core/QCheck2_tests.ml | 8 +++++++- test/core/QCheck_expect_test.expected | 12 ++++++++++-- test/core/QCheck_tests.ml | 10 +++++++++- 4 files changed, 35 insertions(+), 5 deletions(-) diff --git a/test/core/QCheck2_expect_test.expected b/test/core/QCheck2_expect_test.expected index 4e6a0bd9..e6c1ad3e 100644 --- a/test/core/QCheck2_expect_test.expected +++ b/test/core/QCheck2_expect_test.expected @@ -420,6 +420,14 @@ Test bind ordered pairs failed (1 shrink steps): --- Failure -------------------------------------------------------------------- +Test bind ordered pairs - gen bug failed: + +ERROR: uncaught exception in generator for test bind ordered pairs - gen bug after 100 steps: +Exception: Invalid_argument("Gen.int_bound") +Backtrace: + +--- Failure -------------------------------------------------------------------- + Test bind list_size constant failed (12 shrink steps): (4, [0; 0; 0; 0]) @@ -1228,7 +1236,7 @@ stats dist: 4150517416584649600.. 4611686018427387903: ################# 189 ================================================================================ 1 warning(s) -failure (55 tests failed, 1 tests errored, ran 112 tests) +failure (56 tests failed, 1 tests errored, ran 113 tests) random seed: 153870556 +++ Stats for int_dist_empty_bucket ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/test/core/QCheck2_tests.ml b/test/core/QCheck2_tests.ml index f53b2e64..7ec54306 100644 --- a/test/core/QCheck2_tests.ml +++ b/test/core/QCheck2_tests.ml @@ -386,9 +386,14 @@ module Shrink = struct let bind_pair_ordered = Test.make ~name:"bind ordered pairs" ~print:Print.(pair int int) - Gen.(int >>= fun j -> int_bound j >>= fun i -> return (i,j)) + Gen.(pint ~origin:0 >>= fun j -> int_bound j >>= fun i -> return (i,j)) (fun (_i,_j) -> false) + let bind_pair_ordered_gen_bug = + Test.make ~name:"bind ordered pairs - gen bug" ~print:Print.(pair int int) + Gen.(int >>= fun j -> int_bound j >>= fun i -> return (i,j)) (* i may be negative, causing int_bound to fail *) + (fun (_i,_j) -> true) + let bind_pair_list_size = Test.make ~name:"bind list_size constant" ~print:Print.(pair int (list int)) Gen.(int_bound 1000 >>= fun len -> @@ -524,6 +529,7 @@ module Shrink = struct quad_ordered; quad_ordered_rev; bind_pair_ordered; + bind_pair_ordered_gen_bug; bind_pair_list_size; lists_are_empty_issue_64; list_shorter_10; diff --git a/test/core/QCheck_expect_test.expected b/test/core/QCheck_expect_test.expected index d67b9311..3a7e850d 100644 --- a/test/core/QCheck_expect_test.expected +++ b/test/core/QCheck_expect_test.expected @@ -349,12 +349,20 @@ Test quadruples are ordered reversely failed (251 shrink steps): --- Failure -------------------------------------------------------------------- -Test bind ordered pairs failed (123 shrink steps): +Test bind ordered pairs failed (125 shrink steps): (0, 0) --- Failure -------------------------------------------------------------------- +Test bind ordered pairs - gen bug failed: + +ERROR: uncaught exception in generator for test bind ordered pairs - gen bug after 100 steps: +Exception: Invalid_argument("Gen.int_bound") +Backtrace: + +--- Failure -------------------------------------------------------------------- + Test bind list_size constant failed (50 shrink steps): (4, [0; 0; 0; 0]) @@ -1189,7 +1197,7 @@ stats dist: 4150517416584649600.. 4611686018427387903: ################# 189 ================================================================================ 1 warning(s) -failure (55 tests failed, 1 tests errored, ran 119 tests) +failure (56 tests failed, 1 tests errored, ran 120 tests) random seed: 153870556 +++ Stats for int_dist_empty_bucket ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/test/core/QCheck_tests.ml b/test/core/QCheck_tests.ml index f0e39ab1..2e81f43f 100644 --- a/test/core/QCheck_tests.ml +++ b/test/core/QCheck_tests.ml @@ -475,9 +475,16 @@ module Shrink = struct Test.make ~name:"bind ordered pairs" (make ~print:Print.(pair int int) ~shrink:Shrink.(filter (fun (i,j) -> i<=j) (pair int int)) - Gen.(int >>= fun j -> int_bound j >>= fun i -> return (i,j))) + Gen.(pint >>= fun j -> int_bound j >>= fun i -> return (i,j))) (fun (_i,_j) -> false) + let bind_pair_ordered_gen_bug = + Test.make ~name:"bind ordered pairs - gen bug" + (make ~print:Print.(pair int int) + ~shrink:Shrink.(filter (fun (i,j) -> i<=j) (pair int int)) + Gen.(int >>= fun j -> int_bound j >>= fun i -> return (i,j))) (* i may be negative, causing int_bound to fail *) + (fun (_i,_j) -> true) + let bind_pair_list_size = let shrink (_l,xs) = Iter.map (fun xs' -> (List.length xs',xs')) Shrink.(list ~shrink:int xs) in @@ -608,6 +615,7 @@ module Shrink = struct quad_ordered; quad_ordered_rev; bind_pair_ordered; + bind_pair_ordered_gen_bug; bind_pair_list_size; lists_are_empty_issue_64; list_shorter_10; From 03654fec3e682bd69b84f80654ca570774cbbec4 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Mon, 13 Sep 2021 08:55:04 +0200 Subject: [PATCH 5/7] mv gen-failure test to Overall --- test/core/QCheck2_expect_test.expected | 16 ++++++++-------- test/core/QCheck2_tests.ml | 12 ++++++------ test/core/QCheck_expect_test.expected | 16 ++++++++-------- test/core/QCheck_tests.ml | 14 ++++++-------- 4 files changed, 28 insertions(+), 30 deletions(-) diff --git a/test/core/QCheck2_expect_test.expected b/test/core/QCheck2_expect_test.expected index e6c1ad3e..7ff1b393 100644 --- a/test/core/QCheck2_expect_test.expected +++ b/test/core/QCheck2_expect_test.expected @@ -244,6 +244,14 @@ ERROR: only 0.5% tests (of 2000) passed precondition for "FAIL_unlikely_precond" NOTE: it is likely that the precondition is too strong, or that the generator is buggy. +--- Failure -------------------------------------------------------------------- + +Test FAIL_bad_gen failed: + +ERROR: uncaught exception in generator for test FAIL_bad_gen after 100 steps: +Exception: Invalid_argument("Gen.int_bound") +Backtrace: + --- Failure -------------------------------------------------------------------- Test char never produces '\255' failed (0 shrink steps): @@ -420,14 +428,6 @@ Test bind ordered pairs failed (1 shrink steps): --- Failure -------------------------------------------------------------------- -Test bind ordered pairs - gen bug failed: - -ERROR: uncaught exception in generator for test bind ordered pairs - gen bug after 100 steps: -Exception: Invalid_argument("Gen.int_bound") -Backtrace: - ---- Failure -------------------------------------------------------------------- - Test bind list_size constant failed (12 shrink steps): (4, [0; 0; 0; 0]) diff --git a/test/core/QCheck2_tests.ml b/test/core/QCheck2_tests.ml index 7ec54306..fc99232c 100644 --- a/test/core/QCheck2_tests.ml +++ b/test/core/QCheck2_tests.ml @@ -84,6 +84,11 @@ module Overall = struct QCheck.assume (x mod 100 = 1); true) + let bad_gen_fail = + Test.make ~name:"FAIL_bad_gen" + Gen.(int >>= fun j -> int_bound j >>= fun i -> return (i,j)) + (fun (_i,_j) -> true) (* i may be negative, causing int_bound to fail *) + let tests = [ passing; failing; @@ -93,6 +98,7 @@ module Overall = struct retries; bad_assume_warn; bad_assume_fail; + bad_gen_fail; ] end @@ -389,11 +395,6 @@ module Shrink = struct Gen.(pint ~origin:0 >>= fun j -> int_bound j >>= fun i -> return (i,j)) (fun (_i,_j) -> false) - let bind_pair_ordered_gen_bug = - Test.make ~name:"bind ordered pairs - gen bug" ~print:Print.(pair int int) - Gen.(int >>= fun j -> int_bound j >>= fun i -> return (i,j)) (* i may be negative, causing int_bound to fail *) - (fun (_i,_j) -> true) - let bind_pair_list_size = Test.make ~name:"bind list_size constant" ~print:Print.(pair int (list int)) Gen.(int_bound 1000 >>= fun len -> @@ -529,7 +530,6 @@ module Shrink = struct quad_ordered; quad_ordered_rev; bind_pair_ordered; - bind_pair_ordered_gen_bug; bind_pair_list_size; lists_are_empty_issue_64; list_shorter_10; diff --git a/test/core/QCheck_expect_test.expected b/test/core/QCheck_expect_test.expected index 3a7e850d..2d1756ec 100644 --- a/test/core/QCheck_expect_test.expected +++ b/test/core/QCheck_expect_test.expected @@ -179,6 +179,14 @@ ERROR: only 0.5% tests (of 2000) passed precondition for "FAIL_unlikely_precond" NOTE: it is likely that the precondition is too strong, or that the generator is buggy. +--- Failure -------------------------------------------------------------------- + +Test FAIL_bad_gen failed: + +ERROR: uncaught exception in generator for test FAIL_bad_gen after 100 steps: +Exception: Invalid_argument("Gen.int_bound") +Backtrace: + --- Failure -------------------------------------------------------------------- Test char never produces '\255' failed (0 shrink steps): @@ -355,14 +363,6 @@ Test bind ordered pairs failed (125 shrink steps): --- Failure -------------------------------------------------------------------- -Test bind ordered pairs - gen bug failed: - -ERROR: uncaught exception in generator for test bind ordered pairs - gen bug after 100 steps: -Exception: Invalid_argument("Gen.int_bound") -Backtrace: - ---- Failure -------------------------------------------------------------------- - Test bind list_size constant failed (50 shrink steps): (4, [0; 0; 0; 0]) diff --git a/test/core/QCheck_tests.ml b/test/core/QCheck_tests.ml index 2e81f43f..3ccef27d 100644 --- a/test/core/QCheck_tests.ml +++ b/test/core/QCheck_tests.ml @@ -94,6 +94,11 @@ module Overall = struct QCheck.assume (x mod 100 = 1); true) + let bad_gen_fail = + Test.make ~name:"FAIL_bad_gen" + (make Gen.(int >>= fun j -> int_bound j >>= fun i -> return (i,j))) + (fun (_i,_j) -> true) (* i may be negative, causing int_bound to fail *) + let tests = [ passing; failing; @@ -103,6 +108,7 @@ module Overall = struct retries; bad_assume_warn; bad_assume_fail; + bad_gen_fail; ] end @@ -478,13 +484,6 @@ module Shrink = struct Gen.(pint >>= fun j -> int_bound j >>= fun i -> return (i,j))) (fun (_i,_j) -> false) - let bind_pair_ordered_gen_bug = - Test.make ~name:"bind ordered pairs - gen bug" - (make ~print:Print.(pair int int) - ~shrink:Shrink.(filter (fun (i,j) -> i<=j) (pair int int)) - Gen.(int >>= fun j -> int_bound j >>= fun i -> return (i,j))) (* i may be negative, causing int_bound to fail *) - (fun (_i,_j) -> true) - let bind_pair_list_size = let shrink (_l,xs) = Iter.map (fun xs' -> (List.length xs',xs')) Shrink.(list ~shrink:int xs) in @@ -615,7 +614,6 @@ module Shrink = struct quad_ordered; quad_ordered_rev; bind_pair_ordered; - bind_pair_ordered_gen_bug; bind_pair_list_size; lists_are_empty_issue_64; list_shorter_10; From 68ad3bb7e8e859626d7b42ca82ba4429893713f1 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Mon, 13 Sep 2021 11:47:45 +0200 Subject: [PATCH 6/7] add string test --- test/core/QCheck2_expect_test.expected | 8 +++++++- test/core/QCheck2_tests.ml | 8 ++++++++ test/core/QCheck_expect_test.expected | 8 +++++++- test/core/QCheck_tests.ml | 8 ++++++++ 4 files changed, 30 insertions(+), 2 deletions(-) diff --git a/test/core/QCheck2_expect_test.expected b/test/core/QCheck2_expect_test.expected index 7ff1b393..d82ef765 100644 --- a/test/core/QCheck2_expect_test.expected +++ b/test/core/QCheck2_expect_test.expected @@ -320,6 +320,12 @@ Test string never has a \255 char failed (59 shrink steps): --- Failure -------------------------------------------------------------------- +Test strings have unique chars failed (18 shrink steps): + +"aaaaaaaaaaaaa" + +--- Failure -------------------------------------------------------------------- + Test pairs have different components failed (0 shrink steps): (4, 4) @@ -1236,7 +1242,7 @@ stats dist: 4150517416584649600.. 4611686018427387903: ################# 189 ================================================================================ 1 warning(s) -failure (56 tests failed, 1 tests errored, ran 113 tests) +failure (57 tests failed, 1 tests errored, ran 114 tests) random seed: 153870556 +++ Stats for int_dist_empty_bucket ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/test/core/QCheck2_tests.ml b/test/core/QCheck2_tests.ml index fc99232c..49223cbb 100644 --- a/test/core/QCheck2_tests.ml +++ b/test/core/QCheck2_tests.ml @@ -319,6 +319,13 @@ module Shrink = struct Gen.string (fun s -> String.to_seq s |> Seq.fold_left (fun acc c -> acc && c <> '\255') true) + let string_unique_chars = + Test.make ~name:"strings have unique chars" ~count:1000 ~print:Print.string + Gen.string + (fun s -> + let ch_list = String.to_seq s |> List.of_seq in + List.length ch_list = List.length (List.sort_uniq Char.compare ch_list)) + (* test from issue #167 *) let pair_diff_issue_64 = Test.make ~name:"pairs have different components" ~print:Print.(pair int int) @@ -512,6 +519,7 @@ module Shrink = struct strings_are_empty; string_never_has_000_char; string_never_has_255_char; + string_unique_chars; pair_diff_issue_64; pair_same; pair_one_zero; diff --git a/test/core/QCheck_expect_test.expected b/test/core/QCheck_expect_test.expected index 2d1756ec..55b9f181 100644 --- a/test/core/QCheck_expect_test.expected +++ b/test/core/QCheck_expect_test.expected @@ -255,6 +255,12 @@ Test string never has a \255 char failed (249 shrink steps): --- Failure -------------------------------------------------------------------- +Test strings have unique chars failed (248 shrink steps): + +"\206\206" + +--- Failure -------------------------------------------------------------------- + Test pairs have different components failed (0 shrink steps): (4, 4) @@ -1197,7 +1203,7 @@ stats dist: 4150517416584649600.. 4611686018427387903: ################# 189 ================================================================================ 1 warning(s) -failure (56 tests failed, 1 tests errored, ran 120 tests) +failure (57 tests failed, 1 tests errored, ran 121 tests) random seed: 153870556 +++ Stats for int_dist_empty_bucket ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/test/core/QCheck_tests.ml b/test/core/QCheck_tests.ml index 3ccef27d..574d02df 100644 --- a/test/core/QCheck_tests.ml +++ b/test/core/QCheck_tests.ml @@ -412,6 +412,13 @@ module Shrink = struct string (fun s -> String.to_seq s |> Seq.fold_left (fun acc c -> acc && c <> '\255') true) + let string_unique_chars = + Test.make ~name:"strings have unique chars" ~count:1000 + string + (fun s -> + let ch_list = String.to_seq s |> List.of_seq in + List.length ch_list = List.length (List.sort_uniq Char.compare ch_list)) + (* test from issue #167 *) let pair_diff_issue_64 = Test.make ~name:"pairs have different components" @@ -596,6 +603,7 @@ module Shrink = struct strings_are_empty; string_never_has_000_char; string_never_has_255_char; + string_unique_chars; pair_diff_issue_64; pair_same; pair_one_zero; From 08a138f309989e75162ec908c50b05388c3c4802 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Mon, 13 Sep 2021 22:12:19 +0200 Subject: [PATCH 7/7] add shrink-failure test + adj. test name --- test/core/QCheck2_tests.ml | 8 ++++++++ test/core/QCheck_expect_test.expected | 2 +- test/core/QCheck_tests.ml | 10 +++++++++- 3 files changed, 18 insertions(+), 2 deletions(-) diff --git a/test/core/QCheck2_tests.ml b/test/core/QCheck2_tests.ml index 49223cbb..3024f5d4 100644 --- a/test/core/QCheck2_tests.ml +++ b/test/core/QCheck2_tests.ml @@ -89,6 +89,13 @@ module Overall = struct Gen.(int >>= fun j -> int_bound j >>= fun i -> return (i,j)) (fun (_i,_j) -> true) (* i may be negative, causing int_bound to fail *) + let bad_shrinker_fail = + Test.make ~name:"FAIL_bad_shrinker" + (Gen.make_primitive + ~shrink:(fun _i -> raise Error) + ~gen:(fun rs -> Random.State.int rs)) + (fun _i -> false) + let tests = [ passing; failing; @@ -99,6 +106,7 @@ module Overall = struct bad_assume_warn; bad_assume_fail; bad_gen_fail; + (*bad_shrinker_fail;*) ] end diff --git a/test/core/QCheck_expect_test.expected b/test/core/QCheck_expect_test.expected index 55b9f181..eff97d15 100644 --- a/test/core/QCheck_expect_test.expected +++ b/test/core/QCheck_expect_test.expected @@ -502,7 +502,7 @@ Test fold_left fold_right uncurried fun last failed (26 shrink steps): --- Failure -------------------------------------------------------------------- -Test false fold, fun first failed (40 shrink steps): +Test fold_left test, fun first failed (40 shrink steps): ({_ -> ""}, "z", [], [0]) diff --git a/test/core/QCheck_tests.ml b/test/core/QCheck_tests.ml index 574d02df..af25b045 100644 --- a/test/core/QCheck_tests.ml +++ b/test/core/QCheck_tests.ml @@ -99,6 +99,13 @@ module Overall = struct (make Gen.(int >>= fun j -> int_bound j >>= fun i -> return (i,j))) (fun (_i,_j) -> true) (* i may be negative, causing int_bound to fail *) + let bad_shrinker_fail = + Test.make ~name:"FAIL_bad_shrinker" + (make + ~shrink:(fun _i -> raise Error) + Gen.int) + (fun _i -> false) + let tests = [ passing; failing; @@ -109,6 +116,7 @@ module Overall = struct bad_assume_warn; bad_assume_fail; bad_gen_fail; + (*bad_shrinker_fail;*) ] end @@ -702,7 +710,7 @@ module Function = struct (* test from issue #64 *) let fold_left_test = - Test.make ~name:"false fold, fun first" + Test.make ~name:"fold_left test, fun first" (quad (* string -> int -> string *) (fun2 Observable.string Observable.int small_string) small_string