Allow skipping to a specific test number or shrink result

hedgehog/hedgehog.cabal

@@ -136,6 +136,7 @@ test-suite test
     Test.Hedgehog.Filter
     Test.Hedgehog.Maybe
     Test.Hedgehog.Seed
+    Test.Hedgehog.Skip
     Test.Hedgehog.Text
     Test.Hedgehog.Zip
 

hedgehog/src/Hedgehog.hs

@@ -60,6 +60,7 @@ module Hedgehog (
 
   , check
   , recheck
+  , recheckAt
 
   , discover
   , discoverPrefix
@@ -82,6 +83,9 @@ module Hedgehog (
   , withRetries
   , ShrinkRetries
 
+  , withSkip
+  , Skip
+
   -- * Generating Test Data
   , Gen
   , GenT
@@ -185,11 +189,12 @@ import           Hedgehog.Internal.Property (Group(..), GroupName)
 import           Hedgehog.Internal.Property (Confidence, verifiedTermination, withConfidence)
 import           Hedgehog.Internal.Property (ShrinkLimit, withShrinks)
 import           Hedgehog.Internal.Property (ShrinkRetries, withRetries)
+import           Hedgehog.Internal.Property (Skip, withSkip)
 import           Hedgehog.Internal.Property (Test, TestT, property, test)
 import           Hedgehog.Internal.Property (TestLimit, withTests)
 import           Hedgehog.Internal.Property (collect, label)
 import           Hedgehog.Internal.Range (Range, Size(..))
-import           Hedgehog.Internal.Runner (check, recheck, checkSequential, checkParallel)
+import           Hedgehog.Internal.Runner (check, recheck, recheckAt, checkSequential, checkParallel)
 import           Hedgehog.Internal.Seed (Seed(..))
 import           Hedgehog.Internal.State (Command(..), Callback(..))
 import           Hedgehog.Internal.State (Action, Sequential(..), Parallel(..))

hedgehog/src/Hedgehog/Internal/Config.hs

@@ -18,11 +18,15 @@ module Hedgehog.Internal.Config (
   , WorkerCount(..)
   , resolveWorkers
 
+  , Skip(..)
+  , resolveSkip
+
   , detectMark
   , detectColor
   , detectSeed
   , detectVerbosity
   , detectWorkers
+  , detectSkip
   ) where
 
 import           Control.Monad.IO.Class (MonadIO(..))
@@ -33,6 +37,7 @@ import qualified GHC.Conc as Conc
 
 import           Hedgehog.Internal.Seed (Seed(..))
 import qualified Hedgehog.Internal.Seed as Seed
+import           Hedgehog.Internal.Property (Skip(..), skipDecompress)
 
 import           Language.Haskell.TH.Syntax (Lift)
 
@@ -166,6 +171,22 @@ detectWorkers = do
       Just env ->
         pure $ WorkerCount env
 
+detectSkip :: MonadIO m => m Skip
+detectSkip =
+  liftIO $ do
+    menv <- lookupEnv "HEDGEHOG_SKIP"
+    case menv of
+      Nothing ->
+        pure SkipNothing
+      Just env ->
+        case skipDecompress env of
+          Nothing ->
+            -- It's clearer for the user if we error out here, rather than
+            -- silently defaulting to SkipNothing.
+            error "HEDGEHOG_SKIP is not a valid Skip."
+          Just skip ->
+            pure skip
+
 resolveColor :: MonadIO m => Maybe UseColor -> m UseColor
 resolveColor = \case
   Nothing ->
@@ -193,3 +214,10 @@ resolveWorkers = \case
     detectWorkers
   Just x ->
     pure x
+
+resolveSkip :: MonadIO m => Maybe Skip -> m Skip
+resolveSkip = \case
+  Nothing ->
+    detectSkip
+  Just x ->
+    pure x

hedgehog/src/Hedgehog/Internal/Property.hs

@@ -34,11 +34,14 @@ module Hedgehog.Internal.Property (
   , DiscardCount(..)
   , ShrinkLimit(..)
   , ShrinkCount(..)
+  , Skip(..)
+  , ShrinkPath(..)
   , ShrinkRetries(..)
   , withTests
   , withDiscards
   , withShrinks
   , withRetries
+  , withSkip
   , property
   , test
   , forAll
@@ -47,6 +50,8 @@ module Hedgehog.Internal.Property (
   , forAllWithT
   , defaultMinTests
   , discard
+  , skipCompress
+  , skipDecompress
 
   -- * Group
   , Group(..)
@@ -165,7 +170,7 @@ import           Data.Map (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Number.Erf (invnormcdf)
 import qualified Data.List as List
-import           Data.String (IsString)
+import           Data.String (IsString(..))
 import           Data.Ratio ((%))
 import           Data.Typeable (typeOf)
 
@@ -179,6 +184,9 @@ import           Hedgehog.Internal.Source
 
 import           Language.Haskell.TH.Syntax (Lift)
 
+import qualified Numeric
+
+import           Text.Read (readMaybe)
 
 ------------------------------------------------------------------------
 
@@ -273,6 +281,10 @@ data PropertyConfig =
     , propertyShrinkLimit :: !ShrinkLimit
     , propertyShrinkRetries :: !ShrinkRetries
     , propertyTerminationCriteria :: !TerminationCriteria
+
+    -- | If this is 'Nothing', we take the Skip from the environment variable
+    --   @HEDGEHOG_SKIP@.
+    , propertySkip :: Maybe Skip
     } deriving (Eq, Ord, Show, Lift)
 
 -- | The number of successful tests that need to be run before a property test
@@ -292,7 +304,7 @@ newtype TestLimit =
 --
 newtype TestCount =
   TestCount Int
-  deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
+  deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)
 
 -- | The number of tests a property had to discard.
 --
@@ -331,6 +343,156 @@ newtype ShrinkCount =
   ShrinkCount Int
   deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
 
+-- | Where to start running a property's tests.
+--
+data Skip =
+  -- | Don't skip anything.
+  --
+    SkipNothing
+
+  -- | 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
+
+  -- | Skip to a specific test number and shrink state. If it fails, stop
+  --   without shrinking further. If it passes, the property will pass without
+  --   running any more tests.
+  --
+  --   Due to implementation details, all intermediate shrink states - those on
+  --   the direct path from the original test input to the target state - will
+  --   be tested too, and their results discarded.
+  --
+  | SkipToShrink TestCount ShrinkPath
+  deriving (Eq, Ord, Show, Lift)
+
+-- | We use this instance to support usage like
+--
+-- @
+--   withSkip "3:aB"
+-- @
+--
+--   It throws an error if the input is not a valid compressed 'Skip'.
+--
+instance IsString Skip where
+  fromString s =
+    case skipDecompress s of
+      Nothing ->
+        error $ "fromString: Not a valid Skip: " ++ s
+      Just skip ->
+        skip
+
+-- | The path taken to reach a shrink state.
+--
+newtype ShrinkPath =
+  ShrinkPath [Int]
+  deriving (Eq, Ord, Show, Lift)
+
+-- | Compress a Skip into a hopefully-short alphanumeric string.
+--
+--   The bit that might be long is the 'ShrinkPath' in 'SkipToShrink'. For that,
+--   we encode the path components in base 26, alternating between uppercase and
+--   lowercase alphabets to distinguish list elements. Additionally when we have
+--   runs of equal components, we use the normal base 10 encoding to indicate
+--   the length.
+--
+--   This gives something which is hopefully quite short, but a human can
+--   roughly interpret it by eyeball.
+--
+skipCompress :: Skip -> String
+skipCompress = \case
+  SkipNothing ->
+    ""
+  SkipToTest (TestCount n) ->
+    show n
+  SkipToShrink (TestCount n) sp ->
+    show n ++ ":" ++ shrinkPathCompress sp
+
+shrinkPathCompress :: ShrinkPath -> String
+shrinkPathCompress (ShrinkPath sp) =
+  let
+    groups = List.map (\l -> (head l, length l)) $ List.group sp
+  in
+    (mconcat
+      $ zipWith
+          (\alphabet (loc, count) ->
+              Numeric.showIntAtBase 26 (alphabet !!) loc
+              <> if count == 1 then mempty else shows count
+          )
+          (cycle [['a'..'z'], ['A'..'Z']])
+          groups
+    )
+      ""
+
+-- | Decompress a 'Skip'.
+--
+--   This satisfies
+--
+-- @
+--   skipDecompress (skipCompress a) == Just a
+-- @
+--
+skipDecompress :: String -> Maybe Skip
+skipDecompress str =
+  if null str then
+    Just SkipNothing
+  else do
+    let
+      (tcStr, spStr)
+        = span (/= ':') str
+    tc <- TestCount <$> readMaybe tcStr
+    if null spStr then
+      Just $ SkipToTest tc
+    else do
+      sp <- shrinkPathDecompress $ drop 1 spStr
+      Just $ SkipToShrink tc sp
+
+shrinkPathDecompress :: String -> Maybe ShrinkPath
+shrinkPathDecompress str =
+  let
+    isDigit c = '0' <= c && c <= '9'
+    isLower c = 'a' <= c && c <= 'z'
+    isUpper c = 'A' <= c && c <= 'Z'
+    classifyChar c = (isDigit c, isLower c, isUpper c)
+
+    readSNum "" = []
+    readSNum s@(c1:_) =
+      if isDigit c1 then
+        Numeric.readInt 10 isDigit (\c -> fromEnum c - fromEnum '0') s
+      else if isLower c1 then
+        Numeric.readInt 26 isLower (\c -> fromEnum c - fromEnum 'a') s
+      else if isUpper c1 then
+        Numeric.readInt 26 isUpper (\c -> fromEnum c - fromEnum 'A') s
+      else
+        []
+
+    readNumMaybe s =
+      case readSNum s of
+        [(num, "")] -> Just num
+        _ -> Nothing
+
+    spGroups :: [(Maybe Int, Maybe Int)] =
+      let
+        go [] =
+          []
+        go (c1:cs) =
+          let
+            (hd, tl1) =
+              span (\c -> classifyChar c == classifyChar c1) cs
+            (digs, tl2) =
+              span isDigit tl1
+          in
+            ( readNumMaybe (c1:hd)
+            , readNumMaybe $ if null digs then "1" else digs
+            )
+            : go tl2
+      in
+        go str
+  in do
+    sp <- concat <$>
+      traverse (\(mNum, mCount) -> replicate <$> mCount <*> mNum) spGroups
+    Just $ ShrinkPath sp
+
 -- | The number of times to re-run a test during shrinking. This is useful if
 --   you are testing something which fails non-deterministically and you want to
 --   increase the change of getting a good shrink.
@@ -991,6 +1153,8 @@ defaultConfig =
         0
     , propertyTerminationCriteria =
         NoConfidenceTermination defaultMinTests
+    , propertySkip =
+        Nothing
     }
 
 -- | The minimum amount of tests to run for a 'Property'
@@ -1077,6 +1241,12 @@ withRetries :: ShrinkRetries -> Property -> Property
 withRetries n =
   mapConfig $ \config -> config { propertyShrinkRetries = n }
 
+-- | Set the target that a property will skip to before it starts to run.
+--
+withSkip :: Skip -> Property -> Property
+withSkip s =
+  mapConfig $ \config -> config { propertySkip = Just s }
+
 -- | Creates a property with the default configuration.
 --
 property :: HasCallStack => PropertyT IO () -> Property