Skip to content

Commit

Permalink
Test is not Arbitrary
Browse files Browse the repository at this point in the history
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.
  • Loading branch information
nwf committed Dec 31, 2024
1 parent 80f475c commit c357f27
Show file tree
Hide file tree
Showing 2 changed files with 15 additions and 13 deletions.
2 changes: 1 addition & 1 deletion src/QuickCheckVEngine/MainHelpers.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand Down
26 changes: 14 additions & 12 deletions src/QuickCheckVEngine/Test.hs
Original file line number Diff line number Diff line change
Expand Up @@ -66,6 +66,8 @@ module QuickCheckVEngine.Test (
, gatherReports
, filterTest
, showTestWithComments
-- **
, shrinkTest
) where

import Test.QuickCheck
Expand All @@ -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]
Expand Down

0 comments on commit c357f27

Please sign in to comment.