Skip to content

Commit 2293751

Browse files
TysonMNTysonMN
authored
Merge pull request #336 from TysonMN/feature/332_recheck_one_input
Only recheck shrunken input
2 parents 0b6a159 + b39906d commit 2293751

File tree

13 files changed

+202
-62
lines changed

13 files changed

+202
-62
lines changed

‎CHANGELOG.md‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@
55
- A breaking change. Previously, returning a `bool` from a `property` CE (after using `let!`) caused the CE to have return type `Property<unit>`. Now this results in a return type of `Property<bool>`. The previous behavior can now be expressed by piping the `Property<bool>` instance into `Property.falseToFailure`.
66
- Change recheck API to accept recheck data encoded as `string` ([#385][385], [@TysonMN][TysonMN])
77
- Add `RecheckInfo` to simplify recheck reporting ([#386][386], [@TysonMN][TysonMN])
8+
- Optimize rechecking by only executing the end of the `property` CE with the shrunken input ([#336][336], [@TysonMN][TysonMN])
89

910
## Version 0.11.1 (2021-11-19)
1011

@@ -234,6 +235,8 @@
234235
https://github.com/hedgehogqa/fsharp-hedgehog/pull/338
235236
[337]:
236237
https://github.com/hedgehogqa/fsharp-hedgehog/pull/337
238+
[336]:
239+
https://github.com/hedgehogqa/fsharp-hedgehog/pull/336
237240
[334]:
238241
https://github.com/hedgehogqa/fsharp-hedgehog/pull/334
239242
[328]:

‎src/Hedgehog/GenLazy.fs‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
// Workaround for a Fable issue: https://github.com/fable-compiler/Fable/issues/2069
2+
#if FABLE_COMPILER
3+
module Hedgehog.GenLazy
4+
#else
5+
[<RequireQualifiedAccess>]
6+
module internal Hedgehog.GenLazy
7+
#endif
8+
9+
let constant a = a |> Lazy.constant |> Gen.constant
10+
11+
let map f = f |> Lazy.map |> Gen.map
12+
13+
let join glgla = glgla |> Gen.bind Lazy.value
14+
15+
let bind f gla = gla |> map f |> join

‎src/Hedgehog/GenLazyTuple.fs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
// Workaround for a Fable issue: https://github.com/fable-compiler/Fable/issues/2069
2+
#if FABLE_COMPILER
3+
module Hedgehog.GenLazyTuple
4+
#else
5+
[<RequireQualifiedAccess>]
6+
module internal Hedgehog.GenLazyTuple
7+
#endif
8+
9+
let mapFst f = f |> Tuple.mapFst |> GenLazy.map
10+
let mapSnd f = f |> Tuple.mapSnd |> GenLazy.map

‎src/Hedgehog/GenTuple.fs‎

Lines changed: 0 additions & 12 deletions
This file was deleted.

‎src/Hedgehog/Hedgehog.fsproj‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
<?xml version="1.0" encoding="utf-8"?>
1+
<?xml version="1.0" encoding="utf-8"?>
22
<Project Sdk="Microsoft.NET.Sdk">
33
<PropertyGroup>
44
<TargetFrameworks>netstandard1.6;netstandard2.0;net45</TargetFrameworks>
@@ -32,6 +32,7 @@ https://github.com/hedgehogqa/fsharp-hedgehog/blob/master/doc/index.md
3232
<_Parameter1>Hedgehog.Linq.Tests</_Parameter1>
3333
</AssemblyAttribute>
3434
<Compile Include="AutoOpen.fs" />
35+
<Compile Include="Lazy.fs" />
3536
<Compile Include="Numeric.fs" />
3637
<Compile Include="Seed.fs" />
3738
<Compile Include="Seq.fs" />
@@ -44,7 +45,8 @@ https://github.com/hedgehogqa/fsharp-hedgehog/blob/master/doc/index.md
4445
<Compile Include="ListGen.fs" />
4546
<Compile Include="Journal.fs" />
4647
<Compile Include="Tuple.fs" />
47-
<Compile Include="GenTuple.fs" />
48+
<Compile Include="GenLazy.fs" />
49+
<Compile Include="GenLazyTuple.fs" />
4850
<Compile Include="Outcome.fs" />
4951
<Compile Include="Report.fs" />
5052
<Compile Include="PropertyArgs.fs" />

‎src/Hedgehog/Lazy.fs‎

Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,24 @@
1+
// Workaround for a Fable issue: https://github.com/fable-compiler/Fable/issues/2069
2+
#if FABLE_COMPILER
3+
module Hedgehog.Lazy
4+
#else
5+
[<RequireQualifiedAccess>]
6+
module internal Hedgehog.Lazy
7+
#endif
8+
9+
let func (f: unit -> 'a) = Lazy<'a>(valueFactory = fun () -> f ())
10+
11+
let constant (a: 'a) = Lazy<'a>(valueFactory = fun () -> a)
12+
13+
let value (ma: Lazy<'a>) = ma.Value
14+
15+
let map (f: 'a -> 'b) (ma: Lazy<'a>) : Lazy<'b> =
16+
(fun () -> ma.Value |> f)
17+
|> func
18+
19+
let join (mma: Lazy<Lazy<'a>>) =
20+
(fun () -> mma.Value.Value)
21+
|> func
22+
23+
let bind (f: 'a -> Lazy<'b>) =
24+
f |> map >> join

‎src/Hedgehog/Linq/Property.fs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,7 @@ type Property = private Property of Property<unit> with
2121
static member FromBool (value : bool) : Property =
2222
value |> Property.ofBool |> Property
2323

24-
static member FromGen (gen : Gen<Journal * Outcome<'T>>) : Property<'T> =
24+
static member FromGen (gen : Gen<Lazy<Journal * Outcome<'T>>>) : Property<'T> =
2525
Property.ofGen gen
2626

2727
static member FromOutcome (result : Outcome<'T>) : Property<'T> =
@@ -49,7 +49,7 @@ type Property = private Property of Property<unit> with
4949
type PropertyExtensions private () =
5050

5151
[<Extension>]
52-
static member ToGen (property : Property<'T>) : Gen<Journal * Outcome<'T>> =
52+
static member ToGen (property : Property<'T>) : Gen<Lazy<Journal * Outcome<'T>>> =
5353
Property.toGen property
5454

5555
[<Extension>]

‎src/Hedgehog/Property.fs‎

Lines changed: 57 additions & 41 deletions
Original file line numberDiff line numberDiff line change
@@ -5,15 +5,15 @@ open System
55

66
[<Struct>]
77
type Property<'a> =
8-
| Property of Gen<Journal * Outcome<'a>>
8+
| Property of Gen<Lazy<Journal * Outcome<'a>>>
99

1010

1111
module Property =
1212

13-
let ofGen (x : Gen<Journal * Outcome<'a>>) : Property<'a> =
13+
let ofGen (x : Gen<Lazy<Journal * Outcome<'a>>>) : Property<'a> =
1414
Property x
1515

16-
let toGen (Property x : Property<'a>) : Gen<Journal * Outcome<'a>> =
16+
let toGen (Property x : Property<'a>) : Gen<Lazy<Journal * Outcome<'a>>> =
1717
x
1818

1919
let tryFinally (after : unit -> unit) (m : Property<'a>) : Property<'a> =
@@ -37,10 +37,10 @@ module Property =
3737
x.Dispose ())
3838

3939
let filter (p : 'a -> bool) (m : Property<'a>) : Property<'a> =
40-
GenTuple.mapSnd (Outcome.filter p) (toGen m) |> ofGen
40+
m |> toGen |> GenLazyTuple.mapSnd (Outcome.filter p) |> ofGen
4141

4242
let ofOutcome (x : Outcome<'a>) : Property<'a> =
43-
(Journal.empty, x) |> Gen.constant |> ofGen
43+
(Journal.empty, x) |> GenLazy.constant |> ofGen
4444

4545
let failure : Property<unit> =
4646
Failure |> ofOutcome
@@ -58,43 +58,37 @@ module Property =
5858
failure
5959

6060
let counterexample (msg : unit -> string) : Property<unit> =
61-
(Journal.singleton msg, Success ()) |> Gen.constant |> ofGen
62-
63-
let private mapGen
64-
(f : Gen<Journal * Outcome<'a>> -> Gen<Journal * Outcome<'b>>)
65-
(p : Property<'a>) : Property<'b> =
66-
p |> toGen |> f |> ofGen
61+
(Journal.singleton msg, Success ()) |> GenLazy.constant |> ofGen
6762

6863
let map (f : 'a -> 'b) (x : Property<'a>) : Property<'b> =
6964
let g (j, outcome) =
7065
try
7166
(j, outcome |> Outcome.map f)
7267
with e ->
7368
(Journal.append j (Journal.singletonMessage (string e)), Failure)
74-
let h = g |> Gen.map |> mapGen
75-
h x
69+
x |> toGen |> GenLazy.map g |> ofGen
7670

7771
let internal set (a: 'a) (property : Property<'b>) : Property<'a> =
7872
property |> map (fun _ -> a)
7973

8074
let private bindGen
81-
(k : 'a -> Gen<Journal * Outcome<'b>>)
82-
(m : Gen<Journal * Outcome<'a>>) : Gen<Journal * Outcome<'b>> =
83-
m |> Gen.bind (fun (journal, result) ->
75+
(f : 'a -> Gen<Lazy<Journal * Outcome<'b>>>)
76+
(m : Gen<Lazy<Journal * Outcome<'a>>>) : Gen<Lazy<Journal * Outcome<'b>>> =
77+
m |> GenLazy.bind (fun (journal, result) ->
8478
match result with
8579
| Failure ->
86-
Gen.constant (journal, Failure)
80+
GenLazy.constant (journal, Failure)
8781
| Discard ->
88-
Gen.constant (journal, Discard)
89-
| Success x ->
90-
GenTuple.mapFst (Journal.append journal) (k x))
82+
GenLazy.constant (journal, Discard)
83+
| Success a ->
84+
GenLazyTuple.mapFst (Journal.append journal) (f a))
9185

9286
let bind (k : 'a -> Property<'b>) (m : Property<'a>) : Property<'b> =
9387
let kTry a =
9488
try
9589
k a |> toGen
9690
with e ->
97-
(Journal.singletonMessage (string e), Failure) |> Gen.constant
91+
(Journal.singletonMessage (string e), Failure) |> GenLazy.constant
9892
m
9993
|> toGen
10094
|> bindGen kTry
@@ -140,27 +134,51 @@ module Property =
140134
//
141135

142136
let private shrinkInput
143-
(language: Language option)
144-
(recheckData : RecheckData)
137+
(language: Language)
138+
(data : RecheckData)
145139
(shrinkLimit : int<shrinks> Option) =
146140
let rec loop
147141
(nshrinks : int<shrinks>)
148-
(Node ((journal, _), xs) : Tree<Journal * Outcome<'a>>) =
142+
(shrinkPath : ShrinkOutcome list)
143+
(Node (root, xs) : Tree<Lazy<Journal * Outcome<'a>>>) =
144+
let journal = root.Value |> fst
145+
let recheckData = { data with ShrinkPath = shrinkPath }
149146
let failed =
150147
Failed {
151148
Shrinks = nshrinks
152149
Journal = journal
153-
RecheckInfo = language |> Option.map (fun lang -> { Language = lang; Data = recheckData })
154-
}
155-
match shrinkLimit, Seq.tryFind (Tree.outcome >> snd >> Outcome.isFailure) xs with
150+
RecheckInfo =
151+
Some { Language = language
152+
Data = recheckData } }
153+
match shrinkLimit, xs |> Seq.indexed |> Seq.tryFind (snd >> Tree.outcome >> Lazy.value >> snd >> Outcome.isFailure) with
156154
| Some shrinkLimit', _ when nshrinks >= shrinkLimit' -> failed
157155
| _, None -> failed
158-
| _, Some tree -> loop (nshrinks + 1<shrinks>) tree
159-
loop 0<shrinks>
156+
| _, Some (idx, tree) ->
157+
let nextShrinkPath = shrinkPath @ List.replicate idx ShrinkOutcome.Pass @ [ShrinkOutcome.Fail]
158+
loop (nshrinks + 1<shrinks>) nextShrinkPath tree
159+
loop 0<shrinks> []
160+
161+
let rec private followShrinkPath
162+
(Node (root, children) : Tree<Lazy<Journal * Outcome<'a>>>) =
163+
let rec skipPassedChild children shrinkPath =
164+
match children, shrinkPath with
165+
| _, [] ->
166+
Failed {
167+
Shrinks = 0<shrinks>
168+
Journal = root.Value |> fst
169+
RecheckInfo = None
170+
}
171+
| [], _ -> failwith "The shrink path lead to a dead end. This should never happen."
172+
| _ :: childrenTail, ShrinkOutcome.Pass :: shrinkPathTail -> skipPassedChild childrenTail shrinkPathTail
173+
| childrenHead :: _, ShrinkOutcome.Fail :: shrinkPathTail -> followShrinkPath childrenHead shrinkPathTail
174+
skipPassedChild (Seq.toList children)
160175

161-
let private reportWith' (args : PropertyArgs) (config : PropertyConfig) (p : Property<unit>) : Report =
162-
let random = toGen p |> Gen.toRandom
176+
let private splitAndRun p data =
177+
let seed1, seed2 = Seed.split data.Seed
178+
let result = p |> toGen |> Gen.toRandom |> Random.run seed1 data.Size
179+
result, seed2
163180

181+
let private reportWith' (args : PropertyArgs) (config : PropertyConfig) (p : Property<unit>) : Report =
164182
let nextSize size =
165183
if size >= 100 then
166184
1
@@ -177,15 +195,14 @@ module Property =
177195
Discards = discards
178196
Status = GaveUp }
179197
else
180-
let seed1, seed2 = Seed.split data.Seed
181-
let result = Random.run seed1 data.Size random
198+
let result, seed2 = splitAndRun p data
182199
let nextData = {
183200
data with
184201
Seed = seed2
185202
Size = nextSize data.Size
186203
}
187204

188-
match snd (Tree.outcome result) with
205+
match snd (Tree.outcome result).Value with
189206
| Failure ->
190207
{ Tests = tests + 1<tests>
191208
Discards = discards
@@ -222,12 +239,11 @@ module Property =
222239
g |> falseToFailure |> checkWith config
223240

224241
let reportRecheckWith (recheckData: string) (config : PropertyConfig) (p : Property<unit>) : Report =
225-
let args = {
226-
PropertyArgs.init with
227-
Language = None
228-
RecheckData = recheckData |> RecheckData.deserialize
229-
}
230-
p |> reportWith' args config
242+
let recheckData = recheckData |> RecheckData.deserialize
243+
let result, _ = splitAndRun p recheckData
244+
{ Tests = 1<tests>
245+
Discards = 0<discards>
246+
Status = followShrinkPath result recheckData.ShrinkPath }
231247

232248
let reportRecheck (recheckData: string) (p : Property<unit>) : Report =
233249
p |> reportRecheckWith recheckData PropertyConfig.defaultConfig
@@ -310,7 +326,7 @@ module PropertyBuilder =
310326

311327
member __.BindReturn(m : Gen<'a>, f: 'a -> 'b) =
312328
m
313-
|> Gen.map (fun a -> (Journal.empty, Success a))
329+
|> Gen.map (fun a -> Lazy.constant (Journal.empty, Success a))
314330
|> Property.ofGen
315331
|> Property.map f
316332

‎src/Hedgehog/PropertyArgs.fs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2,16 +2,17 @@ namespace Hedgehog
22

33
[<Struct>]
44
type PropertyArgs = internal {
5-
Language : Language option
5+
Language : Language
66
RecheckData : RecheckData
77
}
88

99
module PropertyArgs =
1010

1111
let init = {
12-
Language = Some Language.FSharp
12+
Language = Language.FSharp
1313
RecheckData = {
1414
Size = 0
1515
Seed = Seed.random ()
16+
ShrinkPath = []
1617
}
1718
}

‎src/Hedgehog/Report.fs‎

Lines changed: 18 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -3,11 +3,17 @@ namespace Hedgehog
33
[<Measure>] type tests
44
[<Measure>] type discards
55
[<Measure>] type shrinks
6+
7+
[<RequireQualifiedAccess>]
8+
type ShrinkOutcome =
9+
| Pass
10+
| Fail
611

712
[<Struct>]
813
type RecheckData = internal {
914
Size : Size
1015
Seed : Seed
16+
ShrinkPath : ShrinkOutcome list
1117
}
1218

1319
[<RequireQualifiedAccess>]
@@ -47,7 +53,10 @@ module internal RecheckData =
4753
let serialize data =
4854
[ string data.Size
4955
string data.Seed.Value
50-
string data.Seed.Gamma ]
56+
string data.Seed.Gamma
57+
data.ShrinkPath
58+
|> List.map (function ShrinkOutcome.Fail -> "0" | ShrinkOutcome.Pass -> "1" )
59+
|> String.concat "" ]
5160
|> String.concat separator
5261

5362
let deserialize (s: string) =
@@ -57,8 +66,15 @@ module internal RecheckData =
5766
let seed =
5867
{ Value = parts.[1] |> UInt64.Parse
5968
Gamma = parts.[2] |> UInt64.Parse }
69+
let path =
70+
parts.[3]
71+
|> Seq.map (function '0' -> ShrinkOutcome.Fail
72+
| '1' -> ShrinkOutcome.Pass
73+
| c -> failwithf "Unexpected character %c in shrink path" c)
74+
|> Seq.toList
6075
{ Size = size
61-
Seed = seed }
76+
Seed = seed
77+
ShrinkPath = path }
6278
with e ->
6379
raise (ArgumentException("Failed to deserialize RecheckData", e))
6480

0 commit comments

Comments
 (0)