From b0743573bb40fe0eeaffbb6bb80d7eddd0208514 Mon Sep 17 00:00:00 2001
From: Kurt Schelfthout <kurt.schelfthout@gmail.com>
Date: Sat, 8 May 2021 17:02:22 +0100
Subject: [PATCH] Avoid infinite loop during shrinking. (#570)

---
 FsCheck Release Notes.md     |  2 ++
 src/FsCheck/Runner.fs        | 35 +++++++++++++++++++++++++++--------
 tests/FsCheck.Test/Runner.fs | 23 ++++++++++++++++++++++-
 3 files changed, 51 insertions(+), 9 deletions(-)

diff --git a/FsCheck Release Notes.md b/FsCheck Release Notes.md
index aad1ba18..077b7054 100644
--- a/FsCheck Release Notes.md	
+++ b/FsCheck Release Notes.md	
@@ -2,6 +2,8 @@
 
 * Allow shrinking private unions. (by Sander van Dijk)
 
+* Limit total number of shrink attempts to 5000, to avoid infinite loops in general, and in particular if an argument is mutated in the test.
+
 ### 2.15.2 - 15 Arpil 2021
 
 * Enabled FsCheck.Xunit's `PropertiesAttribute` to work at assembly level. (by Laurence King)
diff --git a/src/FsCheck/Runner.fs b/src/FsCheck/Runner.fs
index a5835aa2..676898fb 100644
--- a/src/FsCheck/Runner.fs
+++ b/src/FsCheck/Runner.fs
@@ -138,15 +138,19 @@ module Runner =
                 | Passed _ -> TestResult.True (testData, config.QuietOnSuccess)
                 | Falsified result -> TestResult.False ({ testData with Labels=result.Labels}, origArgs, result.Arguments, result.Outcome, usedSeed)
                 | Failed _ -> TestResult.Exhausted testData
+                // this means we gave up shrinking
+                | Shrink result | NoShrink result -> TestResult.False ({ testData with Labels=result.Labels}, origArgs, result.Arguments, result.Outcome, usedSeed)
                 | EndShrink result -> TestResult.False ({ testData with Labels=result.Labels}, origArgs, result.Arguments, result.Outcome, usedSeed)
                 | _ -> failwith "Test ended prematurely"
         config.Runner.OnFinished(config.Name,testResult)
 
     let private runner config prop = 
+        // this would ideallyl be a config value, but config is hard to extend right now
+        let maxTotalShrinkNb = 5000
         let testNb = ref 0
         let failedNb = ref 0
         let shrinkNb = ref 0
-        let tryShrinkNb = ref 0
+        let totalShrinkNb = ref 0
         let origArgs = ref []
         let lastStep = ref (Failed Res.rejected)
         let seed = match config.Replay with None -> newSeed() | Some s -> s
@@ -156,13 +160,28 @@ module Runner =
             lastStep := step
             //printfn "%A" step
             match step with
-                | Generated args -> config.Runner.OnArguments(!testNb, args, config.Every); true
-                | Passed _ -> testNb := !testNb + 1; !testNb <> config.MaxTest //stop if we have enough tests
-                | Falsified result -> origArgs := result.Arguments; testNb := !testNb + 1; true //falsified, true to continue with shrinking
-                | Failed _ -> failedNb := !failedNb + 1; !failedNb <> config.MaxFail //failed, stop if we have too much failed tests
-                | Shrink result -> tryShrinkNb := 0; shrinkNb := !shrinkNb + 1; config.Runner.OnShrink(result.Arguments, config.EveryShrink); true
-                | NoShrink _ -> tryShrinkNb := !tryShrinkNb + 1; true
-                | EndShrink _ -> false )
+                | Generated args -> 
+                    config.Runner.OnArguments(!testNb, args, config.Every)
+                    true
+                | Passed _ ->
+                    testNb := !testNb + 1
+                    !testNb <> config.MaxTest //stop if we have enough tests
+                | Falsified result ->
+                    origArgs := result.Arguments
+                    testNb := !testNb + 1
+                    true //falsified, true to continue with shrinking
+                | Failed _ ->
+                    failedNb := !failedNb + 1
+                    !failedNb <> config.MaxFail //failed, stop if we have too much failed tests
+                | Shrink result ->
+                    totalShrinkNb := !totalShrinkNb + 1
+                    shrinkNb := !shrinkNb + 1
+                    config.Runner.OnShrink(result.Arguments, config.EveryShrink)
+                    !totalShrinkNb < maxTotalShrinkNb
+                | NoShrink _ ->
+                    totalShrinkNb := !totalShrinkNb + 1
+                    !totalShrinkNb < maxTotalShrinkNb
+                | EndShrink _ -> false)
         |> Seq.fold (fun acc elem ->
             match elem with
                 | Passed result -> (result.Stamp :: acc)
diff --git a/tests/FsCheck.Test/Runner.fs b/tests/FsCheck.Test/Runner.fs
index fa3f8ff4..e00ed546 100644
--- a/tests/FsCheck.Test/Runner.fs
+++ b/tests/FsCheck.Test/Runner.fs
@@ -324,4 +324,25 @@ module BugReproIssue514 =
             let testMethod = TestMethod(testClass, methodInfo)
             let testCase = new PropertyTestCase(null, TestMethodDisplay.ClassAndMethod, testMethod)
             testCase.RunAsync(null, new TestMessageBus(), [||], new ExceptionAggregator(), new CancellationTokenSource()) |> Async.AwaitTask |> ignore
-            Check.One(Config.Quick, disposed)
\ No newline at end of file
+            Check.One(Config.Quick, disposed)
+
+
+module ShrinkingMutatedTypes =
+    open Xunit
+    open Swensen.Unquote
+    open FsCheck
+
+
+    type Member () =
+        member val Name = "" with get, set
+
+    
+    let mutateMember (m:Member)  =
+        m.Name <- "1"
+        m.Name = "0"
+
+    [<Fact>]
+    let ``should not loop infinitely when shrinking mutated value``() =
+        raisesWith <@ Check.QuickThrowOnFailure(mutateMember) @> (fun e -> <@ e.Message.Contains("5000 shrinks") @>)
+            
+