Merge pull request #336 from TysonMN/feature/332_recheck_one_input

Only recheck shrunken input

CHANGELOG.md

@@ -5,6 +5,7 @@
   - 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`.
 - Change recheck API to accept recheck data encoded as `string` ([#385][385], [@TysonMN][TysonMN])
 - Add `RecheckInfo` to simplify recheck reporting ([#386][386], [@TysonMN][TysonMN])
+- Optimize rechecking by only executing the end of the `property` CE with the shrunken input ([#336][336], [@TysonMN][TysonMN])
 
 ## Version 0.11.1 (2021-11-19)
 
@@ -234,6 +235,8 @@
   https://github.com/hedgehogqa/fsharp-hedgehog/pull/338
 [337]:
   https://github.com/hedgehogqa/fsharp-hedgehog/pull/337
+[336]:
+  https://github.com/hedgehogqa/fsharp-hedgehog/pull/336
 [334]:
   https://github.com/hedgehogqa/fsharp-hedgehog/pull/334
 [328]:

src/Hedgehog/GenLazy.fs

@@ -0,0 +1,15 @@
+// Workaround for a Fable issue: https://github.com/fable-compiler/Fable/issues/2069
+#if FABLE_COMPILER
+module Hedgehog.GenLazy
+#else
+[<RequireQualifiedAccess>]
+module internal Hedgehog.GenLazy
+#endif
+
+let constant a = a |> Lazy.constant |> Gen.constant
+
+let map f = f |> Lazy.map |> Gen.map
+
+let join glgla = glgla |> Gen.bind Lazy.value
+
+let bind f gla = gla |> map f |> join

src/Hedgehog/GenLazyTuple.fs

@@ -0,0 +1,10 @@
+// Workaround for a Fable issue: https://github.com/fable-compiler/Fable/issues/2069
+#if FABLE_COMPILER
+module Hedgehog.GenLazyTuple
+#else
+[<RequireQualifiedAccess>]
+module internal Hedgehog.GenLazyTuple
+#endif
+
+let mapFst f = f |> Tuple.mapFst |> GenLazy.map
+let mapSnd f = f |> Tuple.mapSnd |> GenLazy.map

src/Hedgehog/Hedgehog.fsproj

@@ -1,4 +1,4 @@
-<?xml version="1.0" encoding="utf-8"?>
+<?xml version="1.0" encoding="utf-8"?>
 <Project Sdk="Microsoft.NET.Sdk">
   <PropertyGroup>
     <TargetFrameworks>netstandard1.6;netstandard2.0;net45</TargetFrameworks>
@@ -32,6 +32,7 @@ https://github.com/hedgehogqa/fsharp-hedgehog/blob/master/doc/index.md
       <_Parameter1>Hedgehog.Linq.Tests</_Parameter1>
     </AssemblyAttribute>
     <Compile Include="AutoOpen.fs" />
+    <Compile Include="Lazy.fs" />
     <Compile Include="Numeric.fs" />
     <Compile Include="Seed.fs" />
     <Compile Include="Seq.fs" />
@@ -44,7 +45,8 @@ 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="GenTuple.fs" />
+    <Compile Include="GenLazy.fs" />
+    <Compile Include="GenLazyTuple.fs" />
     <Compile Include="Outcome.fs" />
     <Compile Include="Report.fs" />
     <Compile Include="PropertyArgs.fs" />

src/Hedgehog/Lazy.fs

@@ -0,0 +1,24 @@
+// Workaround for a Fable issue: https://github.com/fable-compiler/Fable/issues/2069
+#if FABLE_COMPILER
+module Hedgehog.Lazy
+#else
+[<RequireQualifiedAccess>]
+module internal Hedgehog.Lazy
+#endif
+
+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> =
+    (fun () -> ma.Value |> f)
+    |> func
+
+let join (mma: Lazy<Lazy<'a>>) =
+    (fun () -> mma.Value.Value)
+    |> func
+
+let bind (f: 'a -> Lazy<'b>) =
+    f |> map >> join

src/Hedgehog/Linq/Property.fs

@@ -21,7 +21,7 @@ type Property = private Property of Property<unit> with
     static member FromBool (value : bool) : Property =
         value |> Property.ofBool |> Property
 
-    static member FromGen (gen : Gen<Journal * Outcome<'T>>) : Property<'T> =
+    static member FromGen (gen : Gen<Lazy<Journal * Outcome<'T>>>) : Property<'T> =
         Property.ofGen gen
 
     static member FromOutcome (result : Outcome<'T>) : Property<'T> =
@@ -49,7 +49,7 @@ type Property = private Property of Property<unit> with
 type PropertyExtensions private () =
 
     [<Extension>]
-    static member ToGen (property : Property<'T>) : Gen<Journal * Outcome<'T>> =
+    static member ToGen (property : Property<'T>) : Gen<Lazy<Journal * Outcome<'T>>> =
         Property.toGen property
 
     [<Extension>]

src/Hedgehog/Property.fs

@@ -5,15 +5,15 @@ open System
 
 [<Struct>]
 type Property<'a> =
-    | Property of Gen<Journal * Outcome<'a>>
+    | Property of Gen<Lazy<Journal * Outcome<'a>>>
 
 
 module Property =
 
-    let ofGen (x : Gen<Journal * Outcome<'a>>) : Property<'a> =
+    let ofGen (x : Gen<Lazy<Journal * Outcome<'a>>>) : Property<'a> =
         Property x
 
-    let toGen (Property x : Property<'a>) : Gen<Journal * Outcome<'a>> =
+    let toGen (Property x : Property<'a>) : Gen<Lazy<Journal * Outcome<'a>>> =
         x
 
     let tryFinally (after : unit -> unit) (m : Property<'a>) : Property<'a> =
@@ -37,10 +37,10 @@ module Property =
                 x.Dispose ())
 
     let filter (p : 'a -> bool) (m : Property<'a>) : Property<'a> =
-        GenTuple.mapSnd (Outcome.filter p) (toGen m) |> ofGen
+        m |> toGen |> GenLazyTuple.mapSnd (Outcome.filter p) |> ofGen
 
     let ofOutcome (x : Outcome<'a>) : Property<'a> =
-        (Journal.empty, x) |> Gen.constant |> ofGen
+        (Journal.empty, x) |> GenLazy.constant |> ofGen
 
     let failure : Property<unit> =
         Failure |> ofOutcome
@@ -58,43 +58,37 @@ module Property =
             failure
 
     let counterexample (msg : unit -> string) : Property<unit> =
-        (Journal.singleton msg, Success ()) |> Gen.constant |> ofGen
-
-    let private mapGen
-            (f : Gen<Journal * Outcome<'a>> -> Gen<Journal * Outcome<'b>>)
-            (p : Property<'a>) : Property<'b> =
-        p |> toGen |> f |> ofGen
+        (Journal.singleton msg, Success ()) |> GenLazy.constant |> ofGen
 
     let map (f : 'a -> 'b) (x : Property<'a>) : Property<'b> =
         let g (j, outcome) =
             try
                 (j, outcome |> Outcome.map f)
             with e ->
                 (Journal.append j (Journal.singletonMessage (string e)), Failure)
-        let h = g |> Gen.map |> mapGen
-        h x
+        x |> toGen |> GenLazy.map g |> ofGen
 
     let internal set (a: 'a) (property : Property<'b>) : Property<'a> =
         property |> map (fun _ -> a)
 
     let private bindGen
-            (k : 'a -> Gen<Journal * Outcome<'b>>)
-            (m : Gen<Journal * Outcome<'a>>) : Gen<Journal * Outcome<'b>> =
-        m |> Gen.bind (fun (journal, result) ->
+            (f : 'a -> Gen<Lazy<Journal * Outcome<'b>>>)
+            (m : Gen<Lazy<Journal * Outcome<'a>>>) : Gen<Lazy<Journal * Outcome<'b>>> =
+        m |> GenLazy.bind (fun (journal, result) ->
             match result with
             | Failure ->
-                Gen.constant (journal, Failure)
+                GenLazy.constant (journal, Failure)
             | Discard ->
-                Gen.constant (journal, Discard)
-            | Success x ->
-                GenTuple.mapFst (Journal.append journal) (k x))
+                GenLazy.constant (journal, Discard)
+            | Success a ->
+                GenLazyTuple.mapFst (Journal.append journal) (f a))
 
     let bind (k : 'a -> Property<'b>) (m : Property<'a>) : Property<'b> =
         let kTry a =
             try
                 k a |> toGen
             with e ->
-                (Journal.singletonMessage (string e), Failure) |> Gen.constant
+                (Journal.singletonMessage (string e), Failure) |> GenLazy.constant
         m
         |> toGen
         |> bindGen kTry
@@ -140,27 +134,51 @@ module Property =
     //
 
     let private shrinkInput
-            (language: Language option)
-            (recheckData : RecheckData)
+            (language: Language)
+            (data : RecheckData)
             (shrinkLimit : int<shrinks> Option) =
         let rec loop
                 (nshrinks : int<shrinks>)
-                (Node ((journal, _), xs) : Tree<Journal * Outcome<'a>>) =
+                (shrinkPath : ShrinkOutcome list)
+                (Node (root, xs) : Tree<Lazy<Journal * Outcome<'a>>>) =
+            let journal = root.Value |> fst
+            let recheckData = { data with ShrinkPath = shrinkPath }
             let failed =
                 Failed {
                     Shrinks = nshrinks
                     Journal = journal
-                    RecheckInfo = language |> Option.map (fun lang -> { Language = lang; Data = recheckData })
-                }
-            match shrinkLimit, Seq.tryFind (Tree.outcome >> snd >> Outcome.isFailure) xs with
+                    RecheckInfo =
+                        Some { Language = language
+                               Data = recheckData } }
+            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 rec private followShrinkPath
+            (Node (root, children) : Tree<Lazy<Journal * Outcome<'a>>>) =
+        let rec skipPassedChild children shrinkPath =
+            match children, shrinkPath with
+            | _, [] ->
+                Failed {
+                    Shrinks = 0<shrinks>
+                    Journal = root.Value |> fst
+                    RecheckInfo = None
+                }
+            | [], _ -> failwith "The shrink path lead to a dead end. This should never happen."
+            | _ :: childrenTail, ShrinkOutcome.Pass :: shrinkPathTail -> skipPassedChild  childrenTail shrinkPathTail
+            | childrenHead :: _, ShrinkOutcome.Fail :: shrinkPathTail -> followShrinkPath childrenHead shrinkPathTail
+        skipPassedChild (Seq.toList children)
 
-    let private reportWith' (args : PropertyArgs) (config : PropertyConfig) (p : Property<unit>) : Report =
-        let random = toGen p |> Gen.toRandom
+    let private splitAndRun p data =
+        let seed1, seed2 = Seed.split data.Seed
+        let result = p |> toGen |> Gen.toRandom |> Random.run seed1 data.Size
+        result, seed2
 
+    let private reportWith' (args : PropertyArgs) (config : PropertyConfig) (p : Property<unit>) : Report =
         let nextSize size =
             if size >= 100 then
                 1
@@ -177,15 +195,14 @@ module Property =
                   Discards = discards
                   Status = GaveUp }
             else
-                let seed1, seed2 = Seed.split data.Seed
-                let result = Random.run seed1 data.Size random
+                let result, seed2 = splitAndRun p data
                 let nextData = {
                     data with
                         Seed = seed2
                         Size = nextSize data.Size
                 }
 
-                match snd (Tree.outcome result) with
+                match snd (Tree.outcome result).Value with
                 | Failure ->
                     { Tests = tests + 1<tests>
                       Discards = discards
@@ -222,12 +239,11 @@ module Property =
         g |> falseToFailure |> checkWith config
 
     let reportRecheckWith (recheckData: string) (config : PropertyConfig) (p : Property<unit>) : Report =
-        let args = {
-            PropertyArgs.init with
-                Language = None
-                RecheckData = recheckData |> RecheckData.deserialize
-        }
-        p |> reportWith' args config
+        let recheckData = recheckData |> RecheckData.deserialize
+        let result, _ = splitAndRun p recheckData
+        { Tests = 1<tests>
+          Discards = 0<discards>
+          Status = followShrinkPath result recheckData.ShrinkPath }
 
     let reportRecheck (recheckData: string) (p : Property<unit>) : Report =
         p |> reportRecheckWith recheckData PropertyConfig.defaultConfig
@@ -310,7 +326,7 @@ module PropertyBuilder =
 
         member __.BindReturn(m : Gen<'a>, f: 'a -> 'b) =
             m
-            |> Gen.map (fun a -> (Journal.empty, Success a))
+            |> Gen.map (fun a -> Lazy.constant (Journal.empty, Success a))
             |> Property.ofGen
             |> Property.map f
 

src/Hedgehog/PropertyArgs.fs

@@ -2,16 +2,17 @@ namespace Hedgehog
 
 [<Struct>]
 type PropertyArgs = internal {
-    Language : Language option
+    Language : Language
     RecheckData : RecheckData
 }
 
 module PropertyArgs =
 
     let init = {
-        Language = Some Language.FSharp
+        Language = Language.FSharp
         RecheckData = {
             Size = 0
             Seed = Seed.random ()
+            ShrinkPath = []
         }
     }

src/Hedgehog/Report.fs

@@ -3,11 +3,17 @@ namespace Hedgehog
 [<Measure>] type tests
 [<Measure>] type discards
 [<Measure>] type shrinks
+
+[<RequireQualifiedAccess>]
+type ShrinkOutcome =
+    | Pass
+    | Fail
 
 [<Struct>]
 type RecheckData = internal {
     Size : Size
     Seed : Seed
+    ShrinkPath : ShrinkOutcome list
 }
 
 [<RequireQualifiedAccess>]
@@ -47,7 +53,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 -> "0" | ShrinkOutcome.Pass -> "1" )
+          |> String.concat "" ]
         |> String.concat separator
 
     let deserialize (s: string) =
@@ -57,8 +66,15 @@ module internal RecheckData =
             let seed =
                 { Value = parts.[1] |> UInt64.Parse
                   Gamma = parts.[2] |> UInt64.Parse }
+            let path =
+                parts.[3]
+                |> Seq.map (function '0' -> ShrinkOutcome.Fail
+                                   | '1' -> ShrinkOutcome.Pass
+                                   |  c  -> failwithf "Unexpected character %c in shrink path" c)
+                |> Seq.toList
             { Size = size
-              Seed = seed }
+              Seed = seed
+              ShrinkPath = path }
         with e ->
             raise (ArgumentException("Failed to deserialize RecheckData", e))