From 66d84cee2611ca8bb562c1831ea0a5028c27896b Mon Sep 17 00:00:00 2001 From: Alexey Raga Date: Fri, 14 Nov 2025 18:26:58 +1100 Subject: [PATCH 1/7] Refactor generators --- .../DefaultGeneratorsTests.cs | 93 ++++ .../GenericGenTests.cs | 6 - .../AutoGenConfigTests.fs | 9 +- .../ComplexGenericTest.fs | 112 ++++ src/Hedgehog.Experimental.Tests/GenTests.fs | 12 +- .../Hedgehog.Experimental.Tests.fsproj | 2 + src/Hedgehog.Experimental.Tests/OrTypeTest.fs | 29 + src/Hedgehog.Experimental/AutoGenConfig.fs | 13 + .../DefaultGenerators.fs | 126 +++++ src/Hedgehog.Experimental/GenX.fs | 516 +++++++++--------- .../GeneratorCollection.fs | 3 +- 11 files changed, 633 insertions(+), 288 deletions(-) create mode 100644 src/Hedgehog.Experimental.CSharp.Tests/DefaultGeneratorsTests.cs create mode 100644 src/Hedgehog.Experimental.Tests/ComplexGenericTest.fs create mode 100644 src/Hedgehog.Experimental.Tests/OrTypeTest.fs create mode 100644 src/Hedgehog.Experimental/DefaultGenerators.fs diff --git a/src/Hedgehog.Experimental.CSharp.Tests/DefaultGeneratorsTests.cs b/src/Hedgehog.Experimental.CSharp.Tests/DefaultGeneratorsTests.cs new file mode 100644 index 0000000..fdfb5ae --- /dev/null +++ b/src/Hedgehog.Experimental.CSharp.Tests/DefaultGeneratorsTests.cs @@ -0,0 +1,93 @@ +using System.Collections.Generic; +using System.Collections.Immutable; +using System.Linq; +using static Hedgehog.Linq.Property; +using Xunit; + +namespace Hedgehog.Linq.Tests; + +public sealed class DefaultGeneratorsTests +{ + private AutoGenConfig _config = GenX.defaults.WithCollectionRange(Range.FromValue(5)); + + [Fact] + public void ShouldGenerateImmutableSet() => + ForAll(GenX.autoWith>(_config)).Select(x => x.Count > 0).Check(); + + [Fact] + public void ShouldGenerateIImmutableSet() => + ForAll(GenX.autoWith>(_config)).Select(x => x.Count > 0).Check(); + + [Fact] + public void ShouldGenerateImmutableSortedSet() => + ForAll(GenX.autoWith>(_config)).Select(x => x.Count > 0).Check(); + + [Fact] + public void ShouldGenerateImmutableList() => + ForAll(GenX.autoWith>(_config)).Select(x => x.Count == 5).Check(); + + [Fact] + public void ShouldGenerateIImmutableList() => + ForAll(GenX.autoWith>(_config)).Select(x => x.Count == 5).Check(); + + [Fact] + public void ShouldGenerateImmutableArray() => + ForAll(GenX.autoWith>(_config)).Select(x => x.Length == 5).Check(); + + [Fact] + public void ShouldGenerateDictionary() => + ForAll(GenX.autoWith>(_config)).Select(x => x.Count > 0).Check(); + + [Fact] + public void ShouldGenerateIDictionary() => + ForAll(GenX.autoWith>(_config)).Select(x => x.Count > 0).Check(); + + [Fact] + public void ShouldGenerateList() => + ForAll(GenX.autoWith>(_config)).Select(x => x.Count == 5).Check(); + + // [Fact] + // public void ShouldGenerateIList() => + // ForAll(GenX.autoWith>(_config)).Select(x => x.Count == 5).Check(); + + [Fact] + public void StressTest() => + ForAll(GenX.autoWith>>>(_config)) + .Select(x => x.Count == 5 && x.All(inner => inner.Count == 5 && inner.All(innerMost => innerMost.Count == 5))) + .Check(); + + [Fact] + public void ShouldGenerateRecursiveTreeWithImmutableList() + { + // Tree node with ImmutableList of children - tests recursive generation with generic types + var config = GenX.defaults + .WithCollectionRange(Range.FromValue(2)) + .WithRecursionDepth(1); + + ForAll(GenX.autoWith>(config)) + .Select(tree => + { + // At depth 1, should have children + // At depth 2, children's children should be empty (recursion limit) + return tree.Children.Count == 2 && + tree.Children.All(child => child.Children.Count == 0); + }) + .Check(); + } +} + +// Recursive data structure for testing +public record TreeNode +{ + public T Value { get; init; } + public List> Children { get; init; } = []; + + public override string ToString() + { + if (Children.Count == 0) + return $"Node({Value})"; + + var childrenStr = string.Join(", ", Children.Select(c => c.ToString())); + return $"Node({Value}, [{childrenStr}])"; + } +} diff --git a/src/Hedgehog.Experimental.CSharp.Tests/GenericGenTests.cs b/src/Hedgehog.Experimental.CSharp.Tests/GenericGenTests.cs index de04e03..a6d8024 100644 --- a/src/Hedgehog.Experimental.CSharp.Tests/GenericGenTests.cs +++ b/src/Hedgehog.Experimental.CSharp.Tests/GenericGenTests.cs @@ -56,12 +56,6 @@ public static Gen> AlwaysJust(Gen gen) => public static Gen> AlwaysLeft(Gen genB, Gen genA) => genA.Select(Either (value) => new Either.Left(value)); - - // Generator for ImmutableList that uses AutoGenConfig's seqRange - public static Gen> ImmutableListGen(AutoGenConfig config, Gen genItem) => - genItem - .List(config.GetCollectionRange()) - .Select(ImmutableList.CreateRange); } public class GenericGenTests diff --git a/src/Hedgehog.Experimental.Tests/AutoGenConfigTests.fs b/src/Hedgehog.Experimental.Tests/AutoGenConfigTests.fs index e337629..9fbd1f6 100644 --- a/src/Hedgehog.Experimental.Tests/AutoGenConfigTests.fs +++ b/src/Hedgehog.Experimental.Tests/AutoGenConfigTests.fs @@ -1,5 +1,6 @@ module Hedgehog.Experimental.Tests.AutoGenConfigTests +open Hedgehog.Experimental open Xunit open Swensen.Unquote open Hedgehog @@ -78,11 +79,9 @@ let ``addGenerators supports methods with AutoGenConfig parameter``() = open System.Collections.Immutable type ImmutableListGenerators = - // Generic generator for ImmutableList that uses AutoGenConfig's seqRange - static member ImmutableListGen<'T>(config: AutoGenConfig, genItem: Gen<'T>) : Gen> = gen { - let! items = genItem |> Gen.list (AutoGenConfig.seqRange config) - return items |> ImmutableList.CreateRange - } + static member ImmutableListGen<'T>(config: AutoGenConfig, genItem: Gen<'T>) : Gen> = + genItem |> Gen.list (AutoGenConfig.seqRange config) |> Gen.map ImmutableList.CreateRange + [] let ``addGenerators supports generic methods with AutoGenConfig and Gen parameters``() = diff --git a/src/Hedgehog.Experimental.Tests/ComplexGenericTest.fs b/src/Hedgehog.Experimental.Tests/ComplexGenericTest.fs new file mode 100644 index 0000000..2867fb3 --- /dev/null +++ b/src/Hedgehog.Experimental.Tests/ComplexGenericTest.fs @@ -0,0 +1,112 @@ +module ComplexGenericTest + +open Xunit +open Swensen.Unquote +open Hedgehog + +// A type with complex generic parameter repetition: +type ComplexType<'A, 'B, 'C, 'D, 'E, 'F, 'G> = { + First: 'A + Second: 'B + Third: 'C + Fifth: 'E + Fourth: 'D + Sixth: 'F + Seventh: 'G +} + +type ComplexGenerators = + // Method with pattern: method has but type uses + static member Complex<'A, 'B, 'C, 'D>( + genA: Gen<'A>, + genC: Gen<'C>, + genB: Gen<'B>, + genD: Gen<'D>) : Gen> = + gen { + let! a = genA + let! b = genB + let! c = genC + let! d = genD + return { + First = a + Second = a + Third = b + Fourth = c + Fifth = a + Sixth = a + Seventh = d + } + } + +[] +let ``Should handle complex generic parameter repetition pattern``() = + let config = + GenX.defaults + |> AutoGenConfig.addGenerators + + // Generate ComplexType + // Method is Complex + let gen = GenX.autoWith> config + let sample = Gen.sample 0 1 gen |> Seq.head + + // Verify the structure is correct + test <@ sample.First = sample.Second @> // Both should be the same 'A value + test <@ sample.First = sample.Fifth @> // All 'A positions should be the same + test <@ sample.Second = sample.Sixth @> + test <@ sample.Third.GetType() = typeof @> + test <@ sample.Fourth.GetType() = typeof @> + test <@ sample.Seventh.GetType() = typeof @> + +// Better test with specific verifiable values +type VerifiableGenerators = + static member VerifiableComplex<'A, 'B, 'C, 'D>( + genA: Gen<'A>, + genC: Gen<'C>, + genB: Gen<'B>, + genD: Gen<'D>) : Gen> = + gen { + let! a = genA + let! b = genB + let! c = genC + let! d = genD + return { + First = a + Second = a + Third = b + Fourth = c + Fifth = a + Sixth = a + Seventh = d + } + } + +// Specific constant generators to verify correct parameter mapping +type SpecificGenerators = + static member Int() = Gen.constant 42 + static member String() = Gen.constant "test" + static member Bool() = Gen.constant true + static member Float() = Gen.constant 3.14 + +[] +let ``Should map parameters correctly with swapped parameter order``() = + let config = + GenX.defaults + |> AutoGenConfig.addGenerators + |> AutoGenConfig.addGenerators + + let gen = GenX.autoWith> config + let sample = Gen.sample 0 1 gen |> Seq.head + + // With swapped parameters (genA, genC, genB, genD), the mapping should be: + // 'A -> int (42) goes to positions: First, Second, Fifth, Sixth + // 'B -> string ("test") goes to position: Third + // 'C -> bool (true) goes to position: Fourth + // 'D -> float (3.14) goes to position: Seventh + + test <@ sample.First = 42 @> + test <@ sample.Second = 42 @> + test <@ sample.Third = "test" @> + test <@ sample.Fourth = true @> + test <@ sample.Fifth = 42 @> + test <@ sample.Sixth = 42 @> + test <@ sample.Seventh = 3.14 @> diff --git a/src/Hedgehog.Experimental.Tests/GenTests.fs b/src/Hedgehog.Experimental.Tests/GenTests.fs index 2541a98..c3ff007 100644 --- a/src/Hedgehog.Experimental.Tests/GenTests.fs +++ b/src/Hedgehog.Experimental.Tests/GenTests.fs @@ -549,7 +549,8 @@ and MutuallyRecursive2 = this.X |> List.choose (fun mc1 -> mc1.X) |> List.map (fun mc2 -> mc2.Depth + 1) - if depths.IsEmpty then 0 else List.max depths + if depths.IsEmpty then 1 // Having items in X means we recursed at least once + else List.max depths [] let ``auto with mutually recursive types does not cause stack overflow using default settings`` () = @@ -573,10 +574,11 @@ let ``auto with mutually recursive types respects max recursion depth`` () = let ``auto with mutually recursive types generates some values with max recursion depth`` () = checkWith 10 <| property { let! depth = Gen.int32 <| Range.linear 1 5 - let! xs1 = GenX.autoWith (GenX.defaults |> AutoGenConfig.setRecursionDepth depth |> AutoGenConfig.setSeqRange (Range.exponential 1 5)) - |> (Gen.list (Range.singleton 100)) - let! xs2 = GenX.autoWith (GenX.defaults |> AutoGenConfig.setRecursionDepth depth |> AutoGenConfig.setSeqRange (Range.exponential 1 5)) - |> (Gen.list (Range.singleton 100)) + let config = GenX.defaults |> AutoGenConfig.setRecursionDepth depth |> AutoGenConfig.setSeqRange (Range.exponential 1 5) + let! xs1 = GenX.autoWith config + |> (Gen.list (Range.singleton 10)) + let! xs2 = GenX.autoWith config + |> (Gen.list (Range.singleton 10)) test <@ xs1 |> List.exists (fun x -> x.Depth = depth) @> test <@ xs2 |> List.exists (fun x -> x.Depth = depth) @> } diff --git a/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj b/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj index 5181028..79025c1 100644 --- a/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj +++ b/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj @@ -7,6 +7,8 @@ + + diff --git a/src/Hedgehog.Experimental.Tests/OrTypeTest.fs b/src/Hedgehog.Experimental.Tests/OrTypeTest.fs new file mode 100644 index 0000000..c7d1289 --- /dev/null +++ b/src/Hedgehog.Experimental.Tests/OrTypeTest.fs @@ -0,0 +1,29 @@ +module OrTypeTest + +open Xunit +open Swensen.Unquote +open Hedgehog + +type Or<'A, 'B> = + | Left of 'A + | Right of 'B + +type OrGenerators = + static member OrSame<'A>(genA: Gen<'A>) : Gen> = + Gen.choice [ + genA |> Gen.map Left + genA |> Gen.map Right + ] + +[] +let ``Should generate Or with same type for both parameters``() = + let config = + GenX.defaults + |> AutoGenConfig.addGenerators + + let gen = GenX.autoWith> config + let sample = Gen.sample 0 1 gen |> Seq.head + + match sample with + | Left x -> test <@ x >= 0 @> // Just verify it's a valid int + | Right x -> test <@ x >= 0 @> diff --git a/src/Hedgehog.Experimental/AutoGenConfig.fs b/src/Hedgehog.Experimental/AutoGenConfig.fs index 86d2a96..2cdd45d 100644 --- a/src/Hedgehog.Experimental/AutoGenConfig.fs +++ b/src/Hedgehog.Experimental/AutoGenConfig.fs @@ -3,6 +3,13 @@ namespace Hedgehog open System open System.Reflection +/// Provides recursion depth information for the currently generated type. +/// Can be used by custom generators to respect recursion limits. +[] +type RecursionContext(canRecurse: bool) = + /// Indicates whether recursion is allowed for the current type being generated. + member _.CanRecurse = canRecurse + type AutoGenConfig = internal { seqRange: Range option recursionDepth: int option @@ -58,6 +65,11 @@ module AutoGenConfig = then Some t else None + let getRecursionContextType (t: Type) = + if t = typeof + then Some t + else None + let tryUnwrapParameters (methodInfo: MethodInfo) : Option = methodInfo.GetParameters() |> Array.fold (fun acc param -> @@ -66,6 +78,7 @@ module AutoGenConfig = | Some types -> getGenType param.ParameterType |> Option.orElseWith (fun () -> getAutoGenConfigType param.ParameterType) + |> Option.orElseWith (fun () -> getRecursionContextType param.ParameterType) |> Option.map (fun t -> Array.append types [| t |]) ) (Some [||]) diff --git a/src/Hedgehog.Experimental/DefaultGenerators.fs b/src/Hedgehog.Experimental/DefaultGenerators.fs new file mode 100644 index 0000000..68b7868 --- /dev/null +++ b/src/Hedgehog.Experimental/DefaultGenerators.fs @@ -0,0 +1,126 @@ +namespace Hedgehog.Experimental + +open System.Collections.Generic +open System.Linq +open Hedgehog +open System +open System.Collections.Immutable + +type DefaultGenerators = + static member Byte() : Gen = Gen.byte <| Range.exponentialBounded () + static member Int16() : Gen = Gen.int16 <| Range.exponentialBounded () + static member UInt16() : Gen = Gen.uint16 <| Range.exponentialBounded () + static member Int32() : Gen = Gen.int32 <| Range.exponentialBounded () + static member UInt32() : Gen = Gen.uint32 <| Range.exponentialBounded () + static member Int64() : Gen = Gen.int64 <| Range.exponentialBounded () + static member UInt64() : Gen = Gen.uint64 <| Range.exponentialBounded () + static member Single() : Gen = Gen.double (Range.exponentialFrom 0. (float Single.MinValue) (float Single.MaxValue)) |> Gen.map single + static member Double() : Gen = Gen.double <| Range.exponentialBounded () + static member Decimal() : Gen = Gen.double (Range.exponentialFrom 0. (float Decimal.MinValue) (float Decimal.MaxValue)) |> Gen.map decimal + static member Bool() : Gen = Gen.bool + static member Guid() : Gen = Gen.guid + static member Char() : Gen = Gen.latin1 + static member String() : Gen = Gen.string (Range.linear 0 50) Gen.latin1 + + static member DateTime() : Gen = DefaultGenerators.DateTimeOffset() |> Gen.map _.DateTime + static member DateTimeOffset() : Gen = + let dateTimeRange = + Range.exponentialFrom + (DateTime(2000, 1, 1)).Ticks + DateTime.MinValue.Ticks + DateTime.MaxValue.Ticks + |> Range.map DateTime + Gen.dateTime dateTimeRange |> Gen.map DateTimeOffset + + static member ImmutableList<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = + if recursionContext.CanRecurse then + valueGen |> Gen.list (AutoGenConfig.seqRange config) |> Gen.map ImmutableList.CreateRange + else + Gen.constant (ImmutableList<'a>.Empty) + + static member IImmutableList<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = + if recursionContext.CanRecurse then + DefaultGenerators.ImmutableList(config, recursionContext, valueGen) |> Gen.map (fun x -> x :> IImmutableList<'a>) + else + Gen.constant (ImmutableList<'a>.Empty :> IImmutableList<'a>) + + static member ImmutableArray<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = + if recursionContext.CanRecurse then + valueGen |> Gen.array (AutoGenConfig.seqRange config) |> Gen.map ImmutableArray.CreateRange + else + Gen.constant (ImmutableArray<'a>.Empty) + + static member ImmutableHashSet<'a when 'a : equality>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = + if recursionContext.CanRecurse then + valueGen |> Gen.list (AutoGenConfig.seqRange config) |> Gen.map ImmutableHashSet.CreateRange + else + Gen.constant (ImmutableHashSet<'a>.Empty) + + static member ImmutableSet<'a when 'a : comparison>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = + if recursionContext.CanRecurse then + valueGen |> Gen.list (AutoGenConfig.seqRange config) |> Gen.map ImmutableSortedSet.CreateRange + else + Gen.constant (ImmutableSortedSet<'a>.Empty) + + static member IImmutableSet<'a when 'a : equality>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = + if recursionContext.CanRecurse then + DefaultGenerators.ImmutableHashSet(config, recursionContext, valueGen) |> Gen.map (fun x -> x :> IImmutableSet<'a>) + else + Gen.constant (ImmutableHashSet<'a>.Empty :> IImmutableSet<'a>) + + static member Dictionary<'k, 'v when 'k: equality>(config: AutoGenConfig, recursionContext: RecursionContext, keyGen: Gen<'k>, valueGen: Gen<'v>): Gen> = + if recursionContext.CanRecurse then + gen { + let! kvps = Gen.zip keyGen valueGen |> Gen.list (AutoGenConfig.seqRange config) + return Dictionary(dict kvps) + } + else + Gen.constant (Dictionary<'k, 'v>()) + + static member IDictionary<'k, 'v when 'k: equality>(config: AutoGenConfig, recursionContext: RecursionContext, keyGen: Gen<'k>, valueGen: Gen<'v>): Gen> = + if recursionContext.CanRecurse then + gen { + let! kvps = Gen.zip keyGen valueGen |> Gen.list (AutoGenConfig.seqRange config) + return Dictionary(dict kvps) + } + else + Gen.constant (Dictionary<'k, 'v>() :> IDictionary<'k, 'v>) + + static member FSharpList<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen<'a list> = + if recursionContext.CanRecurse then + valueGen |> Gen.list (AutoGenConfig.seqRange config) + else + Gen.constant [] + + static member List<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = + DefaultGenerators.FSharpList(config, recursionContext, valueGen) |> Gen.map _.ToList() + + static member IList<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = + DefaultGenerators.FSharpList(config, recursionContext, valueGen) |> Gen.map _.ToList() + + static member Seq<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = + DefaultGenerators.FSharpList(config, recursionContext, valueGen) |> Gen.map Seq.ofList + + static member Option<'a>(recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen<'a option> = + if recursionContext.CanRecurse then Gen.option valueGen + else Gen.constant None + + static member Nullable<'a when 'a : struct and 'a : (new : unit -> 'a) and 'a :> ValueType>(recursionContext: RecursionContext, valueGen: Gen<'a>): Gen> = + if recursionContext.CanRecurse + then valueGen |> Gen.option |> Gen.map Option.toNullable + else Gen.constant (Nullable<'a>()) + + static member Set<'a when 'a : comparison>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = + if recursionContext.CanRecurse then + valueGen |> Gen.list (AutoGenConfig.seqRange config) |> Gen.map Set.ofList + else + Gen.constant Set.empty + + static member Map<'k, 'v when 'k : comparison>(config: AutoGenConfig, recursionContext: RecursionContext, keyGen: Gen<'k>, valueGen: Gen<'v>) : Gen> = + if recursionContext.CanRecurse then + gen { + let! kvps = Gen.zip keyGen valueGen |> Gen.list (AutoGenConfig.seqRange config) + return Map.ofList kvps + } + else + Gen.constant Map.empty<'k, 'v> diff --git a/src/Hedgehog.Experimental/GenX.fs b/src/Hedgehog.Experimental/GenX.fs index 9728b0c..0ff815d 100644 --- a/src/Hedgehog.Experimental/GenX.fs +++ b/src/Hedgehog.Experimental/GenX.fs @@ -1,6 +1,8 @@ namespace Hedgehog open System +open Hedgehog +open Hedgehog.Experimental open TypeShape.Core module GenX = @@ -327,29 +329,8 @@ module GenX = } let defaults = - let dateTimeRange = - Range.exponentialFrom - (DateTime(2000, 1, 1)).Ticks - DateTime.MinValue.Ticks - DateTime.MaxValue.Ticks - |> Range.map DateTime AutoGenConfig.defaults - |> AutoGenConfig.addGenerator (Gen.byte <| Range.exponentialBounded ()) - |> AutoGenConfig.addGenerator (Gen.int16 <| Range.exponentialBounded ()) - |> AutoGenConfig.addGenerator (Gen.uint16 <| Range.exponentialBounded ()) - |> AutoGenConfig.addGenerator (Gen.int32 <| Range.exponentialBounded ()) - |> AutoGenConfig.addGenerator (Gen.uint32 <| Range.exponentialBounded ()) - |> AutoGenConfig.addGenerator (Gen.int64 <| Range.exponentialBounded ()) - |> AutoGenConfig.addGenerator (Gen.uint64 <| Range.exponentialBounded ()) - |> AutoGenConfig.addGenerator (Gen.double (Range.exponentialFrom 0. (float Single.MinValue) (float Single.MaxValue)) |> Gen.map single) - |> AutoGenConfig.addGenerator (Gen.double <| Range.exponentialBounded ()) - |> AutoGenConfig.addGenerator (Gen.double (Range.exponentialFrom 0. (float Decimal.MinValue) (float Decimal.MaxValue)) |> Gen.map decimal) - |> AutoGenConfig.addGenerator Gen.bool - |> AutoGenConfig.addGenerator Gen.guid - |> AutoGenConfig.addGenerator Gen.latin1 - |> AutoGenConfig.addGenerator (Gen.string (Range.linear 0 50) Gen.latin1) - |> AutoGenConfig.addGenerator (Gen.dateTime dateTimeRange) - |> AutoGenConfig.addGenerator (Gen.dateTime dateTimeRange |> Gen.map DateTimeOffset) + |> AutoGenConfig.addGenerators |> AutoGenConfig.addGenerator uri module internal MultidimensionalArray = @@ -373,13 +354,6 @@ module GenX = loop 0 lengths array - module internal InternalGen = - let list<'a> canRecurse autoInner (config: AutoGenConfig) incrementRecursionDepth = - if canRecurse typeof<'a> then - autoInner config (incrementRecursionDepth typeof<'a>) |> Gen.list (AutoGenConfig.seqRange config) - else - Gen.constant ([]: 'a list) - let rec private autoInner<'a> (config : AutoGenConfig) (recursionDepths: Map) : Gen<'a> = let addGenMsg = "You can use 'GenX.defaults |> AutoGenConfig.addGenerator myGen |> GenX.autoWith' to generate types not inherently supported by GenX.auto." @@ -389,254 +363,254 @@ module GenX = if typeof<'a> = typeof then raise (NotSupportedException "Cannot auto-generate AutoGenConfig type. It should be provided as a parameter to generator methods.") - let genPoco (shape: ShapePoco<'a>) = - let bestCtor = - shape.Constructors - |> Seq.filter _.IsPublic - |> Seq.sortBy _.Arity - |> Seq.tryHead - - match bestCtor with - | None -> failwithf "Class %O lacks a public constructor" typeof<'a> - | Some ctor -> - ctor.Accept { - new IConstructorVisitor<'a, Gen<(unit -> 'a)>> with - member __.Visit<'CtorParams> (ctor : ShapeConstructor<'a, 'CtorParams>) = - autoInner config recursionDepths - |> Gen.map (fun args -> - let delayedCtor () = - try - ctor.Invoke args - with - | ex -> - ArgumentException(sprintf "Cannot construct %O with the generated argument(s): %O. %s" typeof<'a> args addGenMsg, ex) - |> raise - delayedCtor + let currentTypeRecursionLevel = + recursionDepths.TryFind typeof<'a>.AssemblyQualifiedName |> Option.defaultValue 0 + + // Check if we can recurse for the current type + // This tells the container generator whether it should generate elements or return empty + let canRecurseForElements = currentTypeRecursionLevel < AutoGenConfig.recursionDepth config + + if currentTypeRecursionLevel > AutoGenConfig.recursionDepth config then + Gen.delay (fun () -> + raise (InvalidOperationException( + sprintf "Recursion depth limit %d exceeded for type %s. " (AutoGenConfig.recursionDepth config) typeof<'a>.FullName + + "To fix this, add a RecursionContext parameter to your generator method and use recursionContext.CanRecurse to control recursion."))) + else + + // Increment recursion depth for this type before generating element types + let newRecursionDepths = recursionDepths.Add(typeof<'a>.AssemblyQualifiedName, currentTypeRecursionLevel + 1) + + // Check recursion depth at the beginning + let canRecurse = currentTypeRecursionLevel < AutoGenConfig.recursionDepth config + + + let genPoco (shape: ShapePoco<'a>) = + let bestCtor = + shape.Constructors + |> Seq.filter _.IsPublic + |> Seq.sortBy _.Arity + |> Seq.tryHead + + match bestCtor with + | None -> failwithf "Class %O lacks a public constructor" typeof<'a> + | Some ctor -> + ctor.Accept { + new IConstructorVisitor<'a, Gen<(unit -> 'a)>> with + member __.Visit<'CtorParams> (ctor : ShapeConstructor<'a, 'CtorParams>) = + autoInner config newRecursionDepths + |> Gen.map (fun args -> + let delayedCtor () = + try + ctor.Invoke args + with + | ex -> + ArgumentException(sprintf "Cannot construct %O with the generated argument(s): %O. %s" typeof<'a> args addGenMsg, ex) + |> raise + delayedCtor + ) + } + + + let wrap (t : Gen<'b>) = unbox> t + + let memberSetterGenerator (shape: IShapeMember<'DeclaringType>) = + shape.Accept { + new IMemberVisitor<'DeclaringType, Gen<'DeclaringType -> 'DeclaringType>> with + member _.Visit(shape: ShapeMember<'DeclaringType, 'MemberType>) = + autoInner<'MemberType> config newRecursionDepths + |> Gen.map (fun mtValue -> fun dt -> + try + shape.Set dt mtValue + with + | ex -> + ArgumentException(sprintf "Cannot set the %s property of %O to the generated value of %O. %s" shape.Label dt mtValue addGenMsg, ex) + |> raise ) } - let canRecurse (t: Type) = - match recursionDepths.TryFind t.AssemblyQualifiedName with - | Some x -> AutoGenConfig.recursionDepth config > x - | None -> AutoGenConfig.recursionDepth config > 0 - - let incrementRecursionDepth (t: Type) = - match recursionDepths.TryFind t.AssemblyQualifiedName with - | Some x -> recursionDepths.Add(t.AssemblyQualifiedName, x+1) - | None -> recursionDepths.Add(t.AssemblyQualifiedName, 1) - - let wrap (t : Gen<'b>) = - unbox> t - - let memberSetterGenerator (shape: IShapeMember<'DeclaringType>) = - shape.Accept { - new IMemberVisitor<'DeclaringType, Gen<'DeclaringType -> 'DeclaringType>> with - member _.Visit(shape: ShapeMember<'DeclaringType, 'MemberType>) = - autoInner<'MemberType> config recursionDepths - |> Gen.map (fun mtValue -> fun dt -> - try - shape.Set dt mtValue - with - | ex -> - ArgumentException(sprintf "Cannot set the %s property of %O to the generated value of %O. %s" shape.Label dt mtValue addGenMsg, ex) - |> raise - ) - } - - let typeShape = TypeShape.Create<'a> () - - // Check if there is a registered generator factory for a given requested generator. - // Fallback to the default heuristics if no factory is found. - match config.generators |> GeneratorCollection.tryFindFor typeof<'a> with - | Some (args, factory) -> - - let factoryArgs = - match typeShape with - | GenericShape (_, typeArgs) -> - // If the type is generic, we need to find the actual types to use - // which requires a bit of matching between all these generic 'a, 'b - // and their actual counterparts. - let argTypes = - args - |> Array.map (fun arg -> - if arg.IsGenericParameter then - typeArgs - |> Array.tryFind (fun p -> p.argTypeDefinition.Name = arg.Name) - |> Option.map _.argType - |> Option.defaultWith (fun _ -> raise unsupportedTypeException) - else arg) - {| genericTypes = typeArgs |> Array.map _.argType; argumentTypes = argTypes |} - - | _ -> {| genericTypes = Array.empty; argumentTypes = args |} - - - // and if the factory takes parameters, recurse and find generators for them - let targetArgs = - factoryArgs.argumentTypes - |> Array.map (fun t -> - // Check if this is AutoGenConfig type - if t = typeof then - box config - else - // Otherwise, generate a value for this type - let ts = TypeShape.Create(t) - ts.Accept { new ITypeVisitor with - member __.Visit<'b> () = autoInner<'b> config recursionDepths |> box - }) - - let resGen = factory factoryArgs.genericTypes targetArgs - resGen |> unbox> - - | None -> - match typeShape with - - | Shape.Unit -> wrap <| Gen.constant () - - | Shape.FSharpOption s -> - s.Element.Accept { - new ITypeVisitor> with - member __.Visit<'a> () = - if canRecurse typeof<'a> then - autoInner<'a> config (incrementRecursionDepth typeof<'a>) |> Gen.option |> wrap - else - Gen.constant (None: 'a option) |> wrap} - - | Shape.Array s -> - s.Element.Accept { - new ITypeVisitor> with - member __.Visit<'a> () = - if canRecurse typeof<'a> then - gen { - let! lengths = - config - |> AutoGenConfig.seqRange - |> Gen.integral - |> List.replicate s.Rank - |> ListGen.sequence - let elementCount = lengths |> List.fold (*) 1 - let! data = - autoInner<'a> config (incrementRecursionDepth typeof<'a>) - |> Gen.list (Range.singleton elementCount) - return MultidimensionalArray.createWithGivenEntries<'a> data lengths |> unbox - } - else - 0 - |> List.replicate s.Rank - |> MultidimensionalArray.createWithDefaultEntries<'a> - |> unbox - |> Gen.constant } - - | Shape.FSharpList s -> - s.Element.Accept { - new ITypeVisitor> with - member __.Visit<'a> () = - InternalGen.list<'a> canRecurse autoInner config incrementRecursionDepth |> wrap } - - | Shape.FSharpSet s -> - s.Accept { - new IFSharpSetVisitor> with - member __.Visit<'a when 'a : comparison> () = - autoInner<'a list> config recursionDepths - |> Gen.map Set.ofList - |> wrap} - - | Shape.FSharpMap s -> - s.Accept { - new IFSharpMapVisitor> with - member __.Visit<'k, 'v when 'k : comparison> () = - autoInner<('k * 'v) list> config recursionDepths - |> Gen.map Map.ofList - |> wrap } - - | Shape.Tuple (:? ShapeTuple<'a> as shape) -> - shape.Elements - |> Seq.toList - |> ListGen.traverse memberSetterGenerator - |> Gen.map (fun fs -> fs |> List.fold (|>) (shape.CreateUninitialized ())) - - | Shape.FSharpRecord (:? ShapeFSharpRecord<'a> as shape) -> - shape.Fields - |> Seq.toList - |> ListGen.traverse memberSetterGenerator - |> Gen.map (fun fs -> fs |> List.fold (|>) (shape.CreateUninitialized ())) - - | Shape.FSharpUnion (:? ShapeFSharpUnion<'a> as shape) -> - let cases = - shape.UnionCases - |> Array.map (fun uc -> - uc.Fields - |> Seq.toList - |> ListGen.traverse memberSetterGenerator) - gen { - let! caseIdx = Gen.integral <| Range.constant 0 (cases.Length - 1) - let! fs = cases[caseIdx] - return fs |> List.fold (|>) (shape.UnionCases[caseIdx].CreateUninitialized ()) - } - - | Shape.Enum _ -> - let values = Enum.GetValues(typeof<'a>) - gen { - let! index = Gen.integral <| Range.constant 0 (values.Length - 1) - return values.GetValue index |> unbox - } - - | Shape.Nullable s -> - s.Accept { - new INullableVisitor> with - member __.Visit<'a when 'a : (new : unit -> 'a) and 'a :> ValueType and 'a : struct> () = - if canRecurse typeof<'a> then - autoInner<'a> config (incrementRecursionDepth typeof<'a>) - |> Gen.option - |> Gen.map Option.toNullable - |> wrap + let typeShape = TypeShape.Create<'a> () + + // Check if there is a registered generator factory for a given requested generator. + // Fallback to the default heuristics if no factory is found. + match config.generators |> GeneratorCollection.tryFindFor typeof<'a> with + | Some (registeredType, (args, factory)) -> + + let factoryArgs = + match typeShape with + | GenericShape (_, typeArgs) -> + // If the type is generic, we need to find the actual types to use. + // We match generic parameters by their GenericParameterPosition property, + // which tells us their position in the method's generic parameter declaration. + + // The registeredType contains the method's generic parameters as they appear in the return type. + // For example: + // - Id<'a> has 'a at position 0 in the type + // - Or<'A, 'A> has 'A at positions 0 and 1 in the type (but GenericParameterPosition=0 for both) + // - Foo<'A, 'A, 'B, 'C> has 'A at 0,1 (GenericParameterPosition=0), 'B at 2 (GenericParameterPosition=1), 'C at 3 (GenericParameterPosition=2) + + let registeredGenArgs = + if registeredType.IsGenericType + then registeredType.GetGenericArguments() + else Array.empty + + // Build a mapping from method generic parameter position to concrete type + // by finding where each method parameter first appears in the registered type + let methodGenParamCount = + registeredGenArgs + |> Array.filter _.IsGenericParameter + |> Array.map _.GenericParameterPosition + |> Array.distinct + |> Array.length + + let genericTypes = Array.zeroCreate methodGenParamCount + + // For each position in registeredType, if it's a generic parameter, + // map it to the corresponding concrete type from typeArgs + for i = 0 to registeredGenArgs.Length - 1 do + let regArg = registeredGenArgs.[i] + if regArg.IsGenericParameter then + let paramPosition = regArg.GenericParameterPosition + // Only set it if we haven't seen this parameter position before (use first occurrence) + if genericTypes[paramPosition] = null + then genericTypes[paramPosition] <- box typeArgs.[i].argType + + let genericTypes = genericTypes |> Array.map unbox + + // Build argumentTypes: substitute generic parameters with concrete types + let argTypes = + args + |> Array.map (fun arg -> + if arg.IsGenericParameter then + // Find where this parameter first appears in the registered type + let paramPosition = arg.GenericParameterPosition + let firstOccurrenceIndex = + registeredGenArgs + |> Array.findIndex (fun t -> t.IsGenericParameter && t.GenericParameterPosition = paramPosition) + typeArgs[firstOccurrenceIndex].argType + else arg) + + {| genericTypes = genericTypes; argumentTypes = argTypes |} + + | _ -> {| genericTypes = Array.empty; argumentTypes = args |} + + // and if the factory takes parameters, recurse and find generators for them + let targetArgs = + factoryArgs.argumentTypes + |> Array.map (fun t -> + // Check if this is AutoGenConfig type + if t = typeof then + box config + // Check if this is RecursionContext type + elif t = typeof then + box (RecursionContext(canRecurseForElements)) + else + // Otherwise, generate a value for this type + let ts = TypeShape.Create(t) + ts.Accept { new ITypeVisitor with + member __.Visit<'b> () = autoInner<'b> config newRecursionDepths |> box + }) + + let resGen = factory factoryArgs.genericTypes targetArgs + resGen |> unbox> + + | None -> + match typeShape with + + | Shape.Unit -> wrap <| Gen.constant () + + | Shape.Array s -> + s.Element.Accept { + new ITypeVisitor> with + member __.Visit<'a> () = + if canRecurse then + gen { + let! lengths = + config + |> AutoGenConfig.seqRange + |> Gen.integral + |> List.replicate s.Rank + |> ListGen.sequence + let elementCount = lengths |> List.fold (*) 1 + let! data = autoInner<'a> config newRecursionDepths |> Gen.list (Range.singleton elementCount) + return MultidimensionalArray.createWithGivenEntries<'a> data lengths |> unbox + } else - Nullable () |> unbox |> Gen.constant - } - - | Shape.Collection s -> - s.Accept { - new ICollectionVisitor> with - member _.Visit<'collection, 'element when 'collection :> System.Collections.Generic.ICollection<'element>> () = - match typeShape with - | Shape.Poco (:? ShapePoco<'a> as shape) -> - gen { - let! collectionCtor = genPoco shape - let! elements = InternalGen.list canRecurse autoInner config incrementRecursionDepth - let collection = collectionCtor () |> unbox> - for e in elements do - collection.Add e - return collection |> unbox<'a> - } - | _ -> raise unsupportedTypeException + 0 + |> List.replicate s.Rank + |> MultidimensionalArray.createWithDefaultEntries<'a> + |> unbox + |> Gen.constant } + + | Shape.Tuple (:? ShapeTuple<'a> as shape) -> + shape.Elements + |> Seq.toList + |> ListGen.traverse memberSetterGenerator + |> Gen.map (fun fs -> fs |> List.fold (|>) (shape.CreateUninitialized ())) + + | Shape.FSharpRecord (:? ShapeFSharpRecord<'a> as shape) -> + shape.Fields + |> Seq.toList + |> ListGen.traverse memberSetterGenerator + |> Gen.map (fun fs -> fs |> List.fold (|>) (shape.CreateUninitialized ())) + + | Shape.FSharpUnion (:? ShapeFSharpUnion<'a> as shape) -> + let cases = + shape.UnionCases + |> Array.map (fun uc -> + uc.Fields + |> Seq.toList + |> ListGen.traverse memberSetterGenerator) + gen { + let! caseIdx = Gen.integral <| Range.constant 0 (cases.Length - 1) + let! fs = cases[caseIdx] + return fs |> List.fold (|>) (shape.UnionCases[caseIdx].CreateUninitialized ()) + } + + | Shape.Enum _ -> + let values = Enum.GetValues(typeof<'a>) + gen { + let! index = Gen.integral <| Range.constant 0 (values.Length - 1) + return values.GetValue index |> unbox } - | Shape.CliMutable (:? ShapeCliMutable<'a> as shape) -> - let getDepth (sm: IShapeMember<_>) = - let rec loop (t: Type) depth = - if t = null - then depth - else loop t.BaseType (depth + 1) - loop sm.MemberInfo.DeclaringType 0 - shape.Properties - |> Array.toList - |> List.groupBy (fun p -> p.MemberInfo.Name) - |> List.map (snd >> function - | [p] -> p - | ps -> ps |> List.sortByDescending getDepth |> List.head) - |> ListGen.traverse memberSetterGenerator - |> Gen.map (fun fs -> fs |> List.fold (|>) (shape.CreateUninitialized ())) - - | Shape.Poco (:? ShapePoco<'a> as shape) -> genPoco shape |> Gen.map (fun x -> x ()) - - | Shape.Enumerable s -> - s.Element.Accept { - new ITypeVisitor> with - member __.Visit<'a> () = - InternalGen.list<'a> canRecurse autoInner config incrementRecursionDepth - |> Gen.map Seq.ofList - |> wrap } - - | _ -> raise unsupportedTypeException + | Shape.Collection s -> + s.Accept { + new ICollectionVisitor> with + member _.Visit<'collection, 'element when 'collection :> System.Collections.Generic.ICollection<'element>> () = + match typeShape with + | Shape.Poco (:? ShapePoco<'a> as shape) -> + gen { + let! collectionCtor = genPoco shape + let! elements = + if canRecurse + then autoInner<'element> config newRecursionDepths |> Gen.list (AutoGenConfig.seqRange config) + else Gen.constant [] + let collection = collectionCtor () |> unbox> + for e in elements do collection.Add e + return collection |> unbox<'a> + } + | _ -> raise unsupportedTypeException + } + + | Shape.CliMutable (:? ShapeCliMutable<'a> as shape) -> + let getDepth (sm: IShapeMember<_>) = + let rec loop (t: Type) depth = + if t = null + then depth + else loop t.BaseType (depth + 1) + loop sm.MemberInfo.DeclaringType 0 + shape.Properties + |> Array.toList + |> List.groupBy _.MemberInfo.Name + |> List.map (snd >> function + | [p] -> p + | ps -> ps |> List.sortByDescending getDepth |> List.head) + |> ListGen.traverse memberSetterGenerator + |> Gen.map (fun fs -> fs |> List.fold (|>) (shape.CreateUninitialized ())) + + | Shape.Poco (:? ShapePoco<'a> as shape) -> genPoco shape |> Gen.map (fun x -> x ()) + + | _ -> raise unsupportedTypeException let auto<'a> = autoInner<'a> defaults Map.empty diff --git a/src/Hedgehog.Experimental/GeneratorCollection.fs b/src/Hedgehog.Experimental/GeneratorCollection.fs index 1007d02..7789147 100644 --- a/src/Hedgehog.Experimental/GeneratorCollection.fs +++ b/src/Hedgehog.Experimental/GeneratorCollection.fs @@ -34,7 +34,8 @@ module internal GeneratorCollection = // Find a generator that can satisfy the given requited type. // It also takes care of finding 'generic' generators (like Either<'a, 'b>) // to satisfy specific types (like Either). + // Returns the registered target type along with the args and factory. let tryFindFor (targetType: Type) = unwrap >> Seq.tryFind (fun (KeyValue (t, _)) -> t |> TypeUtils.satisfies targetType) - >> Option.map (fun (KeyValue (_, v)) -> v) + >> Option.map (fun (KeyValue (k, v)) -> (k, v)) From d1a081d6453963c84785d576d0a48e34d414b28d Mon Sep 17 00:00:00 2001 From: Alexey Raga Date: Fri, 14 Nov 2025 23:35:01 +1100 Subject: [PATCH 2/7] Tests for weird cases --- README.md | 28 ++++--- .../GenericGenTests.cs | 20 ++++- .../Hedgehog.Experimental.Tests.fsproj | 2 +- src/Hedgehog.Experimental.Tests/OrTypeTest.fs | 29 -------- .../TypeParamMappingTests.fs | 73 +++++++++++++++++++ .../DefaultGenerators.fs | 2 +- .../Hedgehog.Experimental.fsproj | 1 + 7 files changed, 109 insertions(+), 46 deletions(-) delete mode 100644 src/Hedgehog.Experimental.Tests/OrTypeTest.fs create mode 100644 src/Hedgehog.Experimental.Tests/TypeParamMappingTests.fs diff --git a/README.md b/README.md index 61bee53..def3446 100644 --- a/README.md +++ b/README.md @@ -208,23 +208,29 @@ let! myVal = **Register generators for generic types in `AutoGenConfig`:** ```f# -// An example of a generic type -type Maybe<'a> = Just of 'a | Nothing - // a type containing generators for generic types // methods should return Gen<_> and are allowed to take Gen<_> and AutoGenConfig as parameters type GenericGenerators = - // Generator for Maybe<'a> - static member MaybeGen<'a>(valueGen : Gen<'a>) : Gen> = - Gen.frequency [ - 1, Gen.constant None - 8, valueGen - ] + + // Generate generic types + static member MyGenericType<'a>(valueGen : Gen<'a>) : Gen> = + valueGen | Gen.map (fun x -> MyGenericType(x)) -let! myVal = + // Generate generic types with recursion support and access to AutoGenConfig + static member ImmutableList<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = + if recursionContext.CanRecurse then + valueGen |> Gen.list (AutoGenConfig.seqRange config) |> Gen.map ImmutableList.CreateRange + else + Gen.constant ImmutableList<'a>.Empty + +// register the generic generators in AutoGenConfig +let config = GenX.defaults |> AutoGenConfig.addGenerators - |> GenX.autoWith> + +// use the config to auto-generate types containing generic types +let! myGenericType = GenX.autoWith config +let! myImmutableList = GenX.autoWith> config ``` If you’re not happy with the auto-gen defaults, you can of course create your own generator that calls `GenX.autoWith` with your chosen config and use that everywhere. diff --git a/src/Hedgehog.Experimental.CSharp.Tests/GenericGenTests.cs b/src/Hedgehog.Experimental.CSharp.Tests/GenericGenTests.cs index a6d8024..745537f 100644 --- a/src/Hedgehog.Experimental.CSharp.Tests/GenericGenTests.cs +++ b/src/Hedgehog.Experimental.CSharp.Tests/GenericGenTests.cs @@ -34,6 +34,8 @@ public sealed class OuterClass public Maybe Value { get; set; } } +public sealed record RecursiveRec(Maybe Value); + public sealed class GenericTestGenerators { public static Gen Guid() => @@ -51,8 +53,10 @@ public static Gen UuidGen() => public static Gen NameGen(Gen gen) => gen.Select(value => new Name("Name: " + value)); - public static Gen> AlwaysJust(Gen gen) => - gen.Select(Maybe (value) => new Maybe.Just(value)); + public static Gen> AlwaysJust(AutoGenConfig config, RecursionContext recCtx, Gen gen) => + recCtx.CanRecurse + ? gen.Select(Maybe (value) => new Maybe.Just(value)) + : Gen.FromValue>(new Maybe.Nothing()); public static Gen> AlwaysLeft(Gen genB, Gen genA) => genA.Select(Either (value) => new Either.Left(value)); @@ -63,6 +67,16 @@ public class GenericGenTests private static bool IsCustomGuid(Guid guid) => new Span(guid.ToByteArray(), 0, 4).ToArray().All(b => b == 0); + [Fact] + public void ShouldGenerateRecursiveRecords() + { + var config = GenX.defaults.WithGenerators(); + var prop = from x in ForAll(GenX.autoWith(config)) + select x != null; + + prop.Check(); + } + [Fact] public void ShouldGenerateValueWithPhantomGenericType_Id() { @@ -145,8 +159,6 @@ public void ShouldGenerateImmutableListUsingAutoGenConfigParameter() .WithCollectionRange(Range.FromValue(7)) .WithGenerators(); - // The ImmutableListGen will be called with config and Gen - // This demonstrates that generators can receive AutoGenConfig to access configuration var prop = from x in ForAll(GenX.autoWith>(config)) select x.Count == 7; diff --git a/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj b/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj index 79025c1..da9bfbb 100644 --- a/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj +++ b/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj @@ -8,7 +8,7 @@ - + diff --git a/src/Hedgehog.Experimental.Tests/OrTypeTest.fs b/src/Hedgehog.Experimental.Tests/OrTypeTest.fs deleted file mode 100644 index c7d1289..0000000 --- a/src/Hedgehog.Experimental.Tests/OrTypeTest.fs +++ /dev/null @@ -1,29 +0,0 @@ -module OrTypeTest - -open Xunit -open Swensen.Unquote -open Hedgehog - -type Or<'A, 'B> = - | Left of 'A - | Right of 'B - -type OrGenerators = - static member OrSame<'A>(genA: Gen<'A>) : Gen> = - Gen.choice [ - genA |> Gen.map Left - genA |> Gen.map Right - ] - -[] -let ``Should generate Or with same type for both parameters``() = - let config = - GenX.defaults - |> AutoGenConfig.addGenerators - - let gen = GenX.autoWith> config - let sample = Gen.sample 0 1 gen |> Seq.head - - match sample with - | Left x -> test <@ x >= 0 @> // Just verify it's a valid int - | Right x -> test <@ x >= 0 @> diff --git a/src/Hedgehog.Experimental.Tests/TypeParamMappingTests.fs b/src/Hedgehog.Experimental.Tests/TypeParamMappingTests.fs new file mode 100644 index 0000000..7e1d52a --- /dev/null +++ b/src/Hedgehog.Experimental.Tests/TypeParamMappingTests.fs @@ -0,0 +1,73 @@ +module TypeParamMappingTests + +open Xunit +open Swensen.Unquote +open Hedgehog + +type Or<'A, 'B> = Left of 'A | Right of 'B + +type And<'A> = And of 'A * 'A + +type OutOfOrder<'a, 'b, 'c> = OutOfOrder of 'c * 'a * 'b * 'a + +type Generators = + static member OrSame<'A>(genA: Gen<'A>) : Gen> = + Gen.choice [ + genA |> Gen.map Left + genA |> Gen.map Right + ] + + static member AndSame<'A>(one: Gen<'A>, two: Gen<'A>) : Gen> = + Gen.map2 (fun x y -> And(x, y)) one two + + static member OutOfOrderGen<'a, 'b, 'c>(genB: Gen<'b>, genC: Gen<'c>, genA: Gen<'a>, genA2: Gen<'a>) : Gen> = + Gen.map4 (fun a a1 b c -> OutOfOrder(c, a, b, a1)) genA genA2 genB genC + +[] +let ``Should generate Or with same type for both parameters``() = + property { + let! i = GenX.auto + let config = + GenX.defaults + |> AutoGenConfig.addGenerator (Gen.constant i) + |> AutoGenConfig.addGenerators + + let! result = GenX.autoWith> config + + match result with + | Left x -> test <@ x = i @> + | Right x -> test <@ x = i @> + } + |> Property.check + +[] +let ``Should generate And with same type for both parameters``() = + property { + let! i = GenX.auto + let config = + GenX.defaults + |> AutoGenConfig.addGenerator (Gen.constant i) + |> AutoGenConfig.addGenerators + + let! result = GenX.autoWith> config + + test <@ result = And(i, i) @> + } + |> Property.check + +[] +let ``Should generate OutOfOrder with parameters in different order``() = + property { + let! i, s, f = GenX.auto + let config = + GenX.defaults + |> AutoGenConfig.addGenerator (Gen.constant i) + |> AutoGenConfig.addGenerator (Gen.constant s) + |> AutoGenConfig.addGenerator (Gen.constant f) + |> AutoGenConfig.addGenerators + + let! result = GenX.autoWith> config + + test <@ result = OutOfOrder(f, i, s, i) @> + } + |> Property.check diff --git a/src/Hedgehog.Experimental/DefaultGenerators.fs b/src/Hedgehog.Experimental/DefaultGenerators.fs index 68b7868..ecb4028 100644 --- a/src/Hedgehog.Experimental/DefaultGenerators.fs +++ b/src/Hedgehog.Experimental/DefaultGenerators.fs @@ -36,7 +36,7 @@ type DefaultGenerators = if recursionContext.CanRecurse then valueGen |> Gen.list (AutoGenConfig.seqRange config) |> Gen.map ImmutableList.CreateRange else - Gen.constant (ImmutableList<'a>.Empty) + Gen.constant ImmutableList<'a>.Empty static member IImmutableList<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = if recursionContext.CanRecurse then diff --git a/src/Hedgehog.Experimental/Hedgehog.Experimental.fsproj b/src/Hedgehog.Experimental/Hedgehog.Experimental.fsproj index 3b42d34..a139c2b 100644 --- a/src/Hedgehog.Experimental/Hedgehog.Experimental.fsproj +++ b/src/Hedgehog.Experimental/Hedgehog.Experimental.fsproj @@ -26,6 +26,7 @@ + <_Parameter1>Hedgehog.Experimental.Tests From f5e9503fc7dabcdbd1ea7c53436689de99f87bfb Mon Sep 17 00:00:00 2001 From: Alexey Raga Date: Sat, 15 Nov 2025 00:04:01 +1100 Subject: [PATCH 3/7] Improve readability for autoInner --- src/Hedgehog.Experimental.Tests/GenTests.fs | 3 +- src/Hedgehog.Experimental/GenX.fs | 210 +++++++++--------- .../Hedgehog.Experimental.fsproj | 1 + .../MultidimensionalArray.fs | 23 ++ 4 files changed, 127 insertions(+), 110 deletions(-) create mode 100644 src/Hedgehog.Experimental/MultidimensionalArray.fs diff --git a/src/Hedgehog.Experimental.Tests/GenTests.fs b/src/Hedgehog.Experimental.Tests/GenTests.fs index c3ff007..7b4a357 100644 --- a/src/Hedgehog.Experimental.Tests/GenTests.fs +++ b/src/Hedgehog.Experimental.Tests/GenTests.fs @@ -1,6 +1,7 @@ module Hedgehog.Experimental.Tests.GenTests open System +open Hedgehog.Experimental open Xunit open Swensen.Unquote open Hedgehog @@ -928,7 +929,7 @@ let ``MultidimensionalArray.createWithGivenEntries works for 2x2`` () = let lengths = [ 2; 2 ] let array : int [,] = - GenX.MultidimensionalArray.createWithGivenEntries data lengths + MultidimensionalArray.createWithGivenEntries data lengths |> unbox <@ diff --git a/src/Hedgehog.Experimental/GenX.fs b/src/Hedgehog.Experimental/GenX.fs index 0ff815d..8e32339 100644 --- a/src/Hedgehog.Experimental/GenX.fs +++ b/src/Hedgehog.Experimental/GenX.fs @@ -333,56 +333,106 @@ module GenX = |> AutoGenConfig.addGenerators |> AutoGenConfig.addGenerator uri - module internal MultidimensionalArray = - - let createWithDefaultEntries<'a> (lengths: int list) = - let array = lengths |> Array.ofList - Array.CreateInstance (typeof<'a>, array) - - let createWithGivenEntries<'a> (data: 'a seq) lengths = - let array = createWithDefaultEntries<'a> lengths - let currentIndices = Array.create (List.length lengths) 0 - use en = data.GetEnumerator () - let rec loop currentDimensionIndex = function - | [] -> - en.MoveNext () |> ignore - array.SetValue(en.Current, currentIndices) - | currentLength :: remainingLengths -> - for i in 0..currentLength - 1 do - currentIndices[currentDimensionIndex] <- i - loop (currentDimensionIndex + 1) remainingLengths - loop 0 lengths - array - - let rec private autoInner<'a> (config : AutoGenConfig) (recursionDepths: Map) : Gen<'a> = + module private AutoGenHelpers = let addGenMsg = "You can use 'GenX.defaults |> AutoGenConfig.addGenerator myGen |> GenX.autoWith' to generate types not inherently supported by GenX.auto." - let unsupportedTypeException = NotSupportedException (sprintf "Unable to auto-generate %s. %s" typeof<'a>.FullName addGenMsg) + + let unsupportedTypeException<'a> () = + NotSupportedException (sprintf "Unable to auto-generate %s. %s" typeof<'a>.FullName addGenMsg) + + type RecursionState = { + CurrentLevel: int + CanRecurse: bool + Depths: Map + } + + let checkRecursionDepth<'a> (config: AutoGenConfig) (recursionDepths: Map) = + let typeName = typeof<'a>.AssemblyQualifiedName + let currentLevel = recursionDepths.TryFind typeName |> Option.defaultValue 0 + let maxDepth = AutoGenConfig.recursionDepth config + + if (currentLevel > maxDepth) then None + else Some + { + CurrentLevel = currentLevel + CanRecurse = currentLevel < maxDepth + Depths = recursionDepths.Add(typeName, currentLevel + 1) + } + + let resolveGenericTypeArgs (registeredType: Type) (typeArgs: GenericArgument array) (args: Type array) = + // If the type is generic, we need to find the actual types to use. + // We match generic parameters by their GenericParameterPosition property, + // which tells us their position in the method's generic parameter declaration. + + // The registeredType contains the method's generic parameters as they appear in the return type. + // For example: + // - Id<'a> has 'a at position 0 in the type + // - Or<'A, 'A> has 'A at positions 0 and 1 in the type (but GenericParameterPosition=0 for both) + // - Foo<'A, 'A, 'B, 'C> has 'A at 0,1 (GenericParameterPosition=0), 'B at 2 (GenericParameterPosition=1), 'C at 3 (GenericParameterPosition=2) + + let registeredGenArgs = + if registeredType.IsGenericType + then registeredType.GetGenericArguments() + else Array.empty + + // Build a mapping from method generic parameter position to concrete type + // by finding where each method parameter first appears in the registered type + let methodGenParamCount = + registeredGenArgs + |> Array.filter _.IsGenericParameter + |> Array.map _.GenericParameterPosition + |> Array.distinct + |> Array.length + + let genericTypes = Array.zeroCreate methodGenParamCount + + // For each position in registeredType, if it's a generic parameter, + // map it to the corresponding concrete type from typeArgs + for i = 0 to registeredGenArgs.Length - 1 do + let regArg = registeredGenArgs[i] + if regArg.IsGenericParameter then + let paramPosition = regArg.GenericParameterPosition + // Only set it if we haven't seen this parameter position before (use first occurrence) + if genericTypes[paramPosition] = null + then genericTypes[paramPosition] <- box typeArgs[i].argType + + let genericTypes = genericTypes |> Array.map unbox + + // Build argumentTypes: substitute generic parameters with concrete types + let argTypes = + args + |> Array.map (fun arg -> + if arg.IsGenericParameter then + // Find where this parameter first appears in the registered type + let paramPosition = arg.GenericParameterPosition + let firstOccurrenceIndex = + registeredGenArgs + |> Array.findIndex (fun t -> t.IsGenericParameter && t.GenericParameterPosition = paramPosition) + typeArgs[firstOccurrenceIndex].argType + else arg) + + {| genericTypes = genericTypes; argumentTypes = argTypes |} + + let prepareFactoryArgTypes (typeShape: TypeShape<'a>) (registeredType: Type) (args: Type array) = + match typeShape with + | GenericShape (_, typeArgs) -> + resolveGenericTypeArgs registeredType typeArgs args + | _ -> {| genericTypes = Array.empty; argumentTypes = args |} + + let rec private autoInner<'a> (config : AutoGenConfig) (recursionDepths: Map) : Gen<'a> = // Prevent auto-generating AutoGenConfig itself - it should only be passed as a parameter if typeof<'a> = typeof then raise (NotSupportedException "Cannot auto-generate AutoGenConfig type. It should be provided as a parameter to generator methods.") - let currentTypeRecursionLevel = - recursionDepths.TryFind typeof<'a>.AssemblyQualifiedName |> Option.defaultValue 0 - - // Check if we can recurse for the current type - // This tells the container generator whether it should generate elements or return empty - let canRecurseForElements = currentTypeRecursionLevel < AutoGenConfig.recursionDepth config - - if currentTypeRecursionLevel > AutoGenConfig.recursionDepth config then + match AutoGenHelpers.checkRecursionDepth<'a> config recursionDepths with + | None -> Gen.delay (fun () -> raise (InvalidOperationException( sprintf "Recursion depth limit %d exceeded for type %s. " (AutoGenConfig.recursionDepth config) typeof<'a>.FullName + "To fix this, add a RecursionContext parameter to your generator method and use recursionContext.CanRecurse to control recursion."))) - else - - // Increment recursion depth for this type before generating element types - let newRecursionDepths = recursionDepths.Add(typeof<'a>.AssemblyQualifiedName, currentTypeRecursionLevel + 1) - - // Check recursion depth at the beginning - let canRecurse = currentTypeRecursionLevel < AutoGenConfig.recursionDepth config + | Some recursionState -> let genPoco (shape: ShapePoco<'a>) = let bestCtor = @@ -397,33 +447,32 @@ module GenX = ctor.Accept { new IConstructorVisitor<'a, Gen<(unit -> 'a)>> with member __.Visit<'CtorParams> (ctor : ShapeConstructor<'a, 'CtorParams>) = - autoInner config newRecursionDepths + autoInner config recursionState.Depths |> Gen.map (fun args -> let delayedCtor () = try ctor.Invoke args with | ex -> - ArgumentException(sprintf "Cannot construct %O with the generated argument(s): %O. %s" typeof<'a> args addGenMsg, ex) + ArgumentException(sprintf "Cannot construct %O with the generated argument(s): %O. %s" typeof<'a> args AutoGenHelpers.addGenMsg, ex) |> raise delayedCtor ) } - let wrap (t : Gen<'b>) = unbox> t let memberSetterGenerator (shape: IShapeMember<'DeclaringType>) = shape.Accept { new IMemberVisitor<'DeclaringType, Gen<'DeclaringType -> 'DeclaringType>> with member _.Visit(shape: ShapeMember<'DeclaringType, 'MemberType>) = - autoInner<'MemberType> config newRecursionDepths + autoInner<'MemberType> config recursionState.Depths |> Gen.map (fun mtValue -> fun dt -> try shape.Set dt mtValue with | ex -> - ArgumentException(sprintf "Cannot set the %s property of %O to the generated value of %O. %s" shape.Label dt mtValue addGenMsg, ex) + ArgumentException(sprintf "Cannot set the %s property of %O to the generated value of %O. %s" shape.Label dt mtValue AutoGenHelpers.addGenMsg, ex) |> raise ) } @@ -434,64 +483,7 @@ module GenX = // Fallback to the default heuristics if no factory is found. match config.generators |> GeneratorCollection.tryFindFor typeof<'a> with | Some (registeredType, (args, factory)) -> - - let factoryArgs = - match typeShape with - | GenericShape (_, typeArgs) -> - // If the type is generic, we need to find the actual types to use. - // We match generic parameters by their GenericParameterPosition property, - // which tells us their position in the method's generic parameter declaration. - - // The registeredType contains the method's generic parameters as they appear in the return type. - // For example: - // - Id<'a> has 'a at position 0 in the type - // - Or<'A, 'A> has 'A at positions 0 and 1 in the type (but GenericParameterPosition=0 for both) - // - Foo<'A, 'A, 'B, 'C> has 'A at 0,1 (GenericParameterPosition=0), 'B at 2 (GenericParameterPosition=1), 'C at 3 (GenericParameterPosition=2) - - let registeredGenArgs = - if registeredType.IsGenericType - then registeredType.GetGenericArguments() - else Array.empty - - // Build a mapping from method generic parameter position to concrete type - // by finding where each method parameter first appears in the registered type - let methodGenParamCount = - registeredGenArgs - |> Array.filter _.IsGenericParameter - |> Array.map _.GenericParameterPosition - |> Array.distinct - |> Array.length - - let genericTypes = Array.zeroCreate methodGenParamCount - - // For each position in registeredType, if it's a generic parameter, - // map it to the corresponding concrete type from typeArgs - for i = 0 to registeredGenArgs.Length - 1 do - let regArg = registeredGenArgs.[i] - if regArg.IsGenericParameter then - let paramPosition = regArg.GenericParameterPosition - // Only set it if we haven't seen this parameter position before (use first occurrence) - if genericTypes[paramPosition] = null - then genericTypes[paramPosition] <- box typeArgs.[i].argType - - let genericTypes = genericTypes |> Array.map unbox - - // Build argumentTypes: substitute generic parameters with concrete types - let argTypes = - args - |> Array.map (fun arg -> - if arg.IsGenericParameter then - // Find where this parameter first appears in the registered type - let paramPosition = arg.GenericParameterPosition - let firstOccurrenceIndex = - registeredGenArgs - |> Array.findIndex (fun t -> t.IsGenericParameter && t.GenericParameterPosition = paramPosition) - typeArgs[firstOccurrenceIndex].argType - else arg) - - {| genericTypes = genericTypes; argumentTypes = argTypes |} - - | _ -> {| genericTypes = Array.empty; argumentTypes = args |} + let factoryArgs = AutoGenHelpers.prepareFactoryArgTypes typeShape registeredType args // and if the factory takes parameters, recurse and find generators for them let targetArgs = @@ -502,12 +494,12 @@ module GenX = box config // Check if this is RecursionContext type elif t = typeof then - box (RecursionContext(canRecurseForElements)) + box (RecursionContext(recursionState.CanRecurse)) else // Otherwise, generate a value for this type let ts = TypeShape.Create(t) ts.Accept { new ITypeVisitor with - member __.Visit<'b> () = autoInner<'b> config newRecursionDepths |> box + member __.Visit<'b> () = autoInner<'b> config recursionState.Depths |> box }) let resGen = factory factoryArgs.genericTypes targetArgs @@ -522,7 +514,7 @@ module GenX = s.Element.Accept { new ITypeVisitor> with member __.Visit<'a> () = - if canRecurse then + if recursionState.CanRecurse then gen { let! lengths = config @@ -531,7 +523,7 @@ module GenX = |> List.replicate s.Rank |> ListGen.sequence let elementCount = lengths |> List.fold (*) 1 - let! data = autoInner<'a> config newRecursionDepths |> Gen.list (Range.singleton elementCount) + let! data = autoInner<'a> config recursionState.Depths |> Gen.list (Range.singleton elementCount) return MultidimensionalArray.createWithGivenEntries<'a> data lengths |> unbox } else @@ -582,14 +574,14 @@ module GenX = gen { let! collectionCtor = genPoco shape let! elements = - if canRecurse - then autoInner<'element> config newRecursionDepths |> Gen.list (AutoGenConfig.seqRange config) + if recursionState.CanRecurse + then autoInner<'element> config recursionState.Depths |> Gen.list (AutoGenConfig.seqRange config) else Gen.constant [] let collection = collectionCtor () |> unbox> for e in elements do collection.Add e return collection |> unbox<'a> } - | _ -> raise unsupportedTypeException + | _ -> raise (AutoGenHelpers.unsupportedTypeException<'a>()) } | Shape.CliMutable (:? ShapeCliMutable<'a> as shape) -> @@ -610,7 +602,7 @@ module GenX = | Shape.Poco (:? ShapePoco<'a> as shape) -> genPoco shape |> Gen.map (fun x -> x ()) - | _ -> raise unsupportedTypeException + | _ -> raise (AutoGenHelpers.unsupportedTypeException<'a>()) let auto<'a> = autoInner<'a> defaults Map.empty diff --git a/src/Hedgehog.Experimental/Hedgehog.Experimental.fsproj b/src/Hedgehog.Experimental/Hedgehog.Experimental.fsproj index a139c2b..c4aaa42 100644 --- a/src/Hedgehog.Experimental/Hedgehog.Experimental.fsproj +++ b/src/Hedgehog.Experimental/Hedgehog.Experimental.fsproj @@ -27,6 +27,7 @@ + <_Parameter1>Hedgehog.Experimental.Tests diff --git a/src/Hedgehog.Experimental/MultidimensionalArray.fs b/src/Hedgehog.Experimental/MultidimensionalArray.fs new file mode 100644 index 0000000..b485e56 --- /dev/null +++ b/src/Hedgehog.Experimental/MultidimensionalArray.fs @@ -0,0 +1,23 @@ +namespace Hedgehog.Experimental +open System + +module internal MultidimensionalArray = + + let createWithDefaultEntries<'a> (lengths: int list) = + let array = lengths |> Array.ofList + Array.CreateInstance (typeof<'a>, array) + + let createWithGivenEntries<'a> (data: 'a seq) lengths = + let array = createWithDefaultEntries<'a> lengths + let currentIndices = Array.create (List.length lengths) 0 + use en = data.GetEnumerator () + let rec loop currentDimensionIndex = function + | [] -> + en.MoveNext () |> ignore + array.SetValue(en.Current, currentIndices) + | currentLength :: remainingLengths -> + for i in 0..currentLength - 1 do + currentIndices[currentDimensionIndex] <- i + loop (currentDimensionIndex + 1) remainingLengths + loop 0 lengths + array From 5669390974627718d4aa63556a7cfd312182a471 Mon Sep 17 00:00:00 2001 From: Alexey Raga Date: Sat, 15 Nov 2025 00:15:32 +1100 Subject: [PATCH 4/7] Generate IReadOnlyList and IReadOnlyDictionary --- .../DefaultGeneratorsTests.cs | 20 +++++++++++++++---- .../DefaultGenerators.fs | 18 ++++++++++------- 2 files changed, 27 insertions(+), 11 deletions(-) diff --git a/src/Hedgehog.Experimental.CSharp.Tests/DefaultGeneratorsTests.cs b/src/Hedgehog.Experimental.CSharp.Tests/DefaultGeneratorsTests.cs index fdfb5ae..c61a0cd 100644 --- a/src/Hedgehog.Experimental.CSharp.Tests/DefaultGeneratorsTests.cs +++ b/src/Hedgehog.Experimental.CSharp.Tests/DefaultGeneratorsTests.cs @@ -8,7 +8,7 @@ namespace Hedgehog.Linq.Tests; public sealed class DefaultGeneratorsTests { - private AutoGenConfig _config = GenX.defaults.WithCollectionRange(Range.FromValue(5)); + private readonly AutoGenConfig _config = GenX.defaults.WithCollectionRange(Range.FromValue(5)); [Fact] public void ShouldGenerateImmutableSet() => @@ -42,13 +42,25 @@ public void ShouldGenerateDictionary() => public void ShouldGenerateIDictionary() => ForAll(GenX.autoWith>(_config)).Select(x => x.Count > 0).Check(); + [Fact] + public void ShouldGenerateIReadOnlyDictionary() => + ForAll(GenX.autoWith>(_config)).Select(x => x.Count > 0).Check(); + [Fact] public void ShouldGenerateList() => ForAll(GenX.autoWith>(_config)).Select(x => x.Count == 5).Check(); - // [Fact] - // public void ShouldGenerateIList() => - // ForAll(GenX.autoWith>(_config)).Select(x => x.Count == 5).Check(); + [Fact] + public void ShouldGenerateIList() => + ForAll(GenX.autoWith>(_config)).Select(x => x.Count == 5).Check(); + + [Fact] + public void ShouldGenerateIReadOnlyList() => + ForAll(GenX.autoWith>(_config)).Select(x => x.Count == 5).Check(); + + [Fact] + public void ShouldGenerateIEnumerable() => + ForAll(GenX.autoWith>(_config)).Select(x => x.Count() == 5).Check(); [Fact] public void StressTest() => diff --git a/src/Hedgehog.Experimental/DefaultGenerators.fs b/src/Hedgehog.Experimental/DefaultGenerators.fs index ecb4028..38a3e40 100644 --- a/src/Hedgehog.Experimental/DefaultGenerators.fs +++ b/src/Hedgehog.Experimental/DefaultGenerators.fs @@ -1,6 +1,7 @@ namespace Hedgehog.Experimental open System.Collections.Generic +open System.Collections.ObjectModel open System.Linq open Hedgehog open System @@ -78,13 +79,13 @@ type DefaultGenerators = Gen.constant (Dictionary<'k, 'v>()) static member IDictionary<'k, 'v when 'k: equality>(config: AutoGenConfig, recursionContext: RecursionContext, keyGen: Gen<'k>, valueGen: Gen<'v>): Gen> = - if recursionContext.CanRecurse then - gen { - let! kvps = Gen.zip keyGen valueGen |> Gen.list (AutoGenConfig.seqRange config) - return Dictionary(dict kvps) - } - else - Gen.constant (Dictionary<'k, 'v>() :> IDictionary<'k, 'v>) + DefaultGenerators.Dictionary(config, recursionContext, keyGen, valueGen) |> Gen.map (fun x -> x :> IDictionary<'k, 'v>) + + static member ReadOnlyDictionary<'k, 'v when 'k: equality>(config: AutoGenConfig, recursionContext: RecursionContext, keyGen: Gen<'k>, valueGen: Gen<'v>): Gen> = + DefaultGenerators.Dictionary(config, recursionContext, keyGen, valueGen) |> Gen.map (fun x -> ReadOnlyDictionary(x)) + + static member IReadOnlyDictionary<'k, 'v when 'k: equality>(config: AutoGenConfig, recursionContext: RecursionContext, keyGen: Gen<'k>, valueGen: Gen<'v>): Gen> = + DefaultGenerators.Dictionary(config, recursionContext, keyGen, valueGen) |> Gen.map (fun x -> ReadOnlyDictionary(x)) static member FSharpList<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen<'a list> = if recursionContext.CanRecurse then @@ -98,6 +99,9 @@ type DefaultGenerators = static member IList<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = DefaultGenerators.FSharpList(config, recursionContext, valueGen) |> Gen.map _.ToList() + static member IReadOnlyList<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = + DefaultGenerators.FSharpList(config, recursionContext, valueGen) |> Gen.map _.ToList().AsReadOnly() + static member Seq<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = DefaultGenerators.FSharpList(config, recursionContext, valueGen) |> Gen.map Seq.ofList From 2ce9d2d250a4307e654665428f6da9e77997069e Mon Sep 17 00:00:00 2001 From: Alexey Raga Date: Sat, 15 Nov 2025 09:05:07 +1100 Subject: [PATCH 5/7] Simplify context propagation --- README.md | 10 +- .../GenericGenTests.cs | 4 +- .../AutoGenContextTests.fs | 36 +++++++ .../Hedgehog.Experimental.Tests.fsproj | 1 + src/Hedgehog.Experimental/AutoGenConfig.fs | 29 +++--- .../DefaultGenerators.fs | 96 +++++++++---------- src/Hedgehog.Experimental/GenX.fs | 75 ++++++++------- 7 files changed, 149 insertions(+), 102 deletions(-) create mode 100644 src/Hedgehog.Experimental.Tests/AutoGenContextTests.fs diff --git a/README.md b/README.md index def3446..8d9c62e 100644 --- a/README.md +++ b/README.md @@ -209,17 +209,17 @@ let! myVal = ```f# // a type containing generators for generic types -// methods should return Gen<_> and are allowed to take Gen<_> and AutoGenConfig as parameters +// methods should return Gen<_> and are allowed to take Gen<_> and AutoGenContext as parameters type GenericGenerators = // Generate generic types static member MyGenericType<'a>(valueGen : Gen<'a>) : Gen> = valueGen | Gen.map (fun x -> MyGenericType(x)) - // Generate generic types with recursion support and access to AutoGenConfig - static member ImmutableList<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = - if recursionContext.CanRecurse then - valueGen |> Gen.list (AutoGenConfig.seqRange config) |> Gen.map ImmutableList.CreateRange + // Generate generic types with recursion support and access to AutoGenContext + static member ImmutableList<'a>(context: AutoGenContext, valueGen: Gen<'a>) : Gen> = + if context.CanRecurse then + valueGen |> Gen.list context.CollectionRange |> Gen.map ImmutableList.CreateRange else Gen.constant ImmutableList<'a>.Empty diff --git a/src/Hedgehog.Experimental.CSharp.Tests/GenericGenTests.cs b/src/Hedgehog.Experimental.CSharp.Tests/GenericGenTests.cs index 745537f..7dd91d5 100644 --- a/src/Hedgehog.Experimental.CSharp.Tests/GenericGenTests.cs +++ b/src/Hedgehog.Experimental.CSharp.Tests/GenericGenTests.cs @@ -53,8 +53,8 @@ public static Gen UuidGen() => public static Gen NameGen(Gen gen) => gen.Select(value => new Name("Name: " + value)); - public static Gen> AlwaysJust(AutoGenConfig config, RecursionContext recCtx, Gen gen) => - recCtx.CanRecurse + public static Gen> AlwaysJust(AutoGenContext context, Gen gen) => + context.CanRecurse ? gen.Select(Maybe (value) => new Maybe.Just(value)) : Gen.FromValue>(new Maybe.Nothing()); diff --git a/src/Hedgehog.Experimental.Tests/AutoGenContextTests.fs b/src/Hedgehog.Experimental.Tests/AutoGenContextTests.fs new file mode 100644 index 0000000..df0230f --- /dev/null +++ b/src/Hedgehog.Experimental.Tests/AutoGenContextTests.fs @@ -0,0 +1,36 @@ +module Hedgehog.Experimental.Tests.AutoGenContextTests + +open Hedgehog +open Xunit +open Swensen.Unquote + +type Maybe<'a> = Just of 'a | Nothing +type RecursiveType<'a> = + { Value: Maybe>} + member this.Depth = + match this.Value with + | Nothing -> 0 + | Just x -> x.Depth + 1 + +type RecursiveGenerators = + // override Option to always generate Some when recursion is allowed + // using the AutoGenContext to assert recursion context preservation + static member Option<'a>(context: AutoGenContext) = + if context.CanRecurse then + printfn "CurrentRecursionDepth: %d" context.CurrentRecursionDepth + context.AutoGenerate<'a>() |> Gen.map Just + else + Gen.constant Nothing + +[] +let ``Should preserve recursion with generic types when using AutoGenContext.AutoGenerate``() = + property { + let! recDepth = Gen.int32 (Range.constant 2 5) + let config = + GenX.defaults + |> AutoGenConfig.addGenerators + |> AutoGenConfig.setRecursionDepth recDepth + + let! result = GenX.autoWith> config + test <@ result.Depth = recDepth @> + } |> Property.recheck "0_8749783378671135247_1719019878934027555_" diff --git a/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj b/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj index da9bfbb..103137b 100644 --- a/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj +++ b/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj @@ -13,6 +13,7 @@ + diff --git a/src/Hedgehog.Experimental/AutoGenConfig.fs b/src/Hedgehog.Experimental/AutoGenConfig.fs index 2cdd45d..025a62e 100644 --- a/src/Hedgehog.Experimental/AutoGenConfig.fs +++ b/src/Hedgehog.Experimental/AutoGenConfig.fs @@ -3,12 +3,19 @@ namespace Hedgehog open System open System.Reflection -/// Provides recursion depth information for the currently generated type. -/// Can be used by custom generators to respect recursion limits. +type internal IAutoGenerator = + abstract member Generate<'a> : unit -> Gen<'a> + [] -type RecursionContext(canRecurse: bool) = - /// Indicates whether recursion is allowed for the current type being generated. - member _.CanRecurse = canRecurse +type AutoGenContext internal ( + canRecurse: bool, + currentRecursionDepth: int, + collectionRange: Range, + auto: IAutoGenerator) = + member _.CanRecurse = canRecurse + member _.CurrentRecursionDepth = currentRecursionDepth + member _.CollectionRange = collectionRange + member _.AutoGenerate<'a>() : Gen<'a> = auto.Generate<'a>() type AutoGenConfig = internal { seqRange: Range option @@ -60,13 +67,8 @@ module AutoGenConfig = then Some (t.GetGenericArguments().[0]) else None - let getAutoGenConfigType (t: Type) = - if t = typeof - then Some t - else None - - let getRecursionContextType (t: Type) = - if t = typeof + let getAutogenContextType (t: Type) = + if t = typeof then Some t else None @@ -77,8 +79,7 @@ module AutoGenConfig = | None -> None | Some types -> getGenType param.ParameterType - |> Option.orElseWith (fun () -> getAutoGenConfigType param.ParameterType) - |> Option.orElseWith (fun () -> getRecursionContextType param.ParameterType) + |> Option.orElseWith (fun () -> getAutogenContextType param.ParameterType) |> Option.map (fun t -> Array.append types [| t |]) ) (Some [||]) diff --git a/src/Hedgehog.Experimental/DefaultGenerators.fs b/src/Hedgehog.Experimental/DefaultGenerators.fs index 38a3e40..7fc7e55 100644 --- a/src/Hedgehog.Experimental/DefaultGenerators.fs +++ b/src/Hedgehog.Experimental/DefaultGenerators.fs @@ -33,97 +33,97 @@ type DefaultGenerators = |> Range.map DateTime Gen.dateTime dateTimeRange |> Gen.map DateTimeOffset - static member ImmutableList<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = - if recursionContext.CanRecurse then - valueGen |> Gen.list (AutoGenConfig.seqRange config) |> Gen.map ImmutableList.CreateRange + static member ImmutableList<'a>(context: AutoGenContext, valueGen: Gen<'a>) : Gen> = + if context.CanRecurse then + valueGen |> Gen.list context.CollectionRange |> Gen.map ImmutableList.CreateRange else Gen.constant ImmutableList<'a>.Empty - static member IImmutableList<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = - if recursionContext.CanRecurse then - DefaultGenerators.ImmutableList(config, recursionContext, valueGen) |> Gen.map (fun x -> x :> IImmutableList<'a>) + static member IImmutableList<'a>(context: AutoGenContext, valueGen: Gen<'a>) : Gen> = + if context.CanRecurse then + DefaultGenerators.ImmutableList(context, valueGen) |> Gen.map (fun x -> x :> IImmutableList<'a>) else Gen.constant (ImmutableList<'a>.Empty :> IImmutableList<'a>) - static member ImmutableArray<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = - if recursionContext.CanRecurse then - valueGen |> Gen.array (AutoGenConfig.seqRange config) |> Gen.map ImmutableArray.CreateRange + static member ImmutableArray<'a>(context: AutoGenContext, valueGen: Gen<'a>) : Gen> = + if context.CanRecurse then + valueGen |> Gen.array context.CollectionRange |> Gen.map ImmutableArray.CreateRange else Gen.constant (ImmutableArray<'a>.Empty) - static member ImmutableHashSet<'a when 'a : equality>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = - if recursionContext.CanRecurse then - valueGen |> Gen.list (AutoGenConfig.seqRange config) |> Gen.map ImmutableHashSet.CreateRange + static member ImmutableHashSet<'a when 'a : equality>(context: AutoGenContext, valueGen: Gen<'a>) : Gen> = + if context.CanRecurse then + valueGen |> Gen.list context.CollectionRange |> Gen.map ImmutableHashSet.CreateRange else Gen.constant (ImmutableHashSet<'a>.Empty) - static member ImmutableSet<'a when 'a : comparison>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = - if recursionContext.CanRecurse then - valueGen |> Gen.list (AutoGenConfig.seqRange config) |> Gen.map ImmutableSortedSet.CreateRange + static member ImmutableSet<'a when 'a : comparison>(context: AutoGenContext, valueGen: Gen<'a>) : Gen> = + if context.CanRecurse then + valueGen |> Gen.list context.CollectionRange |> Gen.map ImmutableSortedSet.CreateRange else Gen.constant (ImmutableSortedSet<'a>.Empty) - static member IImmutableSet<'a when 'a : equality>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = - if recursionContext.CanRecurse then - DefaultGenerators.ImmutableHashSet(config, recursionContext, valueGen) |> Gen.map (fun x -> x :> IImmutableSet<'a>) + static member IImmutableSet<'a when 'a : equality>(context: AutoGenContext, valueGen: Gen<'a>) : Gen> = + if context.CanRecurse then + DefaultGenerators.ImmutableHashSet(context, valueGen) |> Gen.map (fun x -> x :> IImmutableSet<'a>) else Gen.constant (ImmutableHashSet<'a>.Empty :> IImmutableSet<'a>) - static member Dictionary<'k, 'v when 'k: equality>(config: AutoGenConfig, recursionContext: RecursionContext, keyGen: Gen<'k>, valueGen: Gen<'v>): Gen> = - if recursionContext.CanRecurse then + static member Dictionary<'k, 'v when 'k: equality>(context: AutoGenContext, keyGen: Gen<'k>, valueGen: Gen<'v>): Gen> = + if context.CanRecurse then gen { - let! kvps = Gen.zip keyGen valueGen |> Gen.list (AutoGenConfig.seqRange config) + let! kvps = Gen.zip keyGen valueGen |> Gen.list context.CollectionRange return Dictionary(dict kvps) } else Gen.constant (Dictionary<'k, 'v>()) - static member IDictionary<'k, 'v when 'k: equality>(config: AutoGenConfig, recursionContext: RecursionContext, keyGen: Gen<'k>, valueGen: Gen<'v>): Gen> = - DefaultGenerators.Dictionary(config, recursionContext, keyGen, valueGen) |> Gen.map (fun x -> x :> IDictionary<'k, 'v>) + static member IDictionary<'k, 'v when 'k: equality>(context: AutoGenContext, keyGen: Gen<'k>, valueGen: Gen<'v>): Gen> = + DefaultGenerators.Dictionary(context, keyGen, valueGen) |> Gen.map (fun x -> x :> IDictionary<'k, 'v>) - static member ReadOnlyDictionary<'k, 'v when 'k: equality>(config: AutoGenConfig, recursionContext: RecursionContext, keyGen: Gen<'k>, valueGen: Gen<'v>): Gen> = - DefaultGenerators.Dictionary(config, recursionContext, keyGen, valueGen) |> Gen.map (fun x -> ReadOnlyDictionary(x)) + static member ReadOnlyDictionary<'k, 'v when 'k: equality>(context: AutoGenContext, keyGen: Gen<'k>, valueGen: Gen<'v>): Gen> = + DefaultGenerators.Dictionary(context, keyGen, valueGen) |> Gen.map (fun x -> ReadOnlyDictionary(x)) - static member IReadOnlyDictionary<'k, 'v when 'k: equality>(config: AutoGenConfig, recursionContext: RecursionContext, keyGen: Gen<'k>, valueGen: Gen<'v>): Gen> = - DefaultGenerators.Dictionary(config, recursionContext, keyGen, valueGen) |> Gen.map (fun x -> ReadOnlyDictionary(x)) + static member IReadOnlyDictionary<'k, 'v when 'k: equality>(context: AutoGenContext, keyGen: Gen<'k>, valueGen: Gen<'v>): Gen> = + DefaultGenerators.Dictionary(context, keyGen, valueGen) |> Gen.map (fun x -> ReadOnlyDictionary(x)) - static member FSharpList<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen<'a list> = - if recursionContext.CanRecurse then - valueGen |> Gen.list (AutoGenConfig.seqRange config) + static member FSharpList<'a>(context: AutoGenContext, valueGen: Gen<'a>) : Gen<'a list> = + if context.CanRecurse then + valueGen |> Gen.list context.CollectionRange else Gen.constant [] - static member List<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = - DefaultGenerators.FSharpList(config, recursionContext, valueGen) |> Gen.map _.ToList() + static member List<'a>(context: AutoGenContext, valueGen: Gen<'a>) : Gen> = + DefaultGenerators.FSharpList(context, valueGen) |> Gen.map _.ToList() - static member IList<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = - DefaultGenerators.FSharpList(config, recursionContext, valueGen) |> Gen.map _.ToList() + static member IList<'a>(context: AutoGenContext, valueGen: Gen<'a>) : Gen> = + DefaultGenerators.FSharpList(context, valueGen) |> Gen.map _.ToList() - static member IReadOnlyList<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = - DefaultGenerators.FSharpList(config, recursionContext, valueGen) |> Gen.map _.ToList().AsReadOnly() + static member IReadOnlyList<'a>(context: AutoGenContext, valueGen: Gen<'a>) : Gen> = + DefaultGenerators.FSharpList(context, valueGen) |> Gen.map _.ToList().AsReadOnly() - static member Seq<'a>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = - DefaultGenerators.FSharpList(config, recursionContext, valueGen) |> Gen.map Seq.ofList + static member Seq<'a>(context: AutoGenContext, valueGen: Gen<'a>) : Gen> = + DefaultGenerators.FSharpList(context, valueGen) |> Gen.map Seq.ofList - static member Option<'a>(recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen<'a option> = - if recursionContext.CanRecurse then Gen.option valueGen + static member Option<'a>(context: AutoGenContext, valueGen: Gen<'a>) : Gen<'a option> = + if context.CanRecurse then Gen.option valueGen else Gen.constant None - static member Nullable<'a when 'a : struct and 'a : (new : unit -> 'a) and 'a :> ValueType>(recursionContext: RecursionContext, valueGen: Gen<'a>): Gen> = - if recursionContext.CanRecurse + static member Nullable<'a when 'a : struct and 'a : (new : unit -> 'a) and 'a :> ValueType>(context: AutoGenContext, valueGen: Gen<'a>): Gen> = + if context.CanRecurse then valueGen |> Gen.option |> Gen.map Option.toNullable else Gen.constant (Nullable<'a>()) - static member Set<'a when 'a : comparison>(config: AutoGenConfig, recursionContext: RecursionContext, valueGen: Gen<'a>) : Gen> = - if recursionContext.CanRecurse then - valueGen |> Gen.list (AutoGenConfig.seqRange config) |> Gen.map Set.ofList + static member Set<'a when 'a : comparison>(context: AutoGenContext, valueGen: Gen<'a>) : Gen> = + if context.CanRecurse then + valueGen |> Gen.list context.CollectionRange |> Gen.map Set.ofList else Gen.constant Set.empty - static member Map<'k, 'v when 'k : comparison>(config: AutoGenConfig, recursionContext: RecursionContext, keyGen: Gen<'k>, valueGen: Gen<'v>) : Gen> = - if recursionContext.CanRecurse then + static member Map<'k, 'v when 'k : comparison>(context: AutoGenContext, keyGen: Gen<'k>, valueGen: Gen<'v>) : Gen> = + if context.CanRecurse then gen { - let! kvps = Gen.zip keyGen valueGen |> Gen.list (AutoGenConfig.seqRange config) + let! kvps = Gen.zip keyGen valueGen |> Gen.list context.CollectionRange return Map.ofList kvps } else diff --git a/src/Hedgehog.Experimental/GenX.fs b/src/Hedgehog.Experimental/GenX.fs index 8e32339..8b8163f 100644 --- a/src/Hedgehog.Experimental/GenX.fs +++ b/src/Hedgehog.Experimental/GenX.fs @@ -1,6 +1,7 @@ namespace Hedgehog open System +open System.Collections.Immutable open Hedgehog open Hedgehog.Experimental open TypeShape.Core @@ -333,32 +334,37 @@ module GenX = |> AutoGenConfig.addGenerators |> AutoGenConfig.addGenerator uri - module private AutoGenHelpers = - - let addGenMsg = "You can use 'GenX.defaults |> AutoGenConfig.addGenerator myGen |> GenX.autoWith' to generate types not inherently supported by GenX.auto." - - let unsupportedTypeException<'a> () = - NotSupportedException (sprintf "Unable to auto-generate %s. %s" typeof<'a>.FullName addGenMsg) + type internal RecursionState = { + CurrentLevel: int + CanRecurse: bool + Depths: ImmutableDictionary + } - type RecursionState = { - CurrentLevel: int - CanRecurse: bool - Depths: Map + module internal RecursionState = + let empty = { + CurrentLevel = 0 + CanRecurse = true + Depths = ImmutableDictionary.Empty } - let checkRecursionDepth<'a> (config: AutoGenConfig) (recursionDepths: Map) = - let typeName = typeof<'a>.AssemblyQualifiedName - let currentLevel = recursionDepths.TryFind typeName |> Option.defaultValue 0 + let reconcileFor<'a> (config: AutoGenConfig) (current: RecursionState) = + let currentLevel = current.Depths.GetValueOrDefault(typeof<'a>, 0) let maxDepth = AutoGenConfig.recursionDepth config - if (currentLevel > maxDepth) then None else Some { CurrentLevel = currentLevel CanRecurse = currentLevel < maxDepth - Depths = recursionDepths.Add(typeName, currentLevel + 1) + Depths = current.Depths.SetItem(typeof<'a>, currentLevel + 1) } + module private AutoGenHelpers = + + let addGenMsg = "You can use 'GenX.defaults |> AutoGenConfig.addGenerator myGen |> GenX.autoWith' to generate types not inherently supported by GenX.auto." + + let unsupportedTypeException<'a> () = + NotSupportedException (sprintf "Unable to auto-generate %s. %s" typeof<'a>.FullName addGenMsg) + let resolveGenericTypeArgs (registeredType: Type) (typeArgs: GenericArgument array) (args: Type array) = // If the type is generic, we need to find the actual types to use. // We match generic parameters by their GenericParameterPosition property, @@ -419,20 +425,20 @@ module GenX = resolveGenericTypeArgs registeredType typeArgs args | _ -> {| genericTypes = Array.empty; argumentTypes = args |} - let rec private autoInner<'a> (config : AutoGenConfig) (recursionDepths: Map) : Gen<'a> = + let rec private autoInner<'a> (config : AutoGenConfig) (recursionState: RecursionState) : Gen<'a> = // Prevent auto-generating AutoGenConfig itself - it should only be passed as a parameter if typeof<'a> = typeof then raise (NotSupportedException "Cannot auto-generate AutoGenConfig type. It should be provided as a parameter to generator methods.") - match AutoGenHelpers.checkRecursionDepth<'a> config recursionDepths with + match recursionState |> RecursionState.reconcileFor<'a> config with | None -> Gen.delay (fun () -> raise (InvalidOperationException( sprintf "Recursion depth limit %d exceeded for type %s. " (AutoGenConfig.recursionDepth config) typeof<'a>.FullName + "To fix this, add a RecursionContext parameter to your generator method and use recursionContext.CanRecurse to control recursion."))) - | Some recursionState -> + | Some newRecursionState -> let genPoco (shape: ShapePoco<'a>) = let bestCtor = @@ -447,7 +453,7 @@ module GenX = ctor.Accept { new IConstructorVisitor<'a, Gen<(unit -> 'a)>> with member __.Visit<'CtorParams> (ctor : ShapeConstructor<'a, 'CtorParams>) = - autoInner config recursionState.Depths + autoInner config newRecursionState |> Gen.map (fun args -> let delayedCtor () = try @@ -466,7 +472,7 @@ module GenX = shape.Accept { new IMemberVisitor<'DeclaringType, Gen<'DeclaringType -> 'DeclaringType>> with member _.Visit(shape: ShapeMember<'DeclaringType, 'MemberType>) = - autoInner<'MemberType> config recursionState.Depths + autoInner<'MemberType> config newRecursionState |> Gen.map (fun mtValue -> fun dt -> try shape.Set dt mtValue @@ -489,17 +495,20 @@ module GenX = let targetArgs = factoryArgs.argumentTypes |> Array.map (fun t -> - // Check if this is AutoGenConfig type - if t = typeof then - box config - // Check if this is RecursionContext type - elif t = typeof then - box (RecursionContext(recursionState.CanRecurse)) + if t = typeof then + let ctx = AutoGenContext( + canRecurse = newRecursionState.CanRecurse, + currentRecursionDepth = newRecursionState.CurrentLevel, + collectionRange = AutoGenConfig.seqRange config, + auto = { + new IAutoGenerator with + member __.Generate<'x>() = autoInner<'x> config newRecursionState }) + box ctx else // Otherwise, generate a value for this type let ts = TypeShape.Create(t) ts.Accept { new ITypeVisitor with - member __.Visit<'b> () = autoInner<'b> config recursionState.Depths |> box + member __.Visit<'b> () = autoInner<'b> config newRecursionState |> box }) let resGen = factory factoryArgs.genericTypes targetArgs @@ -514,7 +523,7 @@ module GenX = s.Element.Accept { new ITypeVisitor> with member __.Visit<'a> () = - if recursionState.CanRecurse then + if newRecursionState.CanRecurse then gen { let! lengths = config @@ -523,7 +532,7 @@ module GenX = |> List.replicate s.Rank |> ListGen.sequence let elementCount = lengths |> List.fold (*) 1 - let! data = autoInner<'a> config recursionState.Depths |> Gen.list (Range.singleton elementCount) + let! data = autoInner<'a> config newRecursionState |> Gen.list (Range.singleton elementCount) return MultidimensionalArray.createWithGivenEntries<'a> data lengths |> unbox } else @@ -574,8 +583,8 @@ module GenX = gen { let! collectionCtor = genPoco shape let! elements = - if recursionState.CanRecurse - then autoInner<'element> config recursionState.Depths |> Gen.list (AutoGenConfig.seqRange config) + if newRecursionState.CanRecurse + then autoInner<'element> config newRecursionState |> Gen.list (AutoGenConfig.seqRange config) else Gen.constant [] let collection = collectionCtor () |> unbox> for e in elements do collection.Add e @@ -604,6 +613,6 @@ module GenX = | _ -> raise (AutoGenHelpers.unsupportedTypeException<'a>()) - let auto<'a> = autoInner<'a> defaults Map.empty + let auto<'a> = autoInner<'a> defaults RecursionState.empty - let autoWith<'a> config = autoInner<'a> config Map.empty + let autoWith<'a> config = autoInner<'a> config RecursionState.empty From 4e7ea73c2a1154e7979dbb8fe88b4dfd6eaa9021 Mon Sep 17 00:00:00 2001 From: Alexey Raga Date: Sat, 15 Nov 2025 15:53:57 +1100 Subject: [PATCH 6/7] Safer generators overriding --- .../AutoGenContextTests.fs | 13 ++-- .../GenericGenTests.fs | 24 +++++-- src/Hedgehog.Experimental/AutoGenConfig.fs | 5 +- .../GeneratorCollection.fs | 69 ++++++++++++++++--- src/Hedgehog.Experimental/TypeUtils.fs | 2 +- 5 files changed, 87 insertions(+), 26 deletions(-) diff --git a/src/Hedgehog.Experimental.Tests/AutoGenContextTests.fs b/src/Hedgehog.Experimental.Tests/AutoGenContextTests.fs index df0230f..fd4b8dd 100644 --- a/src/Hedgehog.Experimental.Tests/AutoGenContextTests.fs +++ b/src/Hedgehog.Experimental.Tests/AutoGenContextTests.fs @@ -4,13 +4,12 @@ open Hedgehog open Xunit open Swensen.Unquote -type Maybe<'a> = Just of 'a | Nothing type RecursiveType<'a> = - { Value: Maybe>} + { Value: Option>} member this.Depth = match this.Value with - | Nothing -> 0 - | Just x -> x.Depth + 1 + | None -> 0 + | Some x -> x.Depth + 1 type RecursiveGenerators = // override Option to always generate Some when recursion is allowed @@ -18,9 +17,9 @@ type RecursiveGenerators = static member Option<'a>(context: AutoGenContext) = if context.CanRecurse then printfn "CurrentRecursionDepth: %d" context.CurrentRecursionDepth - context.AutoGenerate<'a>() |> Gen.map Just + context.AutoGenerate<'a>() |> Gen.map Some else - Gen.constant Nothing + Gen.constant None [] let ``Should preserve recursion with generic types when using AutoGenContext.AutoGenerate``() = @@ -33,4 +32,4 @@ let ``Should preserve recursion with generic types when using AutoGenContext.Aut let! result = GenX.autoWith> config test <@ result.Depth = recDepth @> - } |> Property.recheck "0_8749783378671135247_1719019878934027555_" + } |> Property.check diff --git a/src/Hedgehog.Experimental.Tests/GenericGenTests.fs b/src/Hedgehog.Experimental.Tests/GenericGenTests.fs index 277aef6..cf704f5 100644 --- a/src/Hedgehog.Experimental.Tests/GenericGenTests.fs +++ b/src/Hedgehog.Experimental.Tests/GenericGenTests.fs @@ -21,10 +21,7 @@ type GenericTestGenerators = // Test that we can override the "default" generator for a type static member Guid() = - Gen.byte (Range.constantBounded()) - |> Gen.array (Range.singleton 12) - |> Gen.map (Array.append (Array.zeroCreate 4)) - |> Gen.map Guid + Gen.constant Guid.Empty // A generator for Id<'a> to test phantom generic type static member Id<'a>(gen : Gen) : Gen> = gen |> Gen.map Id @@ -43,6 +40,12 @@ type GenericTestGenerators = static member AlwaysLeft<'a, 'b>(genB: Gen<'b>, genA: Gen<'a>) : Gen> = genA |> Gen.map Left + static member MaybeStringSpecific(): Gen> = + Gen.constant (Just "Specific String") + + static member EitherIntStringSpecific<'a>(): Gen> = + Gen.constant (Right "Specific String") + let checkWith tests = PropertyConfig.defaultConfig |> PropertyConfig.withTests tests |> Property.checkWith let isCustomGuid (guid: Guid) = guid.ToByteArray()[..3] |> Array.forall ((=) 0uy) @@ -59,7 +62,7 @@ let ``should generate value with phantom generic type - Id<'a>``() = let ``should generate generic value for union type - Either<'a, 'b>``() = let config = GenX.defaults |> AutoGenConfig.addGenerators checkWith 100 <| property { - let! x = GenX.autoWith> config + let! x = GenX.autoWith> config test <@ x |> function Left _ -> true | _ -> false @> } @@ -102,3 +105,14 @@ let ``should generate outer class with generic type inside``() = let! x = GenX.autoWith config test <@ x |> function cls -> match cls.Value with Just v -> isCustomGuid v | _ -> false @> } + +[] +let ``should use most specific generators``() = + let config = GenX.defaults |> AutoGenConfig.addGenerators + checkWith 100 <| property { + let! x = GenX.autoWith> config + test <@ x = Just "Specific String" @> + + let! y = GenX.autoWith> config + test <@ y = Right "Specific String" @> + } diff --git a/src/Hedgehog.Experimental/AutoGenConfig.fs b/src/Hedgehog.Experimental/AutoGenConfig.fs index 025a62e..1164506 100644 --- a/src/Hedgehog.Experimental/AutoGenConfig.fs +++ b/src/Hedgehog.Experimental/AutoGenConfig.fs @@ -56,7 +56,8 @@ module AutoGenConfig = /// Add a generator to the configuration. let addGenerator (gen: Gen<'a>) = - mapGenerators (GeneratorCollection.map _.SetItem(typeof<'a>, ([||], fun _ _ -> gen))) + let targetType = typeof<'a> + mapGenerators (GeneratorCollection.addGenerator targetType targetType [||] (fun _ _ -> gen)) /// Add generators from a given type. /// The type is expected to have static methods that return Gen<_>. @@ -95,5 +96,5 @@ module AutoGenConfig = Some (targetType, typeArray, factory) | _ -> None) |> Seq.fold (fun cfg (targetType, typeArray, factory) -> - cfg |> mapGenerators (GeneratorCollection.addGenerator targetType typeArray factory)) + cfg |> mapGenerators (GeneratorCollection.addGenerator targetType targetType typeArray factory)) config diff --git a/src/Hedgehog.Experimental/GeneratorCollection.fs b/src/Hedgehog.Experimental/GeneratorCollection.fs index 7789147..14e22d9 100644 --- a/src/Hedgehog.Experimental/GeneratorCollection.fs +++ b/src/Hedgehog.Experimental/GeneratorCollection.fs @@ -7,16 +7,31 @@ open System.Collections.Immutable // It takes an array of genetic type parameters and an array of arguments to create the generator. type private GeneratorFactory = Type[] -> obj[] -> obj +/// Represents a normalized key for generator lookup that distinguishes between +/// different patterns of generic vs concrete type arguments. +/// For example: +/// - Either<'a, string> and Either<'b, string> have the same key +/// - Either<'a, 'b> and Either<'x, 'y> have the same key +/// - But Either<'a, string> and Either<'a, 'b> have different keys +type internal GeneratorKey = { + /// The generic type definition (e.g., Either<,>) + GenericTypeDefinition: Type + /// For each type argument position, Some(type) if concrete, None if generic parameter + /// E.g., Either<'a, string> -> [None; Some(string)] + ConcreteTypes: Type option list +} + [] -type GeneratorCollection = +type internal GeneratorCollection = // A dictionary of generators. - // The key is a 'required' generator type + // The key distinguishes between different patterns of generic vs concrete type arguments // The value is a tuple of: - // 1. An array types of arguments for the generator factory - // 2. A generator factory, which can be backed by a generic method, + // 1. The original reflected type (with generic parameters intact for type resolution) + // 2. An array types of arguments for the generator factory + // 3. A generator factory, which can be backed by a generic method, // so it takes an array of genetic type parameters, // and an array of arguments to create the generator. - private GeneratorCollection of ImmutableDictionary + GeneratorCollection of ImmutableDictionary module internal GeneratorCollection = @@ -25,17 +40,49 @@ module internal GeneratorCollection = let unwrap (GeneratorCollection map) = map let map f = unwrap >> f >> GeneratorCollection + /// Create a GeneratorKey from a type by identifying which positions are generic vs concrete + let private createKey (t: Type) : GeneratorKey = + if t.IsGenericType then + let concreteTypes = + t.GetGenericArguments() + |> Seq.map (fun arg -> if arg.IsGenericParameter then None else Some arg) + |> List.ofSeq + { GenericTypeDefinition = t.GetGenericTypeDefinition(); ConcreteTypes = concreteTypes } + else + // Non-generic types use themselves as the key + { GenericTypeDefinition = t; ConcreteTypes = [] } + let merge (GeneratorCollection gens1) (GeneratorCollection gens2) = GeneratorCollection (gens1.SetItems(gens2)) - let addGenerator (targetType: Type) (paramTypes: Type[]) (factory: Type[] -> obj[] -> obj) = - map _.SetItem(targetType, (paramTypes, factory)) + let addGenerator (normalizedType: Type) (originalType: Type) (paramTypes: Type[]) (factory: Type[] -> obj[] -> obj) = + let key = createKey normalizedType + map _.SetItem(key, (originalType, paramTypes, factory)) + + /// Count the number of generic parameters in a type + let private countGenericParameters (t: Type) = + if t.IsGenericType then t.GetGenericArguments() |> Seq.filter _.IsGenericParameter |> Seq.length + else 0 - // Find a generator that can satisfy the given requited type. + // Find a generator that can satisfy the given required type. // It also takes care of finding 'generic' generators (like Either<'a, 'b>) // to satisfy specific types (like Either). - // Returns the registered target type along with the args and factory. + // When multiple generators match, returns the most specific one (fewest generic parameters). + // Returns the original reflected type along with the args and factory. let tryFindFor (targetType: Type) = unwrap - >> Seq.tryFind (fun (KeyValue (t, _)) -> t |> TypeUtils.satisfies targetType) - >> Option.map (fun (KeyValue (k, v)) -> (k, v)) + >> Seq.choose (fun (KeyValue (key, (originalType, paramTypes, factory))) -> + // Only consider generators with the same generic type definition + let targetKey = createKey targetType + if key.GenericTypeDefinition = targetKey.GenericTypeDefinition then + // Check if the stored type can satisfy the target type + if originalType |> TypeUtils.satisfies targetType then + Some (originalType, paramTypes, factory) + else + None + else + None + ) + >> Seq.sortBy (fun (originalType, _, _) -> countGenericParameters originalType) + >> Seq.tryHead + >> Option.map (fun (originalType, paramTypes, factory) -> (originalType, (paramTypes, factory))) diff --git a/src/Hedgehog.Experimental/TypeUtils.fs b/src/Hedgehog.Experimental/TypeUtils.fs index b699bfa..84cf9aa 100644 --- a/src/Hedgehog.Experimental/TypeUtils.fs +++ b/src/Hedgehog.Experimental/TypeUtils.fs @@ -4,7 +4,7 @@ module internal Hedgehog.TypeUtils open System let satisfies (value: Type) (gen: Type) : bool = - if gen.IsGenericTypeDefinition || gen.IsGenericType && value.IsGenericType then + if (gen.IsGenericTypeDefinition || gen.IsGenericType) && value.IsGenericType then let genDef = if gen.IsGenericType then gen.GetGenericTypeDefinition() else gen let valueDef = value.GetGenericTypeDefinition() if genDef = valueDef then From 93a9ab6d21316fc2ed0ae2602a9cc1b042fc3a52 Mon Sep 17 00:00:00 2001 From: Alexey Raga Date: Sat, 15 Nov 2025 16:19:28 +1100 Subject: [PATCH 7/7] Big (2x - 5x) perf gain via momoisation --- .../Hedgehog.Experimental.Tests.fsproj | 2 +- .../GeneratorCollection.fs | 65 ++++++++++++------- 2 files changed, 41 insertions(+), 26 deletions(-) diff --git a/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj b/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj index 103137b..1297675 100644 --- a/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj +++ b/src/Hedgehog.Experimental.Tests/Hedgehog.Experimental.Tests.fsproj @@ -5,7 +5,7 @@ Exe false - + diff --git a/src/Hedgehog.Experimental/GeneratorCollection.fs b/src/Hedgehog.Experimental/GeneratorCollection.fs index 14e22d9..b62d47e 100644 --- a/src/Hedgehog.Experimental/GeneratorCollection.fs +++ b/src/Hedgehog.Experimental/GeneratorCollection.fs @@ -1,6 +1,7 @@ namespace Hedgehog open System +open System.Collections.Concurrent open System.Collections.Immutable // A generator factory which can be backed by a generic method. @@ -21,8 +22,7 @@ type internal GeneratorKey = { ConcreteTypes: Type option list } -[] -type internal GeneratorCollection = +type internal GeneratorCollection = { // A dictionary of generators. // The key distinguishes between different patterns of generic vs concrete type arguments // The value is a tuple of: @@ -31,14 +31,17 @@ type internal GeneratorCollection = // 3. A generator factory, which can be backed by a generic method, // so it takes an array of genetic type parameters, // and an array of arguments to create the generator. - GeneratorCollection of ImmutableDictionary + Generators: ImmutableDictionary + // The cache memoizes tryFindFor results to avoid repeated reflection calls. + Cache: ConcurrentDictionary +} module internal GeneratorCollection = - let empty = GeneratorCollection(ImmutableDictionary.Empty) - - let unwrap (GeneratorCollection map) = map - let map f = unwrap >> f >> GeneratorCollection + let empty = { + Generators = ImmutableDictionary.Empty + Cache = ConcurrentDictionary() + } /// Create a GeneratorKey from a type by identifying which positions are generic vs concrete let private createKey (t: Type) : GeneratorKey = @@ -52,12 +55,21 @@ module internal GeneratorCollection = // Non-generic types use themselves as the key { GenericTypeDefinition = t; ConcreteTypes = [] } - let merge (GeneratorCollection gens1) (GeneratorCollection gens2) = - GeneratorCollection (gens1.SetItems(gens2)) + let merge (gens1: GeneratorCollection) (gens2: GeneratorCollection) = + // Create a new cache when merging since the generator set has changed + { + Generators = gens1.Generators.SetItems(gens2.Generators) + Cache = ConcurrentDictionary() + } let addGenerator (normalizedType: Type) (originalType: Type) (paramTypes: Type[]) (factory: Type[] -> obj[] -> obj) = - let key = createKey normalizedType - map _.SetItem(key, (originalType, paramTypes, factory)) + fun (gc: GeneratorCollection) -> + let key = createKey normalizedType + // Reset cache when adding a generator since lookup results may change + { + Generators = gc.Generators.SetItem(key, (originalType, paramTypes, factory)) + Cache = ConcurrentDictionary() + } /// Count the number of generic parameters in a type let private countGenericParameters (t: Type) = @@ -69,20 +81,23 @@ module internal GeneratorCollection = // to satisfy specific types (like Either). // When multiple generators match, returns the most specific one (fewest generic parameters). // Returns the original reflected type along with the args and factory. - let tryFindFor (targetType: Type) = - unwrap - >> Seq.choose (fun (KeyValue (key, (originalType, paramTypes, factory))) -> - // Only consider generators with the same generic type definition - let targetKey = createKey targetType - if key.GenericTypeDefinition = targetKey.GenericTypeDefinition then - // Check if the stored type can satisfy the target type - if originalType |> TypeUtils.satisfies targetType then - Some (originalType, paramTypes, factory) + // Results are memoized to avoid repeated reflection calls. + let tryFindFor (targetType: Type) (gc: GeneratorCollection) = + gc.Cache.GetOrAdd(targetType, fun targetType -> + let targetKey = createKey targetType + gc.Generators + |> Seq.choose (fun (KeyValue (key, (originalType, paramTypes, factory))) -> + // Only consider generators with the same generic type definition + if key.GenericTypeDefinition = targetKey.GenericTypeDefinition then + // Check if the stored type can satisfy the target type + if originalType |> TypeUtils.satisfies targetType then + Some (originalType, paramTypes, factory) + else + None else None - else - None + ) + |> Seq.sortBy (fun (originalType, _, _) -> countGenericParameters originalType) + |> Seq.tryHead + |> Option.map (fun (originalType, paramTypes, factory) -> (originalType, (paramTypes, factory))) ) - >> Seq.sortBy (fun (originalType, _, _) -> countGenericParameters originalType) - >> Seq.tryHead - >> Option.map (fun (originalType, paramTypes, factory) -> (originalType, (paramTypes, factory)))