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 ]