Optimize rechecking so that only the shrunken input is tested

src/Hedgehog/Property.fs

@@ -139,23 +139,40 @@ 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 {
-                    RecheckData = data
+                    RecheckData = { data with ShrinkPath = shrinkPath }
                     Shrinks = nshrinks
                     Journal = journal
                     RecheckType = 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.RecheckType args.RecheckData 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,7 +240,24 @@ module Property =
                 RecheckType = RecheckType.None
                 RecheckData = recheckData |> RecheckData.deserialize
         }
-        p |> reportWith' args config
+        //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.RecheckData.Seed
+        let result = Random.run seed1 args.RecheckData.Size random
+        let nextData = {
+            args.RecheckData with
+                Seed = seed2
+                Size = nextSize args.RecheckData.Size
+        }
+        let nextArgs = { args with RecheckData = nextData }
+        { Tests = 1<tests>
+          Discards = 0<discards>
+          Status = followShrinkPath nextArgs config.ShrinkLimit result args.RecheckData.ShrinkPath }
 
     let reportRecheck (recheckData: string) (p : Property<unit>) : Report =
         p |> reportRecheckWith recheckData PropertyConfig.defaultConfig

src/Hedgehog/PropertyArgs.fs

@@ -13,5 +13,6 @@ module PropertyArgs =
         RecheckData = {
             Size = 0
             Seed = Seed.random ()
+            ShrinkPath = []
         }
     }

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
@@ -15,6 +20,7 @@ type RecheckType =
 type RecheckData = internal {
     Size : Size
     Seed : Seed
+    ShrinkPath : ShrinkOutcome list
 }
 
 type FailureData = {
@@ -44,7 +50,10 @@ module internal RecheckData =
     let serialize data =
         [ string data.Size
           string data.Seed.Value
-          string data.Seed.Gamma ]
+          string data.Seed.Gamma
+          data.ShrinkPath
+          |> List.map (function ShrinkOutcome.Fail -> "1" | ShrinkOutcome.Pass -> "0" )
+          |> String.concat "" ]
         |> String.concat separator
 
     let deserialize (s: string) =
@@ -54,8 +63,15 @@ module internal RecheckData =
             let seed =
                 { Value = parts.[1] |> UInt64.Parse
                   Gamma = parts.[2] |> UInt64.Parse }
+            let path =
+                parts.[3]
+                |> Seq.map (function '1' -> ShrinkOutcome.Fail
+                                   | '0' -> ShrinkOutcome.Pass
+                                   |  c  -> sprintf "Unknown character %c in shrink path" c |> failwith)
+                |> Seq.toList
             { Size = size
-              Seed = seed }
+              Seed = seed
+              ShrinkPath = path }
         with e ->
             raise (ArgumentException("Failed to deserialize RecheckData", e))
 
@@ -117,6 +133,12 @@ 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 ->
             ()

tests/Hedgehog.Tests/ReportTests.fs

@@ -9,9 +9,13 @@ let reportTests = testList "Report tests" [
     testCase "Roundtrip RecheckData serialization" <| fun () ->
         property {
             let! size = Range.linear 0 1000 |> Gen.int32
+            let! path =
+                Gen.item [ ShrinkOutcome.Fail; ShrinkOutcome.Pass ]
+                |> Gen.list (Range.linear 0 10)
             let expected = {
                 Size = size
-                Seed = Seed.random () }
+                Seed = Seed.random ()
+                ShrinkPath = path }
             let actual =
                 expected
                 |> RecheckData.serialize