Fix test skipping when tests have been discarded.

Closes hedgehogqa#487.

In hedgehogqa#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

@@ -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)
 

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'.
 --

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

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

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