From c357f2757b677e85b522a877925c5b1c5da99612 Mon Sep 17 00:00:00 2001
From: Nathaniel Wesley Filardo <wes.filardo@scisemi.com>
Date: Tue, 31 Dec 2024 19:56:09 +0000
Subject: [PATCH] Test is not Arbitrary

This was just being used for its shrink function, and in exactly one
place, so just give that function a name and use it directly.
---
 src/QuickCheckVEngine/MainHelpers.hs |  2 +-
 src/QuickCheckVEngine/Test.hs        | 26 ++++++++++++++------------
 2 files changed, 15 insertions(+), 13 deletions(-)

diff --git a/src/QuickCheckVEngine/MainHelpers.hs b/src/QuickCheckVEngine/MainHelpers.hs
index c9458f7..92330e4 100644
--- a/src/QuickCheckVEngine/MainHelpers.hs
+++ b/src/QuickCheckVEngine/MainHelpers.hs
@@ -172,7 +172,7 @@ runImpls connA m_connB alive delay verbosity saveDir test onTrace onFirstDeath o
 prop :: RvfiDiiConnection -> Maybe RvfiDiiConnection -> IORef Bool -> (Test TestResult -> IO ())
      -> ArchDesc -> Int -> Int -> Maybe FilePath -> Bool -> Bool -> Gen (Test TestResult) -> Property
 prop connA m_connB alive onFail arch delay verbosity saveDir ignoreAsserts strict gen =
-  forAllShrink gen shrink mkProp
+  forAllShrink gen shrinkTest mkProp
   where mkProp test = whenFail (onFail test) (doProp test)
         doProp test = monadicIO $ run $ runImpls connA m_connB alive delay verbosity saveDir test onTrace onFirstDeath onSubsequentDeaths
         colourGreen = "\ESC[32m"
diff --git a/src/QuickCheckVEngine/Test.hs b/src/QuickCheckVEngine/Test.hs
index 0638737..ee8b143 100644
--- a/src/QuickCheckVEngine/Test.hs
+++ b/src/QuickCheckVEngine/Test.hs
@@ -66,6 +66,8 @@ module QuickCheckVEngine.Test (
 , gatherReports
 , filterTest
 , showTestWithComments
+-- **
+, shrinkTest
 ) where
 
 import Test.QuickCheck
@@ -83,18 +85,18 @@ import Data.List
 -- * Test shrinking
 --------------------------------------------------------------------------------
 
-instance Arbitrary (Test TestResult) where
-  arbitrary = return TestEmpty
-  shrink TestEmpty = []
-  shrink (TestSingle x) = []
-  shrink (TestSequence x y) = let xs = shrink x
-                                  ys = shrink y
-                              in    [TestSequence x' y  | x' <- xs]
-                                 ++ [TestSequence x  y' | y' <- ys]
-  shrink (TestMeta (MetaNoShrink, _) _) = []
-  shrink (TestMeta m@(MetaShrinkStrategy f, _) x) =
-    TestMeta m <$> (f x ++ shrink x)
-  shrink (TestMeta m x) = TestMeta m <$> shrink x
+shrinkTest = go
+ where
+  go TestEmpty = []
+  go (TestSingle x) = []
+  go (TestSequence x y) = let xs = go x
+                              ys = go y
+                          in    [TestSequence x' y  | x' <- xs]
+                             ++ [TestSequence x  y' | y' <- ys]
+  go (TestMeta (MetaNoShrink, _) _) = []
+  go (TestMeta m@(MetaShrinkStrategy f, _) x) =
+    TestMeta m <$> (f x ++ go x)
+  go (TestMeta m x) = TestMeta m <$> go x
 
 data ShrinkMethods =
   MkShrinkMethods { methodSingle :: TestResult -> [Test TestResult]