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"] ) ]