Added maxShrinks

hedgehogqa · Jan 24, 2021 · 1ad0e77 · 1ad0e77
1 parent 4f68106
commit 1ad0e77
Show file tree

Hide file tree

Showing 3 changed files with 73 additions and 17 deletions.
diff --git a/src/Hedgehog/Linq/Property.fs b/src/Hedgehog/Linq/Property.fs
@@ -74,6 +74,11 @@ type PropertyExtensions private () =
         let (Property property) = property
         Property.report property
 
+    [<Extension>]
+    static member Report (property : Property, tests : int<tests>, maxShrinks : int<shrinks>) : Report =
+        let (Property property) = property
+        Property.report'' tests maxShrinks property
+
     [<Extension>]
     static member Report (property : Property, tests : int<tests>) : Report =
         let (Property property) = property
@@ -87,11 +92,20 @@ type PropertyExtensions private () =
     static member Report (property : Property<bool>, tests : int<tests>) : Report =
         Property.reportBool' tests property
 
+    [<Extension>]
+    static member Report (property : Property<bool>, tests : int<tests>, maxShrinks : int<shrinks>) : Report =
+        Property.reportBool'' tests maxShrinks property
+
     [<Extension>]
     static member Check (property : Property) : unit =
         let (Property property) = property
         Property.check property
 
+    [<Extension>]
+    static member Check (property : Property, tests : int<tests>, maxShrinks : int<shrinks>) : unit =
+        let (Property property) = property
+        Property.check'' tests maxShrinks property
+
     [<Extension>]
     static member Check (property : Property, tests : int<tests>) : unit =
         let (Property property) = property
@@ -105,6 +119,10 @@ type PropertyExtensions private () =
     static member Check (property : Property<bool>, tests : int<tests>) : unit =
         Property.checkBool' tests property
 
+    [<Extension>]
+    static member Check (property : Property<bool>, tests : int<tests>, maxShrinks : int<shrinks>) : unit =
+        Property.checkBool'' tests maxShrinks property
+
     [<Extension>]
     static member Recheck (property : Property, size : Size, seed : Seed) : unit =
         let (Property property) = property

diff --git a/src/Hedgehog/Property.fs b/src/Hedgehog/Property.fs
@@ -100,26 +100,34 @@ module Property =
             (size : Size)
             (seed : Seed)
             (Node ((journal, x), xs) : Tree<Journal * Outcome<'a>>)
-            (nshrinks : int<shrinks>) : Status =
+            (nshrinks : int<shrinks>) 
+            (maxShrinks : int<shrinks> Option) : Status =
+        let failed =
+            Failed {
+                Size = size
+                Seed = seed
+                Shrinks = nshrinks
+                Journal = journal
+                RenderRecheck = renderRecheck
+            }
+        let takeSmallest tree = takeSmallest renderRecheck size seed tree (nshrinks + 1<shrinks>) maxShrinks
         match x with
         | Failure ->
             match Seq.tryFind (Outcome.isFailure << snd << Tree.outcome) xs with
-            | None ->
-                Failed {
-                    Size = size
-                    Seed = seed
-                    Shrinks = nshrinks
-                    Journal = journal
-                    RenderRecheck = renderRecheck
-                }
+            | None -> failed
             | Some tree ->
-                takeSmallest renderRecheck size seed tree (nshrinks + 1<shrinks>)
+                match maxShrinks with
+                | None -> takeSmallest tree
+                | Some maxShrinks' ->
+                    if nshrinks < maxShrinks' then
+                        takeSmallest tree
+                    else failed
         | Discard ->
             GaveUp
         | Success _ ->
             OK
 
-    let private reportWith' (renderRecheck : bool) (size0 : Size) (seed : Seed) (n : int<tests>) (p : Property<unit>) : Report =
+    let private reportWith' (renderRecheck : bool) (size0 : Size) (seed : Seed) (n : int<tests>) maxShrinks (p : Property<unit>) : Report =
         let random = toGen p |> Gen.toRandom
 
         let nextSize size =
@@ -145,30 +153,41 @@ module Property =
                 | Failure ->
                     { Tests = tests + 1<tests>
                       Discards = discards
-                      Status = takeSmallest renderRecheck size seed result 0<shrinks> }
+                      Status = takeSmallest renderRecheck size seed result 0<shrinks> maxShrinks}
                 | Success () ->
                     loop seed2 (nextSize size) (tests + 1<tests>) discards
                 | Discard ->
                     loop seed2 (nextSize size) tests (discards + 1<discards>)
 
         loop seed size0 0<tests> 0<discards>
 
-    let private reportWith (renderRecheck : bool) (size : Size) (seed : Seed) (p : Property<unit>) : Report =
-        reportWith' renderRecheck size seed 100<tests> p
+    let private reportWith (renderRecheck : bool) (size : Size) (seed : Seed) maxShrinks (p : Property<unit>) : Report =
+        reportWith' renderRecheck size seed 100<tests> maxShrinks p
+
+    let report'' (n : int<tests>) (maxShrinks : int<shrinks>) (p : Property<unit>) : Report =
+        let seed = Seed.random ()
+        reportWith' true 1 seed n (Some maxShrinks) p
 
     let report' (n : int<tests>) (p : Property<unit>) : Report =
         let seed = Seed.random ()
-        reportWith' true 1 seed n p
+        reportWith' true 1 seed n None p
 
     let report (p : Property<unit>) : Report =
         report' 100<tests> p
 
+    let reportBool'' (n : int<tests>) (maxShrinks : int<shrinks>) (p : Property<bool>) : Report =
+        bind p ofBool |> report'' n maxShrinks
+
     let reportBool' (n : int<tests>) (p : Property<bool>) : Report =
         bind p ofBool |> report' n
 
     let reportBool (p : Property<bool>) : Report =
         bind p ofBool |> report
 
+    let check'' (n : int<tests>) (maxShrinks : int<shrinks>) (p : Property<unit>) : unit =
+        report'' n maxShrinks p
+        |> Report.tryRaise
+
     let check' (n : int<tests>) (p : Property<unit>) : unit =
         report' n p
         |> Report.tryRaise
@@ -177,6 +196,10 @@ module Property =
         report p
         |> Report.tryRaise
 
+    let checkBool'' (n : int<tests>) (maxShrinks : int<shrinks>) (p : Property<bool>) : unit =
+        reportBool'' n maxShrinks p
+        |> Report.tryRaise
+
     let checkBool (g : Property<bool>) : unit =
         bind g ofBool |> check
 
@@ -193,10 +216,10 @@ module Property =
         | _ -> failure
 
     let reportRecheck' (size : Size) (seed : Seed) (n : int<tests>) (p : Property<unit>) : Report =
-        reportWith' false size seed n p
+        reportWith' false size seed n None p
 
     let reportRecheck (size : Size) (seed : Seed) (p : Property<unit>) : Report =
-        reportWith false size seed p
+        reportWith false size seed None p
 
     let reportRecheckBool' (size : Size) (seed : Seed) (n : int<tests>) (p : Property<bool>) : Report =
         bind p ofBool |> reportRecheck' size seed n

diff --git a/tests/Hedgehog.Tests/ShrinkTests.fs b/tests/Hedgehog.Tests/ShrinkTests.fs
@@ -232,3 +232,18 @@ let ``towardsDouble returns empty list when run out of shrinks`` x0 destination
         |> Shrink.towards destination
         |> Seq.toList
     test <@ actual |> List.isEmpty @>
+
+[<Theory>]
+[<InlineData(0)>]
+[<InlineData(1)>]
+[<InlineData(2)>]
+let ``Property.report'' respects its maxShrinks`` maxShrinks =
+    let report =
+        property {
+            let! actual = Range.linear 1 1_000_000 |> Gen.int
+            return actual < 500_000
+        } |> Property.report'' 100<tests> maxShrinks
+    match report.Status with
+    | Failed failureData ->
+        failureData.Shrinks =! maxShrinks
+    | _ -> failwith "impossible"