diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## Version 1.4 (2023-08-07) + +* Fix skipping to tests/shrinks when tests have been discarded ([#489][489], [@ChickenProp][ChickenProp]) + ## Version 1.3 (2023-06-22) * Better documentation for `Var` ([#491][491], [@endgame][endgame]) @@ -288,6 +292,8 @@ [491]: https://github.com/hedgehogqa/haskell-hedgehog/pull/491 +[489]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/489 [486]: https://github.com/hedgehogqa/haskell-hedgehog/pull/486 [485]: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -89,6 +89,16 @@ ``` +## In Memory of Jacob Stanley + +As we come to the end of our guide to haskell-hedgehog, we'd like to take a moment to remember and honor one of its key contributors, our dear friend, author and co-founder, Jacob Stanley. + +Jacob's passion for Haskell and his commitment to creating high-quality, reliable software was truly inspiring. His work has shaped haskell-hedgehog in countless ways, and without him, it wouldn't be the project it is today. + +Jacob passed away unexpectedly on April 9th. His absence is deeply felt, but his impact on this project, and on all of us who had the privilege to work with him, remains. We continue to maintain and develop haskell-hedgehog in his memory and in honor of his dedication to excellence in programming. + +As you explore haskell-hedgehog, and possibly contribute to its ongoing development, we invite you to join us in remembering Jacob Stanley — a tremendous developer, collaborator, and friend. +

diff --git a/hedgehog.cabal b/hedgehog.cabal --- a/hedgehog.cabal +++ b/hedgehog.cabal @@ -1,4 +1,4 @@ -version: 1.3 +version: 1.4 name: hedgehog diff --git a/src/Hedgehog/Internal/Property.hs b/src/Hedgehog/Internal/Property.hs --- a/src/Hedgehog/Internal/Property.hs +++ b/src/Hedgehog/Internal/Property.hs @@ -312,7 +312,7 @@ -- 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 @@ -- | 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 @@ -- 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 @@ -- 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 @@ 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/src/Hedgehog/Internal/Report.hs b/src/Hedgehog/Internal/Report.hs --- a/src/Hedgehog/Internal/Report.hs +++ b/src/Hedgehog/Internal/Report.hs @@ -622,8 +622,8 @@ 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 @@ bottom = maybe - [ppReproduce name seed (SkipToShrink tests shrinkPath)] + [ppReproduce name seed (SkipToShrink tests discards shrinkPath)] (const []) mcoverage @@ -752,7 +752,7 @@ 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 @@ ppShrinkDiscard (failureShrinks failure) discards <> "." <#> "shrink path:" <+> - ppSkip (SkipToShrink tests $ failureShrinkPath failure) + ppSkip (SkipToShrink tests discards $ failureShrinkPath failure) ] ++ ppCoverage tests coverage ++ pfailure diff --git a/src/Hedgehog/Internal/Runner.hs b/src/Hedgehog/Internal/Runner.hs --- a/src/Hedgehog/Internal/Runner.hs +++ b/src/Hedgehog/Internal/Runner.hs @@ -220,10 +220,10 @@ 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 @@ -- 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/test/Test/Hedgehog/Skip.hs b/test/Test/Hedgehog/Skip.hs --- a/test/Test/Hedgehog/Skip.hs +++ b/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 @@ -- | 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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,8 +186,40 @@ 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 = let @@ -192,13 +229,16 @@ 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 @@ -- 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"] ) ]