optimize rechecking

src/Hedgehog/Gen.fs

@@ -43,7 +43,7 @@ module Gen =
     let bind (k : 'a -> Gen<'b>) (m : Gen<'a>) : Gen<'b> =
         toRandom m |> bindRandom (toRandom << k) |> ofRandom
 
-    let flatten (mma : Gen<Gen<'a>>) = mma |> bind id
+    let join (mma : Gen<Gen<'a>>) = mma |> bind id
 
     let mapRandom (f : Random<Tree<'a>> -> Random<Tree<'b>>) (g : Gen<'a>) : Gen<'b> =
         toRandom g |> f |> ofRandom

src/Hedgehog/GenLazy.fs

@@ -10,4 +10,6 @@ let constant a = a |> Lazy.constant |> Gen.constant
 
 let map f = f |> Lazy.map |> Gen.map
 
-let bind f gla = gla |> map f |> Gen.map LazyGen.sequence |> Gen.flatten |> Gen.map Lazy.flatten
+let join glgla = glgla |> Gen.bind Lazy.value
+
+let bind f gla = gla |> map f |> join

src/Hedgehog/Hedgehog.fsproj

@@ -42,7 +42,6 @@ https://github.com/hedgehogqa/fsharp-hedgehog/blob/master/doc/index.md
     <Compile Include="ListGen.fs" />
     <Compile Include="Journal.fs" />
     <Compile Include="Tuple.fs" />
-    <Compile Include="LazyGen.fs" />
     <Compile Include="GenLazy.fs" />
     <Compile Include="GenLazyTuple.fs" />
     <Compile Include="Outcome.fs" />

src/Hedgehog/Lazy.fs

@@ -6,15 +6,19 @@ module Hedgehog.Lazy
 module internal Hedgehog.Lazy
 #endif
 
-let constant a = Lazy(fun () -> a)
+let func (f: unit -> 'a) = Lazy<'a>(valueFactory = fun () -> f ())
+
+let constant (a: 'a) = Lazy<'a>(valueFactory = fun () -> a)
 
 let value (ma: Lazy<'a>) = ma.Value
 
 let map (f: 'a -> 'b) (ma: Lazy<'a>) : Lazy<'b> =
-    Lazy(fun () -> ma.Value |> f)
+    (fun () -> ma.Value |> f)
+    |> func
 
-let flatten (mma: Lazy<Lazy<'a>>) =
-    Lazy(fun () -> mma.Value.Value)
+let join (mma: Lazy<Lazy<'a>>) =
+    (fun () -> mma.Value.Value)
+    |> func
 
 let bind (f: 'a -> Lazy<'b>) =
-    f |> map >> flatten
+    f |> map >> join

src/Hedgehog/Property.fs

@@ -133,24 +133,42 @@ module Property =
             (shrinkLimit : int<shrinks> Option) =
         let rec loop
                 (nshrinks : int<shrinks>)
+                (shrinkPath : ShrinkOutcome list)
                 (Node (root, xs) : Tree<Lazy<Journal * Outcome<'a>>>) =
             let journal = root.Value |> fst
             let failed =
                 Failed {
                     Size = args.Size
                     Seed = args.Seed
                     Shrinks = nshrinks
+                    ShrinkPath = shrinkPath
                     Journal = journal
                     RecheckType = args.RecheckType
                 }
-            match shrinkLimit, Seq.tryFind (Tree.outcome >> Lazy.value >> snd >> Outcome.isFailure) xs with
+            match shrinkLimit, xs |> Seq.indexed |> Seq.tryFind (snd >> Tree.outcome >> Lazy.value >> snd >> Outcome.isFailure) with
             | Some shrinkLimit', _ when nshrinks >= shrinkLimit' -> failed
             | _, None -> failed
-            | _, Some tree -> loop (nshrinks + 1<shrinks>) tree
-        loop 0<shrinks>
+            | _, Some (idx, tree) ->
+                let nextShrinkPath = shrinkPath @ List.replicate idx ShrinkOutcome.Pass @ [ShrinkOutcome.Fail]
+                loop (nshrinks + 1<shrinks>) nextShrinkPath tree
+        loop 0<shrinks> []
+
+    let private followShrinkPath
+            (args : PropertyArgs)
+            (shrinkLimit : int<shrinks> Option) =
+        let rec skipFailure
+                (Node (root, children) : Tree<Lazy<Journal * Outcome<'a>>>) =
+            let rec trySkipNext children shrinkPath =
+                match children, shrinkPath with
+                | _, [] -> shrinkInput args shrinkLimit (Node (root, []))
+                | [], _ -> failwith "The shrink path lead to a dead end. This should never happen. Please report this bug."
+                | _ :: childrenTail, ShrinkOutcome.Pass :: shrinkPathTail -> trySkipNext childrenTail shrinkPathTail
+                | childrenHead :: _, ShrinkOutcome.Fail :: shrinkPathTail -> skipFailure childrenHead shrinkPathTail
+            trySkipNext (Seq.toList children)
+        skipFailure
 
     let private reportWith' (args : PropertyArgs) (config : PropertyConfig) (p : Property<unit>) : Report =
-        let random = toGen p |> Gen.toRandom
+        let random = p |> toGen |> Gen.toRandom
 
         let nextSize size =
             if size >= 100 then
@@ -223,6 +241,31 @@ module Property =
         with e ->
             handle e |> ofGen
 
+    let reportOptimizedRecheckWith (size : Size) (seed : Seed) (shrinkPath : ShrinkOutcome list) (config : PropertyConfig) (p : Property<unit>) : Report =
+        let args = {
+            PropertyArgs.init with
+                RecheckType = RecheckType.None
+                Seed = seed
+                Size = size
+        }
+        //reportWith' args config p
+        let random = p |> toGen |> Gen.toRandom
+        let nextSize size =
+            if size >= 100 then
+                1
+            else
+                size + 1
+        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
+        }
+        { Tests = 1<tests>
+          Discards = 0<discards>
+          Status = followShrinkPath nextArgs config.ShrinkLimit result shrinkPath }
+
     let reportRecheckWith (size : Size) (seed : Seed) (config : PropertyConfig) (p : Property<unit>) : Report =
         let args = {
             PropertyArgs.init with

src/Hedgehog/Report.fs

@@ -4,6 +4,11 @@ namespace Hedgehog
 [<Measure>] type discards
 [<Measure>] type shrinks
 
+[<RequireQualifiedAccess>]
+type ShrinkOutcome =
+    | Pass
+    | Fail
+
 [<RequireQualifiedAccess>]
 type RecheckType =
     | None
@@ -14,6 +19,7 @@ type FailureData = {
     Size : Size
     Seed : Seed
     Shrinks : int<shrinks>
+    ShrinkPath : ShrinkOutcome list
     Journal : Journal
     RecheckType : RecheckType
 }
@@ -86,23 +92,31 @@ module Report =
 
         Seq.iter (appendLine sb) (Journal.eval failure.Journal)
 
+        let serilizeShrinkPath path =
+            let serilzeShrinkStep = function
+                | ShrinkOutcome.Pass -> '1'
+                | ShrinkOutcome.Fail -> '0'
+            path |> Seq.map serilzeShrinkStep |> Seq.toArray |> String
+
         match failure.RecheckType with
         | RecheckType.None ->
             ()
 
         | RecheckType.FSharp ->
             appendLinef sb "This failure can be reproduced by running:"
-            appendLinef sb "> Property.recheck %d ({ Value = %A; Gamma = %A }) <property>"
+            appendLinef sb "> Property.recheck %d ({ Value = %A; Gamma = %A }) \"%s\" <property>"
                 failure.Size
                 failure.Seed.Value
                 failure.Seed.Gamma
+                (failure.ShrinkPath |> serilizeShrinkPath)
 
         | RecheckType.CSharp ->
             appendLinef sb "This failure can be reproduced by running:"
-            appendLinef sb "> property.Recheck(%d, new Seed { Value = %A; Gamma = %A })"
+            appendLinef sb "> Property.recheck %d ({ Value = %A; Gamma = %A }) \"%s\" <property>"
                 failure.Size
                 failure.Seed.Value
                 failure.Seed.Gamma
+                (failure.ShrinkPath |> serilizeShrinkPath)
 
         sb.ToString().Trim() // Exclude extra newline.
 

tests/Hedgehog.Tests/PropertyTests.fs

@@ -1,4 +1,4 @@
-module Hedgehog.Tests.PropertyTests
+module Hedgehog.Tests.PropertyTests
 
 open Hedgehog
 open Expecto
@@ -33,7 +33,13 @@ let asdf () =
     | GaveUp -> failwith "Initial report should be Failed, not GaveUp"
     | Failed failure1 ->
         count <- 0
-        let report2 = Property.reportRecheck failure1.Size ({ Value = failure1.Seed.Value; Gamma = failure1.Seed.Gamma }) prop
+        let report2 =
+            Property.reportOptimizedRecheckWith
+                failure1.Size
+                ({ Value = failure1.Seed.Value; Gamma = failure1.Seed.Gamma })
+                failure1.ShrinkPath
+                PropertyConfig.defaultConfig
+                prop
         match report2.Status with
         | OK -> failwith "Recheck report should be Failed, not OK"
         | GaveUp -> failwith "Recheck report should be Failed, not GaveUp"