From 60c5d557426fa796ca7b3aad241b47869a2e65d2 Mon Sep 17 00:00:00 2001 From: Adam Becker Date: Tue, 21 Sep 2021 21:17:45 +0000 Subject: [PATCH 1/2] Add more detailed state for property. --- src/Hedgehog/Hedgehog.fsproj | 2 +- src/Hedgehog/Property.fs | 100 +++++++++++++++++---------------- src/Hedgehog/PropertyArgs.fs | 16 ------ src/Hedgehog/PropertyConfig.fs | 8 ++- src/Hedgehog/PropertyState.fs | 47 ++++++++++++++++ 5 files changed, 105 insertions(+), 68 deletions(-) delete mode 100644 src/Hedgehog/PropertyArgs.fs create mode 100644 src/Hedgehog/PropertyState.fs diff --git a/src/Hedgehog/Hedgehog.fsproj b/src/Hedgehog/Hedgehog.fsproj index 6ee480e9..7250ff3f 100644 --- a/src/Hedgehog/Hedgehog.fsproj +++ b/src/Hedgehog/Hedgehog.fsproj @@ -44,7 +44,7 @@ https://github.com/hedgehogqa/fsharp-hedgehog/blob/master/doc/index.md - + diff --git a/src/Hedgehog/Property.fs b/src/Hedgehog/Property.fs index 6522ee78..1d3c66ae 100644 --- a/src/Hedgehog/Property.fs +++ b/src/Hedgehog/Property.fs @@ -127,72 +127,76 @@ module Property = let forAll' (gen : Gen<'a>) : Property<'a> = gen |> forAll success + // + // Conditions + // + + let private shouldFail (state : PropertyState) (config : PropertyConfig) : bool = + config.ShrinkLimit + |> Option.map (fun limit -> state.Shrinks >= limit) + |> Option.defaultValue false + + let private shouldPass (state : PropertyState) (config : PropertyConfig) : bool = + state.Tests >= config.TestLimit + + let private shouldGiveUp (state : PropertyState) (config : PropertyConfig) : bool = + state.Discards >= config.DiscardLimit + // // Runner // - let private shrinkInput - (args : PropertyArgs) - (shrinkLimit : int Option) = - let rec loop - (nshrinks : int) - (Node ((journal, _), xs) : Tree>) = + let private shrinkInput (state : PropertyState) (config : PropertyConfig) (tree : Tree>) : Status = + let rec loop (state : PropertyState) (tree : Tree>) : Status = + let (Node ((journal, _), xs)) = tree + let failed = Failed { - Size = args.Size - Seed = args.Seed - Shrinks = nshrinks + Size = state.Size + Seed = state.Seed + Shrinks = state.Shrinks Journal = journal - RecheckType = args.RecheckType + RecheckType = state.RecheckType } - match shrinkLimit, Seq.tryFind (Tree.outcome >> snd >> Outcome.isFailure) xs with - | Some shrinkLimit', _ when nshrinks >= shrinkLimit' -> failed - | _, None -> failed - | _, Some tree -> loop (nshrinks + 1) tree - loop 0 + if shouldFail state config then + failed + else + match Seq.tryFind (Tree.outcome >> snd >> Outcome.isFailure) xs with + | None -> failed + | Some tree -> loop (PropertyState.countShrink state) tree + loop state tree - let private reportWith' (args : PropertyArgs) (config : PropertyConfig) (p : Property) : Report = + let private reportWith' (state : PropertyState) (config : PropertyConfig) (p : Property) : Report = let random = toGen p |> Gen.toRandom - let nextSize size = - if size >= 100 then - 1 - else - size + 1 - - let rec loop args tests discards = - if tests = config.TestLimit then - { Tests = tests - Discards = discards + let rec loop state = + if shouldPass state config then + { Tests = state.Tests + Discards = state.Discards Status = OK } - elif discards >= 100 then - { Tests = tests - Discards = discards + elif shouldGiveUp state config then + { Tests = state.Tests + Discards = state.Discards Status = GaveUp } else - let seed1, seed2 = Seed.split args.Seed - let result = Random.run seed1 args.Size random - let nextArgs = { - args with - Seed = seed2 - Size = nextSize args.Size - } + let seed, state = PropertyState.next state + let tree = Random.run seed state.Size random - match snd (Tree.outcome result) with + match snd (Tree.outcome tree) with | Failure -> - { Tests = tests + 1 - Discards = discards - Status = shrinkInput args config.ShrinkLimit result } + { Tests = state.Tests + 1 + Discards = state.Discards + Status = shrinkInput state config tree } | Success () -> - loop nextArgs (tests + 1) discards + loop (PropertyState.countTest state) | Discard -> - loop nextArgs tests (discards + 1) + loop (PropertyState.countDiscard state) - loop args 0 0 + loop state let reportWith (config : PropertyConfig) (p : Property) : Report = - let args = PropertyArgs.init - p |> reportWith' args config + let state = PropertyState.init + p |> reportWith' state config let report (p : Property) : Report = p |> reportWith PropertyConfig.defaultConfig @@ -218,13 +222,13 @@ module Property = g |> bind ofBool |> checkWith config let reportRecheckWith (size : Size) (seed : Seed) (config : PropertyConfig) (p : Property) : Report = - let args = { - PropertyArgs.init with + let state = { + PropertyState.init with RecheckType = RecheckType.None Seed = seed Size = size } - reportWith' args config p + reportWith' state config p let reportRecheck (size : Size) (seed : Seed) (p : Property) : Report = reportRecheckWith size seed PropertyConfig.defaultConfig p diff --git a/src/Hedgehog/PropertyArgs.fs b/src/Hedgehog/PropertyArgs.fs deleted file mode 100644 index 7a7867ac..00000000 --- a/src/Hedgehog/PropertyArgs.fs +++ /dev/null @@ -1,16 +0,0 @@ -namespace Hedgehog - -[] -type PropertyArgs = private { - RecheckType : RecheckType - Size : Size - Seed : Seed -} - -module PropertyArgs = - - let init = { - RecheckType = RecheckType.FSharp - Size = 0 - Seed = Seed.random () - } diff --git a/src/Hedgehog/PropertyConfig.fs b/src/Hedgehog/PropertyConfig.fs index b229389d..ad0e4337 100644 --- a/src/Hedgehog/PropertyConfig.fs +++ b/src/Hedgehog/PropertyConfig.fs @@ -1,16 +1,18 @@ namespace Hedgehog type PropertyConfig = internal { - TestLimit : int + DiscardLimit : int ShrinkLimit : int option + TestLimit : int } module PropertyConfig = /// The default configuration for a property test. let defaultConfig : PropertyConfig = - { TestLimit = 100 - ShrinkLimit = None } + { DiscardLimit = 100 + ShrinkLimit = None + TestLimit = 100 } /// Set the number of times a property is allowed to shrink before the test /// runner gives up and displays the counterexample. diff --git a/src/Hedgehog/PropertyState.fs b/src/Hedgehog/PropertyState.fs new file mode 100644 index 00000000..eaf986f7 --- /dev/null +++ b/src/Hedgehog/PropertyState.fs @@ -0,0 +1,47 @@ +namespace Hedgehog + +[] +type PropertyState = private { + Discards : int + Shrinks : int + Tests : int + RecheckType : RecheckType + Seed : Seed + Size : Size +} + +module PropertyState = + + let init = { + Discards = 0 + Shrinks = 0 + Tests = 0 + RecheckType = RecheckType.FSharp + Seed = Seed.random () + Size = 0 + } + + let countDiscard (state : PropertyState) : PropertyState = + { state with Discards = state.Discards + 1 } + + let countShrink (state : PropertyState) : PropertyState = + { state with Shrinks = state.Shrinks + 1 } + + let countTest (state : PropertyState) : PropertyState = + { state with Tests = state.Tests + 1 } + + let next (state : PropertyState) : (Seed * PropertyState) = + let nextSize size = + if size >= 100 then + 1 + else + size + 1 + + let nextSeed, seed = Seed.split state.Seed + let nextState = { + state with + Seed = seed + Size = nextSize state.Size + } + + (nextSeed, nextState) From f941064447d16c08b7aa4264631d2fb87a682a0c Mon Sep 17 00:00:00 2001 From: Adam Becker Date: Tue, 21 Sep 2021 21:39:07 +0000 Subject: [PATCH 2/2] Minor name juggling. --- src/Hedgehog/PropertyState.fs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Hedgehog/PropertyState.fs b/src/Hedgehog/PropertyState.fs index eaf986f7..eb1f425b 100644 --- a/src/Hedgehog/PropertyState.fs +++ b/src/Hedgehog/PropertyState.fs @@ -31,17 +31,17 @@ module PropertyState = { state with Tests = state.Tests + 1 } let next (state : PropertyState) : (Seed * PropertyState) = - let nextSize size = - if size >= 100 then + let nextSize = + if state.Size >= 100 then 1 else - size + 1 + state.Size + 1 - let nextSeed, seed = Seed.split state.Seed - let nextState = { + let seed, nextSeed = Seed.split state.Seed + let state = { state with - Seed = seed - Size = nextSize state.Size + Seed = nextSeed + Size = nextSize } - (nextSeed, nextState) + (seed, state)