Fix test skipping when tests have been discarded.

CHANGELOG.md

@@ -1,3 +1,7 @@
+## Version 1.4 (unreleased)
+
+* 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])

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