diff --git a/CHANGELOG.md b/CHANGELOG.md index e2a53789..70615f46 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -58,6 +58,10 @@ - Add a documentation warning about the precedence of `==>` to `QCheck` and `QCheck2` - Remove 32-bit support from QCheck's internal test suite. The libraries themselves are expected to continue running on 32-bit platforms. +- Add `QCheck2.Gen.recursive`, a combinator for building generators of + recursive types from their base and recursive cases. It scales the size by + the reciprocal of the golden ratio (~0.618) at each level rather than + halving, and takes an optional `?scale` to override that schedule. ## 0.91 (2025-12-21) diff --git a/src/core/QCheck2.ml b/src/core/QCheck2.ml index 1e20a379..2669fa23 100644 --- a/src/core/QCheck2.ml +++ b/src/core/QCheck2.ml @@ -889,6 +889,27 @@ module Gen = struct let rec f' n st = f f' n st in f' + (* The reciprocal of the golden ratio, the default per-level size scaling + factor of [recursive]. *) + let golden_ratio_scale (n : int) : int = + int_of_float (Float.round (float_of_int n *. 0.618033988749895)) + + let recursive ?(scale = golden_ratio_scale) + (combine : 'a t list -> 'a t) + (base : 'a t list) + (rec_cases : ('a t -> 'a t) list) : 'a t = + match base with + | [] -> failwith "QCheck2.Gen.recursive called with an empty list of base cases" + | _ -> + sized (fix (fun self n -> + if n <= 1 + then combine base + else + (* Clamping to [n - 1] keeps the recursion well-founded whatever + [scale] returns. *) + let smaller = delay (fun () -> self (max 0 (min (n - 1) (scale n)))) in + combine (base @ List.map (fun rec_case -> rec_case smaller) rec_cases))) + let generate ?(rand=RS.make_self_init()) ~(n : int) (gen : 'a t) : 'a list = list_repeat n gen rand |> Tree.root diff --git a/src/core/QCheck2.mli b/src/core/QCheck2.mli index e40dc4f4..fba9c47e 100644 --- a/src/core/QCheck2.mli +++ b/src/core/QCheck2.mli @@ -856,6 +856,50 @@ module Gen : sig in a generator. @since 0.17 *) + val recursive : + ?scale:(int -> int) -> + ('a t list -> 'a t) -> + 'a t list -> + ('a t -> 'a t) list -> + 'a t + (** [recursive combine base rec_cases] builds a generator for a recursive + type out of its non-recursive cases [base] and its recursive cases + [rec_cases], combined with [combine] - typically {!oneof}, or + {!oneof_weighted} composed with a weighting function. + + A size is drawn with {!val:sized}, and every generator in [rec_cases] is + handed a generator for the same type at a smaller size. The size is + multiplied by the reciprocal of the golden ratio (approximately [0.618]) + at each level, so the expected depth grows with the drawn size instead of + being bounded by a fixed division schedule. Once the size reaches [1] only + [base] is used, which is what terminates the recursion. + + Compared to writing the recursion by hand with {!val:sized} and {!fix}, this + combinator picks the size schedule for you and makes the base cases + syntactically distinct from the recursive ones, so a generator cannot + accidentally be written without a terminating case. + + Example: + {[ + type tree = Leaf of int | Node of tree * tree + + let tree_gen = + QCheck2.Gen.(recursive oneof + [ map (fun i -> Leaf i) nat ] + [ (fun self -> map2 (fun l r -> Node (l, r)) self self) ]) + ]} + + Shrinks on the size first, then on the selected cases. + + @param scale how the size is reduced at each level, [0.618] times the + size by default. Its result is clamped to the range [\[0, n - 1\]], so a + [scale] that fails to decrease cannot make generation diverge. + + @raise Failure if [base] is empty, since the recursion could then never + stop. + + @since 0.92 *) + (** {2:composing_generators Composing generators} QCheck generators compose well: it means one can easily craft generators for new values diff --git a/test/core/QCheck2_unit_tests.ml b/test/core/QCheck2_unit_tests.ml index 9dad143e..5495dfb1 100644 --- a/test/core/QCheck2_unit_tests.ml +++ b/test/core/QCheck2_unit_tests.ml @@ -583,10 +583,75 @@ module Gen = struct let b = nb > 400 && nb < 600 in Alcotest.(check bool) "Gen.option produces around 50% of Some" b true + type tree = Leaf of int | Node of tree * tree + + let tree_gen = + Gen.(recursive oneof + [ map (fun i -> Leaf i) nat ] + [ (fun self -> map2 (fun l r -> Node (l, r)) self self) ]) + + let rec tree_depth = function + | Leaf _ -> 1 + | Node (l, r) -> 1 + max (tree_depth l) (tree_depth r) + + let sample_depths ?(count = 200) ~seed gen = + let rand = rand_init seed in + List.init count (fun _ -> tree_depth (Gen.generate1 ~rand gen)) + + let test_gen_recursive_terminates () = + let depths = sample_depths ~seed:1234 tree_gen in + let max_depth = List.fold_left max 0 depths in + (* [nat] draws at most 9999 and the size is multiplied by 0.618 per level, + so no sample can be deeper than log(9999) / log(1/0.618) ~ 20 levels. *) + Alcotest.(check bool) + "Gen.recursive bounds the depth by the golden ratio schedule" + true (max_depth <= 25); + Alcotest.(check bool) + "Gen.recursive actually uses its recursive cases" + true (max_depth > 1) + + let test_gen_recursive_requires_base_case () = + Alcotest.check_raises + "Gen.recursive rejects an empty list of base cases" + (Failure "QCheck2.Gen.recursive called with an empty list of base cases") + (fun () -> ignore (Gen.recursive Gen.oneof [] [ (fun self -> self) ])) + + let test_gen_recursive_scale_cannot_diverge () = + (* A [scale] that grows the size is clamped to [n - 1], so the recursion + still terminates - here on a linear structure, to keep it cheap. *) + let list_gen = + Gen.(recursive ~scale:(fun n -> n * 100) oneof + [ pure [] ] + [ (fun self -> map2 (fun x xs -> x :: xs) nat self) ]) + in + let rand = rand_init 99 in + let lengths = List.init 20 (fun _ -> List.length (Gen.generate1 ~rand list_gen)) in + Alcotest.(check bool) + "Gen.recursive clamps a non-decreasing scale" + true (List.for_all (fun n -> n <= 10_000) lengths) + + let test_gen_recursive_shrinks_to_base_case () = + let rand = rand_init 7 in + let rec find_recursive_tree remaining = + if remaining = 0 + then Alcotest.fail "Gen.recursive produced no recursive tree in 100 tries" + else + let t = Gen.generate_tree ~rand tree_gen in + if tree_depth (Tree.root t) > 1 then t else find_recursive_tree (remaining - 1) + in + let path = repeated_success (find_recursive_tree 100) in + Alcotest.(check bool) + "Gen.recursive shrinks down to a base case" + true (List.exists (fun v -> tree_depth v = 1) path) + let tests = ("Gen", Alcotest.[ test_case "option with default ratio" `Quick test_gen_option_default; test_case "option with custom ratio" `Quick test_gen_option_custom; + test_case "recursive terminates" `Quick test_gen_recursive_terminates; + test_case "recursive requires a base case" `Quick test_gen_recursive_requires_base_case; + test_case "recursive clamps its scale" `Quick test_gen_recursive_scale_cannot_diverge; + test_case "recursive shrinks to a base case" `Quick test_gen_recursive_shrinks_to_base_case; ]) end