hedgehog 1.1.2 → 1.2

raw patch · 12 files changed

+728/−103 lines, 12 filesdep ~mtldep ~primitivedep ~resourcetPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: mtl, primitive, resourcet, template-haskell, text, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +25/−2
• hedgehog.cabal +7/−6
• src/Hedgehog.hs +6/−1
• src/Hedgehog/Gen.hs +1/−0
• src/Hedgehog/Internal/Config.hs +28/−0
• src/Hedgehog/Internal/Gen.hs +29/−0
• src/Hedgehog/Internal/Property.hs +187/−2
• src/Hedgehog/Internal/Report.hs +36/−20
• src/Hedgehog/Internal/Runner.hs +155/−70
• src/Hedgehog/Internal/State.hs +6/−2
• test/Test/Hedgehog/Skip.hs +246/−0
• test/test.hs +2/−0

@@ -1,11 +1,17 @@-## Version 1.1.2 (2022-09-02)+## Version 1.2 (2022-08-28) +* Allow skipping to a specific test number or shrink result ([#454][454], [@ChickenProp][ChickenProp])+  * Export shrinkPathCompress and shrinkPathDecompress ([#462][462], [@mbg][mbg]) * Support GHC 9.4 ([#461][461], [@ysangkok][ysangkok]) * Allow newer dependencies ([#457][457], [@ysangkok][ysangkok])+* Add Gen.subset ([#451][451], [@chris-martin][chris-martin])+* Add example for Gen.subsequence ([#450][450], [@chris-martin][chris-martin])+* Don't drop actions depending on shrunk predecessors ([#453][453], [@ChickenProp][ChickenProp])  ## Version 1.1.1 (2022-01-29)  * Support using fixed seed via `HEDGEHOG_SEED` ([#446][446], [@simfleischman][simfleischman] / [@moodmosaic][moodmosaic])+* Compatibility with text-2.0 ([#443][443], [@sjakobi][sjakobi]) * Better 'cover' example code in haddocks ([#423][423], [@jhrcek][jhrcek])  ## Version 1.1 (2022-01-27)@@ -246,17 +252,34 @@   https://github.com/patrickt [simfleischman]:   https://github.com/simfleischman+[ChickenProp]:+  https://github.com/ChickenProp [ysangkok]:-   https://github.com/ysangkok+  https://github.com/ysangkok+[mbg]:+  https://github.com/mbg [jhrcek]:   https://github.com/jhrcek ++[462]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/462 [461]:   https://github.com/hedgehogqa/haskell-hedgehog/pull/461 [457]:   https://github.com/hedgehogqa/haskell-hedgehog/pull/457+[454]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/454+[453]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/453+[451]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/451+[450]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/450 [446]:   https://github.com/hedgehogqa/haskell-hedgehog/pull/446+[443]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/443 [436]:   https://github.com/hedgehogqa/haskell-hedgehog/pull/436 [423]:

@@ -1,4 +1,4 @@-version: 1.1.2+version: 1.2  name:   hedgehog@@ -65,7 +65,7 @@     , lifted-async                    >= 0.7        && < 0.11     , mmorph                          >= 1.0        && < 1.3     , monad-control                   >= 1.0        && < 1.1-    , mtl                             >= 2.1        && < 2.3+    , mtl                             >= 2.1        && < 2.4     , pretty-show                     >= 1.6        && < 1.11     , primitive                       >= 0.6        && < 0.8     , random                          >= 1.1        && < 1.3@@ -74,7 +74,7 @@     , template-haskell                >= 2.10       && < 2.20     , text                            >= 1.1        && < 2.1     , time                            >= 1.4        && < 1.13-    , transformers                    >= 0.5        && < 0.6+    , transformers                    >= 0.5        && < 0.7     , transformers-base               >= 0.4.5.1    && < 0.5     , wl-pprint-annotated             >= 0.0        && < 0.2 @@ -136,6 +136,7 @@     Test.Hedgehog.Filter     Test.Hedgehog.Maybe     Test.Hedgehog.Seed+    Test.Hedgehog.Skip     Test.Hedgehog.Text     Test.Hedgehog.Zip @@ -144,10 +145,10 @@     , base                            >= 3          && < 5     , containers                      >= 0.4        && < 0.7     , mmorph                          >= 1.0        && < 1.3-    , mtl                             >= 2.1        && < 2.3+    , mtl                             >= 2.1        && < 2.4     , pretty-show                     >= 1.6        && < 1.11-    , text                            >= 1.1        && < 1.3-    , transformers                    >= 0.3        && < 0.6+    , text                            >= 1.1        && < 2.1+    , transformers                    >= 0.3        && < 0.7    default-language:     Haskell2010

@@ -60,6 +60,7 @@    , check   , recheck+  , recheckAt    , discover   , discoverPrefix@@ -82,6 +83,9 @@   , withRetries   , ShrinkRetries +  , withSkip+  , Skip+   -- * Generating Test Data   , Gen   , GenT@@ -185,11 +189,12 @@ 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(..))

@@ -94,6 +94,7 @@    -- ** Combinations & Permutations   , subsequence+  , subset   , shuffle    -- ** Abstract State Machine

@@ -18,11 +18,15 @@   , WorkerCount(..)   , resolveWorkers +  , Skip(..)+  , resolveSkip+   , detectMark   , detectColor   , detectSeed   , detectVerbosity   , detectWorkers+  , detectSkip   ) where  import           Control.Monad.IO.Class (MonadIO(..))@@ -33,6 +37,7 @@  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 @@       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 ->@@ -191,5 +212,12 @@ resolveWorkers = \case   Nothing ->     detectWorkers+  Just x ->+    pure x++resolveSkip :: MonadIO m => Maybe Skip -> m Skip+resolveSkip = \case+  Nothing ->+    detectSkip   Just x ->     pure x

@@ -130,6 +130,7 @@    -- ** Combinations & Permutations   , subsequence+  , subset   , shuffle   , shuffleSeq @@ -216,6 +217,7 @@ import           Data.Sequence (Seq) import qualified Data.Sequence as Seq import           Data.Set (Set)+import qualified Data.Set as Set import           Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text@@ -1662,9 +1664,36 @@  -- | Generates a random subsequence of a list. --+-- For example:+--+-- @+-- Gen.print (Gen.subsequence [1..5])+-- @+--+--   > === Outcome ===+--   > [1,2,4]+--   > === Shrinks ===+--   > []+--   > [2,4]+--   > [1,4]+--   > [1,2]+-- subsequence :: MonadGen m => [a] -> m [a] subsequence xs =   shrink Shrink.list $ filterM (const bool_) xs++-- | Generates a random subset of a set.+--+--  /This shrinks towards the empty set./+--+subset :: MonadGen m => Set a -> m (Set a)+-- Set.fromDistinctAscList has an unchecked precondition that the list+-- must be strictly ascending. This precondition is satisfied because+-- Set.toAscList produces a strictly ascending list, and the 'subsequence'+-- generator only removes elements from the list; it never adds or+-- rearranges elements, so the strictly ascending property is undisturbed.+subset =+  fmap Set.fromDistinctAscList . subsequence . Set.toAscList  -- | Generates a random permutation of a list. --

@@ -34,11 +34,14 @@   , DiscardCount(..)   , ShrinkLimit(..)   , ShrinkCount(..)+  , Skip(..)+  , ShrinkPath(..)   , ShrinkRetries(..)   , withTests   , withDiscards   , withShrinks   , withRetries+  , withSkip   , property   , test   , forAll@@ -47,6 +50,10 @@   , forAllWithT   , defaultMinTests   , discard+  , skipCompress+  , shrinkPathCompress+  , skipDecompress+  , shrinkPathDecompress    -- * Group   , Group(..)@@ -165,7 +172,7 @@ 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,7 +186,10 @@  import           Language.Haskell.TH.Syntax (Lift) +import qualified Numeric +import           Text.Read (readMaybe)+ ------------------------------------------------------------------------  -- | A property test, along with some configurable limits like how many times@@ -273,6 +283,10 @@     , 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 +306,7 @@ -- 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 +345,169 @@   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++-- | Compress a 'ShrinkPath' into a hopefully-short alphanumeric string.+--+--   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.+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++-- | Decompress a 'ShrinkPath'.+--+--   This satisfies+--+-- @+--   shrinkPathDecompress (shrinkPathCompress a) == Just a+-- @+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 +1168,8 @@         0     , propertyTerminationCriteria =         NoConfidenceTermination defaultMinTests+    , propertySkip =+        Nothing     }  -- | The minimum amount of tests to run for a 'Property'@@ -1076,6 +1255,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. --

@@ -62,10 +62,10 @@ import           Hedgehog.Internal.Property (TestCount(..), DiscardCount(..)) import           Hedgehog.Internal.Property (coverPercentage, coverageFailures) import           Hedgehog.Internal.Property (labelCovered)+import           Hedgehog.Internal.Property (ShrinkPath(..), skipCompress)  import           Hedgehog.Internal.Show import           Hedgehog.Internal.Source-import           Hedgehog.Range (Size)  import           System.Console.ANSI (ColorIntensity(..), Color(..)) import           System.Console.ANSI (ConsoleLayer(..), ConsoleIntensity(..))@@ -91,9 +91,8 @@  data FailureReport =   FailureReport {-      failureSize :: !Size-    , failureSeed :: !Seed-    , failureShrinks :: !ShrinkCount+      failureShrinks :: !ShrinkCount+    , failureShrinkPath :: !ShrinkPath     , failureCoverage :: !(Maybe (Coverage CoverCount))     , failureAnnotations :: ![FailedAnnotation]     , failureLocation :: !(Maybe Span)@@ -127,6 +126,7 @@       reportTests :: !TestCount     , reportDiscards :: !DiscardCount     , reportCoverage :: !(Coverage CoverCount)+    , reportSeed :: !Seed     , reportStatus :: !a     } deriving (Show, Functor, Foldable, Traversable) @@ -267,16 +267,15 @@     Nothing  mkFailure ::-     Size-  -> Seed-  -> ShrinkCount+     ShrinkCount+  -> ShrinkPath   -> Maybe (Coverage CoverCount)   -> Maybe Span   -> String   -> Maybe Diff   -> [Log]   -> FailureReport-mkFailure size seed shrinks mcoverage location message diff logs =+mkFailure shrinks shrinkPath mcoverage location message diff logs =   let     inputs =       mapMaybe takeAnnotation logs@@ -284,7 +283,7 @@     footnotes =       mapMaybe takeFootnote logs   in-    FailureReport size seed shrinks mcoverage inputs location message diff footnotes+    FailureReport shrinks shrinkPath mcoverage inputs location message diff footnotes  ------------------------------------------------------------------------ -- Pretty Printing@@ -326,6 +325,18 @@   ShrinkCount n ->     ppShow n <+> "shrinks" +-- | Render a compressed 'Skip'.+--+ppSkip :: Skip -> Doc a+ppSkip =+  WL.text . skipCompress++-- | Render a compressed 'Skip', such that it can be read back in.+--+ppSkipReadable :: Skip -> Doc a+ppSkipReadable =+  WL.text . show . skipCompress+ ppRawPropertyCount :: PropertyCount -> Doc a ppRawPropertyCount (PropertyCount n) =   ppShow n@@ -580,15 +591,15 @@       in         WL.vsep (ppLocation : ppLines) -ppReproduce :: Maybe PropertyName -> Size -> Seed -> Doc Markup-ppReproduce name size seed =+ppReproduce :: Maybe PropertyName -> Seed -> Skip -> Doc Markup+ppReproduce name seed skip =   WL.vsep [       markup ReproduceHeader         "This failure can be reproduced by running:"     , gutter ReproduceGutter . markup ReproduceSource $-        "recheck" <+>-        WL.text (showsPrec 11 size "") <+>+        "recheckAt" <+>         WL.text (showsPrec 11 seed "") <+>+        ppSkipReadable skip <+>         maybe "<property>" (WL.text . unPropertyName) name     ] @@ -611,8 +622,8 @@ ppTextLines =   fmap WL.text . List.lines -ppFailureReport :: MonadIO m => Maybe PropertyName -> TestCount -> FailureReport -> m [Doc Markup]-ppFailureReport name tests (FailureReport size seed _ mcoverage inputs0 mlocation0 msg mdiff msgs0) = do+ppFailureReport :: MonadIO m => Maybe PropertyName -> TestCount -> Seed -> FailureReport -> m [Doc Markup]+ppFailureReport name tests seed (FailureReport _ shrinkPath mcoverage inputs0 mlocation0 msg mdiff msgs0) = do   let     basic =       -- Move the failure message to the end section if we have@@ -684,7 +695,10 @@         f xs      bottom =-      maybe [ppReproduce name size seed] (const []) mcoverage+      maybe+        [ppReproduce name seed (SkipToShrink tests shrinkPath)]+        (const [])+        mcoverage    pure .     whenSome (mempty :) .@@ -712,7 +726,7 @@     WL.text name  ppProgress :: MonadIO m => Maybe PropertyName -> Report Progress -> m (Doc Markup)-ppProgress name (Report tests discards coverage status) =+ppProgress name (Report tests discards coverage _ status) =   case status of     Running ->       pure . WL.vsep $ [@@ -735,10 +749,10 @@         "(shrinking)"  ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup)-ppResult name (Report tests discards coverage result) = do+ppResult name (Report tests discards coverage seed result) = do   case result of     Failed failure -> do-      pfailure <- ppFailureReport name tests failure+      pfailure <- ppFailureReport name tests seed failure       pure . WL.vsep $ [           icon FailedIcon '✗' . WL.align . WL.annotate FailedText $             ppName name <+>@@ -746,7 +760,9 @@             "after" <+>             ppTestCount tests <>             ppShrinkDiscard (failureShrinks failure) discards <>-            "."+            "." <#>+            "shrink path:" <+>+            ppSkip (SkipToShrink tests $ failureShrinkPath failure)         ] ++         ppCoverage tests coverage ++         pfailure

@@ -13,6 +13,7 @@   -- * Running Individual Properties     check   , recheck+  , recheckAt    -- * Running Groups of Properties   , RunnerConfig(..)@@ -30,6 +31,7 @@ import qualified Control.Concurrent.STM.TVar as TVar import           Control.Monad.Catch (MonadCatch(..), catchAll) import           Control.Monad.IO.Class (MonadIO(..))+import           Data.Maybe (isJust)  import           Hedgehog.Internal.Config import           Hedgehog.Internal.Gen (evalGenT)@@ -39,12 +41,13 @@ import           Hedgehog.Internal.Property (Journal(..), Coverage(..), CoverCount(..)) import           Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..)) import           Hedgehog.Internal.Property (PropertyT(..), Failure(..), runTestT)-import           Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withTests)+import           Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withTests, withSkip) import           Hedgehog.Internal.Property (TerminationCriteria(..)) import           Hedgehog.Internal.Property (TestCount(..), PropertyCount(..)) import           Hedgehog.Internal.Property (confidenceSuccess, confidenceFailure) import           Hedgehog.Internal.Property (coverageSuccess, journalCoverage) import           Hedgehog.Internal.Property (defaultMinTests)+import           Hedgehog.Internal.Property (ShrinkPath(..)) import           Hedgehog.Internal.Queue import           Hedgehog.Internal.Region import           Hedgehog.Internal.Report@@ -116,41 +119,89 @@  takeSmallest ::      MonadIO m-  => Size-  -> Seed-  -> ShrinkCount+  => ShrinkCount+  -> ShrinkPath   -> ShrinkLimit   -> ShrinkRetries   -> (Progress -> m ())   -> NodeT m (Maybe (Either Failure (), Journal))   -> m Result-takeSmallest size seed shrinks slimit retries updateUI = \case-  NodeT Nothing _ ->-    pure GaveUp+takeSmallest shrinks0 (ShrinkPath shrinkPath0) slimit retries updateUI =+  let+    loop shrinks revShrinkPath = \case+      NodeT Nothing _ ->+        pure GaveUp -  NodeT (Just (x, (Journal logs))) xs ->-    case x of-      Left (Failure loc err mdiff) -> do-        let-          failure =-            mkFailure size seed shrinks Nothing loc err mdiff (reverse logs)+      NodeT (Just (x, (Journal logs))) xs ->+        case x of+          Left (Failure loc err mdiff) -> do+            let+              shrinkPath =+                ShrinkPath $ reverse revShrinkPath+              failure =+                mkFailure shrinks shrinkPath Nothing loc err mdiff (reverse logs) -        updateUI $ Shrinking failure+            updateUI $ Shrinking failure -        if shrinks >= fromIntegral slimit then-          -- if we've hit the shrink limit, don't shrink any further-          pure $ Failed failure-        else-          findM xs (Failed failure) $ \m -> do-            o <- runTreeN retries m-            if isFailure o then-              Just <$> takeSmallest size seed (shrinks + 1) slimit retries updateUI o+            if shrinks >= fromIntegral slimit then+              -- if we've hit the shrink limit, don't shrink any further+              pure $ Failed failure             else-              return Nothing+              findM (zip [0..] xs) (Failed failure) $ \(n, m) -> do+                o <- runTreeN retries m+                if isFailure o then+                  Just <$> loop (shrinks + 1) (n : revShrinkPath) o+                else+                  return Nothing -      Right () ->-        return OK+          Right () ->+            return OK+  in+    loop shrinks0 (reverse shrinkPath0) +-- | Follow a given shrink path, instead of searching exhaustively. Assume that+-- the end of the path is minimal, and don't try to shrink any further than+-- that.+--+-- This evaluates the test for all the shrinks on the path, but not ones+-- off-path. Because the generator is mixed with the test code, it's probably+-- not possible to avoid this.+skipToShrink ::+     MonadIO m+  => ShrinkPath+  -> (Progress -> m ())+  -> NodeT m (Maybe (Either Failure (), Journal))+  -> m Result+skipToShrink (ShrinkPath shrinkPath) updateUI =+  let+    loop shrinks [] = \case+      NodeT Nothing _ ->+        pure GaveUp++      NodeT (Just (x, (Journal logs))) _ ->+        case x of+          Left (Failure loc err mdiff) -> do+            let+              failure =+                mkFailure shrinks (ShrinkPath shrinkPath) Nothing loc err mdiff (reverse logs)++            updateUI $ Shrinking failure+            pure $ Failed failure++          Right () ->+            return OK++    loop shrinks (s0:ss) = \case+      NodeT _ xs ->+        case drop s0 xs of+          [] ->+            pure GaveUp+          (x:_) -> do+            o <- runTreeT x+            loop (shrinks + 1) ss o+  in+    loop 0 shrinkPath+ checkReport ::      forall m.      MonadIO m@@ -161,8 +212,19 @@   -> PropertyT m ()   -> (Report Progress -> m ())   -> m (Report Result)-checkReport cfg size0 seed0 test0 updateUI =+checkReport cfg size0 seed0 test0 updateUI = do+  skip <- liftIO $ resolveSkip $ propertySkip cfg+   let+    (mSkipToTest, mSkipToShrink) =+      case skip of+        SkipNothing ->+          (Nothing, Nothing)+        SkipToTest t ->+          (Just t, Nothing)+        SkipToShrink t s ->+          (Just t, Just s)+     test =       catchAll test0 (fail . show) @@ -198,7 +260,7 @@       -> Coverage CoverCount       -> m (Report Result)     loop !tests !discards !size !seed !coverage0 = do-      updateUI $ Report tests discards coverage0 Running+      updateUI $ Report tests discards coverage0 seed0 Running        let         coverageReached =@@ -221,13 +283,12 @@           coverageSuccess tests coverage0          successReport =-          Report tests discards coverage0 OK+          Report tests discards coverage0 seed0 OK          failureReport message =-          Report tests discards coverage0 . Failed $ mkFailure-            size-            seed+          Report tests discards coverage0 seed0 . Failed $ mkFailure             0+            (ShrinkPath [])             (Just coverage0)             Nothing             message@@ -249,54 +310,70 @@         -- at this point, we know that enough tests have been run in order to         -- make a decision on if this was a successful run or not         ---        -- If we have early termination, then we need to check coverageReached / coverageUnreachable-        pure $ case terminationCriteria of-          EarlyTermination _ _ -> confidenceReport-          NoEarlyTermination _ _ -> confidenceReport-          NoConfidenceTermination _ ->-            if labelsCovered then-              successReport-            else-              failureReport $-                "Labels not sufficently covered after " <> show tests <> " tests"+        -- If we have early termination, then we need to check coverageReached /+        -- coverageUnreachable. If we skip tests, we ignore coverage.+        if isJust mSkipToTest then+          pure successReport+        else+          pure $ case terminationCriteria of+            EarlyTermination _ _ -> confidenceReport+            NoEarlyTermination _ _ -> confidenceReport+            NoConfidenceTermination _ ->+              if labelsCovered then+                successReport+              else+                failureReport $+                  "Labels not sufficently covered after " <> show tests <> " tests"        else if discards >= fromIntegral (propertyDiscardLimit cfg) then         -- we've hit the discard limit, give up-        pure $ Report tests discards coverage0 GaveUp+        pure $ Report tests discards coverage0 seed0 GaveUp        else         case Seed.split seed of-          (s0, s1) -> do-            node@(NodeT x _) <--              runTreeT . evalGenT size s0 . runTestT $ unPropertyT test-            case x of-              Nothing ->-                loop tests (discards + 1) (size + 1) s1 coverage0+          (s0, s1) -> case (mSkipToTest, mSkipToShrink) of+            -- 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 _, Just shrinkPath) -> do+              node <-+                runTreeT . evalGenT size s0 . runTestT $ unPropertyT test+              let+                mkReport =+                  Report (tests + 1) discards coverage0 seed0+              mkReport <$> skipToShrink shrinkPath (updateUI . mkReport) node+            _ -> do+              node@(NodeT x _) <-+                runTreeT . evalGenT size s0 . runTestT $ unPropertyT test+              case x of+                Nothing ->+                  loop tests (discards + 1) (size + 1) s1 coverage0 -              Just (Left _, _) ->-                let-                  mkReport =-                    Report (tests + 1) discards coverage0-                in-                  fmap mkReport $-                    takeSmallest-                      size-                      seed-                      0-                      (propertyShrinkLimit cfg)-                      (propertyShrinkRetries cfg)-                      (updateUI . mkReport)-                      node+                Just (Left _, _) ->+                  let+                    mkReport =+                      Report (tests + 1) discards coverage0 seed0+                  in+                    fmap mkReport $+                      takeSmallest+                        0+                        (ShrinkPath [])+                        (propertyShrinkLimit cfg)+                        (propertyShrinkRetries cfg)+                        (updateUI . mkReport)+                        node -              Just (Right (), journal) ->-                let-                  coverage =-                    journalCoverage journal <> coverage0-                in-                  loop (tests + 1) discards (size + 1) s1 coverage-  in-    loop 0 0 size0 seed0 mempty+                Just (Right (), journal) ->+                  let+                    coverage =+                      journalCoverage journal <> coverage0+                  in+                    loop (tests + 1) discards (size + 1) s1 coverage +  loop 0 0 size0 seed0 mempty+ checkRegion ::      MonadIO m   => Region@@ -356,6 +433,14 @@   let prop = withTests 1 prop0   _ <- liftIO . displayRegion $ \region ->     checkRegion region color Nothing size seed prop+  pure ()++recheckAt :: MonadIO m => Seed -> Skip -> Property -> m ()+recheckAt seed skip prop0 = do+  color <- detectColor+  let prop = withSkip skip prop0+  _ <- liftIO . displayRegion $ \region ->+    checkRegion region color Nothing 0 seed prop   pure ()  -- | Check a group of properties using the specified runner config.

@@ -548,6 +548,12 @@     Command mgenInput exec callbacks <-       Gen.element_ $ filter (\c -> commandGenOK c state0) commands +    -- If we shrink the input, we still want to use the same output. Otherwise+    -- any actions using this output as part of their input will be dropped. But+    -- the existing output is still in the context, so `contextNewVar` will+    -- create a new one. To avoid that, we generate the output before the input.+    output <- contextNewVar+     input <-       case mgenInput state0 of         Nothing ->@@ -559,8 +565,6 @@       pure Nothing      else do-      output <- contextNewVar-       contextUpdate $         callbackUpdate callbacks state0 input (Var output) 

@@ -0,0 +1,246 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module Test.Hedgehog.Skip where++import           Control.Monad.IO.Class (MonadIO(..))++import           Data.Foldable (for_)+import           Data.IORef (IORef)+import qualified Data.IORef as IORef++import           Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import qualified Hedgehog.Internal.Config as Config+import           Hedgehog.Internal.Property (Skip(..), ShrinkPath(..), skipCompress, skipDecompress)+import qualified Hedgehog.Internal.Property as Property+import qualified Hedgehog.Internal.Runner as Runner+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.+--+skipTestProperty :: IORef [(Size, Int, Bool)] -> Property+skipTestProperty logRef =+  withTests 5 . property $ do+    val@(curSize, _, shouldPass) <- forAll $ do+      curSize <- Gen.sized pure+      (shouldPass, nShrinks) <-+        (,)+          <$> Gen.shrink (\b -> if b then [] else [True]) (pure $ curSize /= 2)+          <*> Gen.shrink (\n -> reverse [0 .. n-1]) (pure 3)+      pure (curSize, nShrinks, shouldPass)++    -- Fail coverage to make sure we disable it when shrinking.+    cover 100 "Not 4" (curSize /= 4)++    liftIO $ IORef.modifyIORef' logRef (val :)+    assert shouldPass++checkProp :: MonadIO m => Property -> m (Report Result)+checkProp prop = do+  seed <- Config.resolveSeed Nothing+  liftIO $ Runner.checkReport+    (Property.propertyConfig prop)+    0+    seed+    (Property.propertyTest prop)+    (const $ pure ())++prop_SkipNothing :: Property+prop_SkipNothing =+  withTests 1 . property $ do+    logRef <- liftIO $ IORef.newIORef []+    let+      prop =+        withSkip "" $ skipTestProperty logRef++    report <- checkProp prop+    case reportStatus report of+      Failed f -> do+        failureShrinks f === 3+        failureShrinkPath f === ShrinkPath [1, 1, 1]++      _ ->+        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)+      ]++prop_SkipToFailingTest :: Property+prop_SkipToFailingTest =+  withTests 1 . property $ do+    logRef <- liftIO $ IORef.newIORef []+    let+      prop =+        withSkip "3" $ skipTestProperty logRef++    report <- checkProp prop+    case reportStatus report of+      Failed f -> do+        failureShrinks f === 3+        failureShrinkPath f === ShrinkPath [1, 1, 1]++      _ ->+        failure++    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)+      ]++prop_SkipPastFailingTest :: Property+prop_SkipPastFailingTest =+  withTests 1 . property $ do+    logRef <- liftIO $ IORef.newIORef []+    let+      prop =+        withSkip "4" $ skipTestProperty logRef++    report <- checkProp prop+    reportStatus report === OK++    logs <- liftIO $ reverse <$> IORef.readIORef logRef+    logs === [(3, 3, True), (4, 3, True)]++prop_SkipToNoShrink :: Property+prop_SkipToNoShrink =+  withTests 1 . property $ do+    logRef <- liftIO $ IORef.newIORef []+    let+      prop =+        withSkip "3:" $ skipTestProperty logRef++    report <- checkProp prop+    case reportStatus report of+      Failed f -> do+        failureShrinks f === 0+        failureShrinkPath f === Property.ShrinkPath []++      _ ->+        failure++    logs <- liftIO $ reverse <$> IORef.readIORef logRef+    logs === [(2, 3, False)]++prop_SkipToFailingShrink :: Property+prop_SkipToFailingShrink =+  withTests 1 . property $ do+    logRef <- liftIO $ IORef.newIORef []+    let+      prop =+        withSkip "3:b2" $ skipTestProperty logRef++    report <- checkProp prop+    case reportStatus report of+      Failed f -> do+        failureShrinks f === 2+        failureShrinkPath f === Property.ShrinkPath [1, 1]++      _ ->+        failure++    logs <- liftIO $ reverse <$> IORef.readIORef logRef+    logs === [(2, 3, False), (2, 2, False), (2, 1, False)]++prop_SkipToPassingShrink :: Property+prop_SkipToPassingShrink =+  withTests 1 . property $ do+    logRef <- liftIO $ IORef.newIORef []+    let+      prop =+        withSkip "3:bA" $ skipTestProperty logRef++    report <- checkProp prop+    reportStatus report === OK++    logs <- liftIO $ reverse <$> IORef.readIORef logRef+    logs === [(2, 3, False), (2, 2, False), (2, 2, True)]++genSkip :: Gen Skip+genSkip =+  let+    range =+      Range.linear 0 100++    genTestCount =+      Property.TestCount <$> Gen.int range++    genShrinkPath =+      Property.ShrinkPath <$> Gen.list range (Gen.int range)+  in+    Gen.choice+      [ pure SkipNothing+      , SkipToTest <$> genTestCount+      , SkipToShrink <$> genTestCount <*> genShrinkPath+      ]++-- | Test that `skipCompress` and `skipDecompress` roundtrip.+prop_compressSkip :: Property+prop_compressSkip =+  property $ do+    skip <- forAll genSkip+    tripping skip Property.skipCompress Property.skipDecompress++-- | Demonstrate some example compressions.+--+--   In general it's probably fine for compressions to change between hedgehog+--   versions. There's not much reason to share them or save them long-term. So+--   breaking this test isn't necessarily a problem, if it's done deliberately.+--+--   But it's useful to have examples, to avoid accidentally changing the+--   compression format and to demonstrate edge cases.+prop_compressDecompressExamples :: Property+prop_compressDecompressExamples =+  withTests 1 . property $ do+    let+      -- Each test case has a Skip, the result of compressing it, and some other+      -- 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]+          , "5:cDa"+          , ["5:CdA", "05:c1b0D1A1"]+          )+        , ( SkipToShrink 21 $ Property.ShrinkPath [5, 3, 27, 27, 26]+          , "21:fDbb2BA"+          , ["21:fDbbBBba"]+          )+        ]++    for_ testCases $ \(skip, compressed, otherCompressions) -> do+      skipCompress skip === compressed+      for_ (compressed : otherCompressions) $ \c ->+        skipDecompress c === Just skip++tests :: IO Bool+tests =+  checkParallel $$(discover)

@@ -5,6 +5,7 @@ import qualified Test.Hedgehog.Filter import qualified Test.Hedgehog.Maybe import qualified Test.Hedgehog.Seed+import qualified Test.Hedgehog.Skip import qualified Test.Hedgehog.Text import qualified Test.Hedgehog.Zip @@ -17,6 +18,7 @@     , Test.Hedgehog.Filter.tests     , Test.Hedgehog.Maybe.tests     , Test.Hedgehog.Seed.tests+    , Test.Hedgehog.Skip.tests     , Test.Hedgehog.Text.tests     , Test.Hedgehog.Zip.tests     ]