From c569c61d6d7e10b6b94eebec1eab0486c7a9c1b6 Mon Sep 17 00:00:00 2001 From: Phil Hazelden Date: Thu, 25 May 2023 09:20:11 +0100 Subject: [PATCH] Fix test skipping when tests have been discarded. Closes #487. In #454 we introduced test skipping, with the idea that a failed test could report a way for you to jump back to reproduce it without all the preceding tests. But it didn't work if any of the preceding tests had been discarded, because each discard also changes the seed and the size. Users could manually add the discard count to the test count in the `Skip`, but that's no fun. Plus, it wouldn't work if the test count plus discard count exceeded the test limit, because that would generate a success without running any tests. So now a `Skip` (other than `SkipNothing`) includes a `DiscardCount` as well as a `TestCount`. It's rendered in the compressed path as `testCount/discardCount`, or just `testCount` if `discardCount` is 0. The exact sequence of passing tests and discards doesn't affect the final seed or size, so the counts are all we need. This changes an exposed type, so PVP requires a major version bump. --- CHANGELOG.md | 3 +- hedgehog/src/Hedgehog/Internal/Property.hs | 41 ++++--- hedgehog/src/Hedgehog/Internal/Report.hs | 10 +- hedgehog/src/Hedgehog/Internal/Runner.hs | 15 +-- hedgehog/test/Test/Hedgehog/Skip.hs | 118 ++++++++++++++------- 5 files changed, 123 insertions(+), 64 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 54d7d9da..7b6dcb6b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,7 @@ -## Version 1.2.1 (unreleased) +## Version 1.3 (unreleased) * Export `Hedgehog.Internal.Seed.seed` ([#477][477], [@sol][sol]) +* Fix skipping to tests/shrinks when tests have been discarded ## Version 1.2 (2022-08-28) diff --git a/hedgehog/src/Hedgehog/Internal/Property.hs b/hedgehog/src/Hedgehog/Internal/Property.hs index c901550d..915b3780 100644 --- a/hedgehog/src/Hedgehog/Internal/Property.hs +++ b/hedgehog/src/Hedgehog/Internal/Property.hs @@ -312,7 +312,7 @@ newtype TestCount = -- newtype DiscardCount = DiscardCount Int - deriving (Eq, Ord, Show, Num, Enum, Real, Integral) + deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift) -- | The number of discards to allow before giving up. -- @@ -355,7 +355,10 @@ data Skip = -- | Skip to a specific test number. If it fails, shrink as normal. If it -- passes, move on to the next test. Coverage checks are disabled. -- - | SkipToTest TestCount + -- We also need to count discards, since failing "after 7 tests" points at a + -- different generated value than failing "after 7 tests and 5 discards". + -- + | SkipToTest TestCount DiscardCount -- | Skip to a specific test number and shrink state. If it fails, stop -- without shrinking further. If it passes, the property will pass without @@ -365,7 +368,7 @@ data Skip = -- the direct path from the original test input to the target state - will -- be tested too, and their results discarded. -- - | SkipToShrink TestCount ShrinkPath + | SkipToShrink TestCount DiscardCount ShrinkPath deriving (Eq, Ord, Show, Lift) -- | We use this instance to support usage like @@ -402,13 +405,17 @@ newtype ShrinkPath = -- roughly interpret it by eyeball. -- skipCompress :: Skip -> String -skipCompress = \case - SkipNothing -> - "" - SkipToTest (TestCount n) -> - show n - SkipToShrink (TestCount n) sp -> - show n ++ ":" ++ shrinkPathCompress sp +skipCompress = + let + showTD (TestCount t) (DiscardCount d) = + show t ++ (if d == 0 then "" else "/" ++ show d) + in \case + SkipNothing -> + "" + SkipToTest t d-> + showTD t d + SkipToShrink t d sp -> + showTD t d ++ ":" ++ shrinkPathCompress sp -- | Compress a 'ShrinkPath' into a hopefully-short alphanumeric string. -- @@ -446,14 +453,22 @@ skipDecompress str = Just SkipNothing else do let - (tcStr, spStr) + (tcDcStr, spStr) = span (/= ':') str + + (tcStr, dcStr) + = span (/= '/') tcDcStr + tc <- TestCount <$> readMaybe tcStr + dc <- DiscardCount <$> if null dcStr + then Just 0 + else readMaybe (drop 1 dcStr) + if null spStr then - Just $ SkipToTest tc + Just $ SkipToTest tc dc else do sp <- shrinkPathDecompress $ drop 1 spStr - Just $ SkipToShrink tc sp + Just $ SkipToShrink tc dc sp -- | Decompress a 'ShrinkPath'. -- diff --git a/hedgehog/src/Hedgehog/Internal/Report.hs b/hedgehog/src/Hedgehog/Internal/Report.hs index ff7ad954..f5ed9d2b 100644 --- a/hedgehog/src/Hedgehog/Internal/Report.hs +++ b/hedgehog/src/Hedgehog/Internal/Report.hs @@ -622,8 +622,8 @@ ppTextLines :: String -> [Doc Markup] ppTextLines = fmap WL.text . List.lines -ppFailureReport :: MonadIO m => Maybe PropertyName -> TestCount -> Seed -> FailureReport -> m [Doc Markup] -ppFailureReport name tests seed (FailureReport _ shrinkPath mcoverage inputs0 mlocation0 msg mdiff msgs0) = do +ppFailureReport :: MonadIO m => Maybe PropertyName -> TestCount -> DiscardCount -> Seed -> FailureReport -> m [Doc Markup] +ppFailureReport name tests discards seed (FailureReport _ shrinkPath mcoverage inputs0 mlocation0 msg mdiff msgs0) = do let basic = -- Move the failure message to the end section if we have @@ -696,7 +696,7 @@ ppFailureReport name tests seed (FailureReport _ shrinkPath mcoverage inputs0 ml bottom = maybe - [ppReproduce name seed (SkipToShrink tests shrinkPath)] + [ppReproduce name seed (SkipToShrink tests discards shrinkPath)] (const []) mcoverage @@ -752,7 +752,7 @@ ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup) ppResult name (Report tests discards coverage seed result) = do case result of Failed failure -> do - pfailure <- ppFailureReport name tests seed failure + pfailure <- ppFailureReport name tests discards seed failure pure . WL.vsep $ [ icon FailedIcon '✗' . WL.align . WL.annotate FailedText $ ppName name <+> @@ -762,7 +762,7 @@ ppResult name (Report tests discards coverage seed result) = do ppShrinkDiscard (failureShrinks failure) discards <> "." <#> "shrink path:" <+> - ppSkip (SkipToShrink tests $ failureShrinkPath failure) + ppSkip (SkipToShrink tests discards $ failureShrinkPath failure) ] ++ ppCoverage tests coverage ++ pfailure diff --git a/hedgehog/src/Hedgehog/Internal/Runner.hs b/hedgehog/src/Hedgehog/Internal/Runner.hs index c4b883c3..f6785d2d 100644 --- a/hedgehog/src/Hedgehog/Internal/Runner.hs +++ b/hedgehog/src/Hedgehog/Internal/Runner.hs @@ -220,10 +220,10 @@ checkReport cfg size0 seed0 test0 updateUI = do case skip of SkipNothing -> (Nothing, Nothing) - SkipToTest t -> - (Just t, Nothing) - SkipToShrink t s -> - (Just t, Just s) + SkipToTest t d -> + (Just (t, d), Nothing) + SkipToShrink t d s -> + (Just (t, d), Just s) test = catchAny test0 (fail . show) @@ -335,8 +335,11 @@ checkReport cfg size0 seed0 test0 updateUI = do -- If the report says failed "after 32 tests", the test number that -- failed was 31, but we want the user to be able to skip to 32 and -- start with the one that failed. - (Just n, _) | n > tests + 1 -> - loop (tests + 1) discards (size + 1) s1 coverage0 + (Just (n, d), _) + | n > tests + 1 -> + loop (tests + 1) discards (size + 1) s1 coverage0 + | d > discards -> + loop tests (discards + 1) (size + 1) s1 coverage0 (Just _, Just shrinkPath) -> do node <- runTreeT . evalGenT size s0 . runTestT $ unPropertyT test diff --git a/hedgehog/test/Test/Hedgehog/Skip.hs b/hedgehog/test/Test/Hedgehog/Skip.hs index a8ef3957..92881110 100644 --- a/hedgehog/test/Test/Hedgehog/Skip.hs +++ b/hedgehog/test/Test/Hedgehog/Skip.hs @@ -7,6 +7,7 @@ module Test.Hedgehog.Skip where +import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) import Data.Foldable (for_) @@ -25,24 +26,27 @@ import Hedgehog.Internal.Report (Report(..), Result(..), FailureReport -- | We use this property to help test skipping. It keeps a log of every time it -- runs in the 'IORef' it's passed. -- --- It ignores its seed. It fails at size 2. When it shrinks, it initially --- shrinks to something that will pass, and then to something that will fail. +-- It ignores its seed. It discards at size 1 and fails at size 2. When it +-- shrinks, it initially shrinks to something that will pass, and then to +-- something that will fail. -- -skipTestProperty :: IORef [(Size, Int, Bool)] -> Property +skipTestProperty :: IORef [(Size, Int, Bool, Bool)] -> Property skipTestProperty logRef = withTests 5 . property $ do - val@(curSize, _, shouldPass) <- forAll $ do + val@(curSize, _, shouldDiscard, shouldPass) <- forAll $ do curSize <- Gen.sized pure - (shouldPass, nShrinks) <- - (,) - <$> Gen.shrink (\b -> if b then [] else [True]) (pure $ curSize /= 2) + (shouldDiscard, shouldPass, nShrinks) <- + (,,) + <$> pure (curSize == 1) + <*> Gen.shrink (\b -> if b then [] else [True]) (pure $ curSize /= 2) <*> Gen.shrink (\n -> reverse [0 .. n-1]) (pure 3) - pure (curSize, nShrinks, shouldPass) + pure (curSize, nShrinks, shouldDiscard, shouldPass) -- Fail coverage to make sure we disable it when shrinking. cover 100 "Not 4" (curSize /= 4) liftIO $ IORef.modifyIORef' logRef (val :) + when shouldDiscard discard assert shouldPass checkProp :: MonadIO m => Property -> m (Report Result) @@ -69,21 +73,22 @@ prop_SkipNothing = failureShrinks f === 3 failureShrinkPath f === ShrinkPath [1, 1, 1] - _ -> + _ -> do + annotateShow report failure logs <- liftIO $ reverse <$> IORef.readIORef logRef logs === - [ (0, 3, True) - , (1, 3, True) - , (2, 3, False) - , (2, 3, True) - , (2, 2, False) - , (2, 2, True) - , (2, 1, False) - , (2, 1, True) - , (2, 0, False) - , (2, 0, True) + [ (0, 3, False, True) + , (1, 3, True, True) + , (2, 3, False, False) + , (2, 3, False, True) + , (2, 2, False, False) + , (2, 2, False, True) + , (2, 1, False, False) + , (2, 1, False, True) + , (2, 0, False, False) + , (2, 0, False, True) ] prop_SkipToFailingTest :: Property @@ -105,14 +110,14 @@ prop_SkipToFailingTest = logs <- liftIO $ reverse <$> IORef.readIORef logRef logs === - [ (2, 3, False) - , (2, 3, True) - , (2, 2, False) - , (2, 2, True) - , (2, 1, False) - , (2, 1, True) - , (2, 0, False) - , (2, 0, True) + [ (2, 3, False, False) + , (2, 3, False, True) + , (2, 2, False, False) + , (2, 2, False, True) + , (2, 1, False, False) + , (2, 1, False, True) + , (2, 0, False, False) + , (2, 0, False, True) ] prop_SkipPastFailingTest :: Property @@ -127,7 +132,7 @@ prop_SkipPastFailingTest = reportStatus report === OK logs <- liftIO $ reverse <$> IORef.readIORef logRef - logs === [(3, 3, True), (4, 3, True)] + logs === [(3, 3, False, True), (4, 3, False, True)] prop_SkipToNoShrink :: Property prop_SkipToNoShrink = @@ -147,7 +152,7 @@ prop_SkipToNoShrink = failure logs <- liftIO $ reverse <$> IORef.readIORef logRef - logs === [(2, 3, False)] + logs === [(2, 3, False, False)] prop_SkipToFailingShrink :: Property prop_SkipToFailingShrink = @@ -167,7 +172,7 @@ prop_SkipToFailingShrink = failure logs <- liftIO $ reverse <$> IORef.readIORef logRef - logs === [(2, 3, False), (2, 2, False), (2, 1, False)] + logs === [(2, 3, False, False), (2, 2, False, False), (2, 1, False, False)] prop_SkipToPassingShrink :: Property prop_SkipToPassingShrink = @@ -181,7 +186,39 @@ prop_SkipToPassingShrink = reportStatus report === OK logs <- liftIO $ reverse <$> IORef.readIORef logRef - logs === [(2, 3, False), (2, 2, False), (2, 2, True)] + logs === [(2, 3, False, False), (2, 2, False, False), (2, 2, False, True)] + +prop_SkipToReportedShrink :: Property +prop_SkipToReportedShrink = + withTests 1 . property $ do + logRef <- liftIO $ IORef.newIORef [] + + report1 <- checkProp $ skipTestProperty logRef + failure1 <- case reportStatus report1 of + Failed f -> pure f + _ -> do + annotateShow report1 + failure + + let + skip = SkipToShrink (reportTests report1) + (reportDiscards report1) + (failureShrinkPath failure1) + + + report2 <- checkProp $ withSkip skip $ skipTestProperty logRef + failure2 <- case reportStatus report2 of + Failed f -> pure f + _ -> do + annotateShow report2 + failure + + failure1 === failure2 + + reportTests report1 === 2 + reportTests report2 === 2 + reportDiscards report1 === 1 + reportDiscards report2 === 1 genSkip :: Gen Skip genSkip = @@ -192,13 +229,16 @@ genSkip = genTestCount = Property.TestCount <$> Gen.int range + genDiscardCount = + Property.DiscardCount <$> Gen.int range + genShrinkPath = Property.ShrinkPath <$> Gen.list range (Gen.int range) in Gen.choice [ pure SkipNothing - , SkipToTest <$> genTestCount - , SkipToShrink <$> genTestCount <*> genShrinkPath + , SkipToTest <$> genTestCount <*> genDiscardCount + , SkipToShrink <$> genTestCount <*> genDiscardCount <*> genShrinkPath ] -- | Test that `skipCompress` and `skipDecompress` roundtrip. @@ -224,15 +264,15 @@ prop_compressDecompressExamples = -- strings that would decompress to the same Skip. testCases = [ (SkipNothing, "", []) - , (SkipToTest 3, "3", ["03", "003"]) - , (SkipToTest 197, "197", ["0197", "00197"]) - , ( SkipToShrink 5 $ Property.ShrinkPath [2, 3, 0] + , (SkipToTest 3 0, "3", ["03", "003", "3/0", "03/00"]) + , (SkipToTest 197 1, "197/1", ["0197/1", "00197/01"]) + , ( SkipToShrink 5 0 $ Property.ShrinkPath [2, 3, 0] , "5:cDa" , ["5:CdA", "05:c1b0D1A1"] ) - , ( SkipToShrink 21 $ Property.ShrinkPath [5, 3, 27, 27, 26] - , "21:fDbb2BA" - , ["21:fDbbBBba"] + , ( SkipToShrink 21 3 $ Property.ShrinkPath [5, 3, 27, 27, 26] + , "21/3:fDbb2BA" + , ["21/3:fDbbBBba"] ) ]