Script 'mail_helper' called by obssrc
Hello community,

here is the log from the commit of package ghc-hedgehog for openSUSE:Factory 
checked in at 2023-01-18 13:11:19
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-hedgehog (Old)
 and      /work/SRC/openSUSE:Factory/.ghc-hedgehog.new.32243 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Package is "ghc-hedgehog"

Wed Jan 18 13:11:19 2023 rev:9 rq:1059313 version:1.2

Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-hedgehog/ghc-hedgehog.changes        
2022-10-13 15:44:39.115031531 +0200
+++ /work/SRC/openSUSE:Factory/.ghc-hedgehog.new.32243/ghc-hedgehog.changes     
2023-01-18 13:11:42.205056331 +0100
@@ -1,0 +2,10 @@
+Sat Sep 27 22:16:11 UTC 2022 - Peter Simons <psim...@suse.com>
+
+- Update hedgehog to version 1.2.
+  * Allow skipping to a specific test number or shrink result
+    * Export shrinkPathCompress and shrinkPathDecompress
+  * Add Gen.subset
+  * Add example for Gen.subsequence
+  * Don't drop actions depending on shrunk predecessors
+
+-------------------------------------------------------------------
@@ -5,4 +15,2 @@
-  Upstream has edited the change log file since the last release in
-  a non-trivial way, i.e. they did more than just add a new entry
-  at the top. You can review the file at:
-  http://hackage.haskell.org/package/hedgehog-1.1.2/src/CHANGELOG.md
+  * Support GHC 9.4
+  * Allow newer dependencies
@@ -75 +82,0 @@
-

Old:
----
  hedgehog-1.1.2.tar.gz

New:
----
  hedgehog-1.2.tar.gz

++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Other differences:
------------------
++++++ ghc-hedgehog.spec ++++++
--- /var/tmp/diff_new_pack.GQwMnY/_old  2023-01-18 13:11:42.653058066 +0100
+++ /var/tmp/diff_new_pack.GQwMnY/_new  2023-01-18 13:11:42.657058082 +0100
@@ -19,7 +19,7 @@
 %global pkg_name hedgehog
 %bcond_with tests
 Name:           ghc-%{pkg_name}
-Version:        1.1.2
+Version:        1.2
 Release:        0
 Summary:        Release with confidence
 License:        BSD-3-Clause

++++++ hedgehog-1.1.2.tar.gz -> hedgehog-1.2.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' 
'--exclude=.svnignore' old/hedgehog-1.1.2/CHANGELOG.md 
new/hedgehog-1.2/CHANGELOG.md
--- old/hedgehog-1.1.2/CHANGELOG.md     2022-09-02 17:43:34.000000000 +0200
+++ new/hedgehog-1.2/CHANGELOG.md       2022-08-27 22:39:31.000000000 +0200
@@ -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]:
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' 
'--exclude=.svnignore' old/hedgehog-1.1.2/hedgehog.cabal 
new/hedgehog-1.2/hedgehog.cabal
--- old/hedgehog-1.1.2/hedgehog.cabal   2022-09-02 17:44:44.000000000 +0200
+++ new/hedgehog-1.2/hedgehog.cabal     2001-09-09 03:46:40.000000000 +0200
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' 
'--exclude=.svnignore' old/hedgehog-1.1.2/src/Hedgehog/Gen.hs 
new/hedgehog-1.2/src/Hedgehog/Gen.hs
--- old/hedgehog-1.1.2/src/Hedgehog/Gen.hs      2001-09-09 03:46:40.000000000 
+0200
+++ new/hedgehog-1.2/src/Hedgehog/Gen.hs        2001-09-09 03:46:40.000000000 
+0200
@@ -94,6 +94,7 @@
 
   -- ** Combinations & Permutations
   , subsequence
+  , subset
   , shuffle
 
   -- ** Abstract State Machine
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' 
'--exclude=.svnignore' old/hedgehog-1.1.2/src/Hedgehog/Internal/Config.hs 
new/hedgehog-1.2/src/Hedgehog/Internal/Config.hs
--- old/hedgehog-1.1.2/src/Hedgehog/Internal/Config.hs  2001-09-09 
03:46:40.000000000 +0200
+++ new/hedgehog-1.2/src/Hedgehog/Internal/Config.hs    2001-09-09 
03:46:40.000000000 +0200
@@ -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 ->
@@ -193,3 +214,10 @@
     detectWorkers
   Just x ->
     pure x
+
+resolveSkip :: MonadIO m => Maybe Skip -> m Skip
+resolveSkip = \case
+  Nothing ->
+    detectSkip
+  Just x ->
+    pure x
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' 
'--exclude=.svnignore' old/hedgehog-1.1.2/src/Hedgehog/Internal/Gen.hs 
new/hedgehog-1.2/src/Hedgehog/Internal/Gen.hs
--- old/hedgehog-1.1.2/src/Hedgehog/Internal/Gen.hs     2022-09-02 
17:45:07.000000000 +0200
+++ new/hedgehog-1.2/src/Hedgehog/Internal/Gen.hs       2001-09-09 
03:46:40.000000000 +0200
@@ -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,10 +1664,37 @@
 
 -- | 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.
 --
 --   /This shrinks towards the order of the list being identical to the input/
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' 
'--exclude=.svnignore' old/hedgehog-1.1.2/src/Hedgehog/Internal/Property.hs 
new/hedgehog-1.2/src/Hedgehog/Internal/Property.hs
--- old/hedgehog-1.1.2/src/Hedgehog/Internal/Property.hs        2001-09-09 
03:46:40.000000000 +0200
+++ new/hedgehog-1.2/src/Hedgehog/Internal/Property.hs  2001-09-09 
03:46:40.000000000 +0200
@@ -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,6 +186,9 @@
 
 import           Language.Haskell.TH.Syntax (Lift)
 
+import qualified Numeric
+
+import           Text.Read (readMaybe)
 
 ------------------------------------------------------------------------
 
@@ -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'
@@ -1077,6 +1256,12 @@
 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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' 
'--exclude=.svnignore' old/hedgehog-1.1.2/src/Hedgehog/Internal/Report.hs 
new/hedgehog-1.2/src/Hedgehog/Internal/Report.hs
--- old/hedgehog-1.1.2/src/Hedgehog/Internal/Report.hs  2001-09-09 
03:46:40.000000000 +0200
+++ new/hedgehog-1.2/src/Hedgehog/Internal/Report.hs    2001-09-09 
03:46:40.000000000 +0200
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' 
'--exclude=.svnignore' old/hedgehog-1.1.2/src/Hedgehog/Internal/Runner.hs 
new/hedgehog-1.2/src/Hedgehog/Internal/Runner.hs
--- old/hedgehog-1.1.2/src/Hedgehog/Internal/Runner.hs  2001-09-09 
03:46:40.000000000 +0200
+++ new/hedgehog-1.2/src/Hedgehog/Internal/Runner.hs    2001-09-09 
03:46:40.000000000 +0200
@@ -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,40 +119,88 @@
 
 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
-
-  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)
-
-        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
+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
+              shrinkPath =
+                ShrinkPath $ reverse revShrinkPath
+              failure =
+                mkFailure shrinks shrinkPath Nothing loc err mdiff (reverse 
logs)
+
+            updateUI $ Shrinking failure
+
+            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.
@@ -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,53 +310,69 @@
         -- 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
-
-              Just (Left _, _) ->
-                let
-                  mkReport =
-                    Report (tests + 1) discards coverage0
-                in
-                  fmap mkReport $
-                    takeSmallest
-                      size
-                      seed
-                      0
-                      (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
+          (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 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
+
+  loop 0 0 size0 seed0 mempty
 
 checkRegion ::
      MonadIO m
@@ -358,6 +435,14 @@
     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.
 --
 checkGroup :: MonadIO m => RunnerConfig -> Group -> m Bool
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' 
'--exclude=.svnignore' old/hedgehog-1.1.2/src/Hedgehog/Internal/State.hs 
new/hedgehog-1.2/src/Hedgehog/Internal/State.hs
--- old/hedgehog-1.1.2/src/Hedgehog/Internal/State.hs   2001-09-09 
03:46:40.000000000 +0200
+++ new/hedgehog-1.2/src/Hedgehog/Internal/State.hs     2001-09-09 
03:46:40.000000000 +0200
@@ -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)
 
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' 
'--exclude=.svnignore' old/hedgehog-1.1.2/src/Hedgehog.hs 
new/hedgehog-1.2/src/Hedgehog.hs
--- old/hedgehog-1.1.2/src/Hedgehog.hs  2001-09-09 03:46:40.000000000 +0200
+++ new/hedgehog-1.2/src/Hedgehog.hs    2001-09-09 03:46:40.000000000 +0200
@@ -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(..))
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' 
'--exclude=.svnignore' old/hedgehog-1.1.2/test/Test/Hedgehog/Skip.hs 
new/hedgehog-1.2/test/Test/Hedgehog/Skip.hs
--- old/hedgehog-1.1.2/test/Test/Hedgehog/Skip.hs       1970-01-01 
01:00:00.000000000 +0100
+++ new/hedgehog-1.2/test/Test/Hedgehog/Skip.hs 2001-09-09 03:46:40.000000000 
+0200
@@ -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)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' 
'--exclude=.svnignore' old/hedgehog-1.1.2/test/test.hs 
new/hedgehog-1.2/test/test.hs
--- old/hedgehog-1.1.2/test/test.hs     2001-09-09 03:46:40.000000000 +0200
+++ new/hedgehog-1.2/test/test.hs       2001-09-09 03:46:40.000000000 +0200
@@ -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
     ]

Reply via email to