hedgehog 1.2 → 1.7
raw patch · 13 files changed
Files
- CHANGELOG.md +141/−1
- README.md +15/−3
- hedgehog.cabal +28/−21
- src/Hedgehog/Internal/Exception.hs +1/−1
- src/Hedgehog/Internal/Gen.hs +118/−44
- src/Hedgehog/Internal/Property.hs +39/−20
- src/Hedgehog/Internal/Region.hs +1/−1
- src/Hedgehog/Internal/Report.hs +169/−58
- src/Hedgehog/Internal/Runner.hs +12/−9
- src/Hedgehog/Internal/Seed.hs +1/−0
- src/Hedgehog/Internal/State.hs +32/−21
- src/Hedgehog/Internal/Tree.hs +7/−3
- test/Test/Hedgehog/Skip.hs +79/−39
CHANGELOG.md view
@@ -1,3 +1,55 @@+## Version 1.7 (2025-09-22)++* Fix eta-reduction issues for GHC 9.0; add CI and cabal support for GHC 9.0.2 ([#557][557], [@tomjaguarpaw][tomjaguarpaw])+* Allow lifted-async 0.11 ([#556][556], [@felixonmars][felixonmars])+* Remove `fromJust` call by using a separate existential wrapper ([#554][554], [@HuwCampbell][HuwCampbell])++## Version 1.6 (2025-09-08)++* Fix GitHub CI URL ([#545][545], [@tmcgilchrist][tmcgilchrist])+* Bump upper bounds for containers and random ([#544][544], [@moodmosaic][moodmosaic])+* Support GHC 9.12 ([#540][540], [@erikd][erikd])+* Add callstacks to generators that can error ([#538][538], [@ChickenProp][ChickenProp])+* Drop support for GHC 8.0.2 ([#538][538], [@ChickenProp][ChickenProp])++## Version 1.5 (2024-07-25)++* Bump containers and filepath dependencies ([#533][533], [@erikd][erikd])+* Hedgehog.Internal.Report: Add `configPrintShrinkPath` ([#531][531], [@sol][sol])+* Allow GHC 9.10 ([#530][530], [@erikd][erikd])+* hedgehog-{example,quickcheck,test-laws}: Raise QuickCheck bound ([#529][529], [@JackKelly-Bellroy][JackKelly-Bellroy])+* Allow to omit icons at the start of important output lines ([#524][524], [@sol][sol])+* Allow to omit source location from report ([#523][523], [@sol][sol])+* Fix "insufficient coverage" message ([#521][521], [@sol][sol])+* Support empty property names ([#520][520], [@sol][sol])+* Allow to disable the `recheckAt`-message ([#519][519], [@sol][sol])+* Remove redundant `Show` constraints: `evalMaybe`, `evalMaybeM` ([#516][516], [@endgame][endgame])+* Relax upper bound on `ansi-terminal` ([#515][515], [@moodmosaic][moodmosaic])+* Report.hs refactoring ([#514][514], [@sol][sol])+* Relax time dependency to < 1.15 ([#513][513], [@tomjaguarpaw][tomjaguarpaw])+* Bump barbies upper bound ([#510][510], [@jchia][jchia])+* Support primitive 0.9 ([#509][509], [@Vekhir][Vekhir])+* Show less context on failure ([#505][505], [@sol][sol])+* Allow GHC 9.8 ([#504][504], [@tomjaguarpaw][tomjaguarpaw])+* Wrap `evalMaybeM` and `evalEitherM` in `withFrozenCallStack` ([#499][499], [@ocharles][ocharles])++## Version 1.4 (2023-08-07)++* Fix skipping to tests/shrinks when tests have been discarded ([#489][489], [@ChickenProp][ChickenProp])++## Version 1.3 (2023-06-22)++* Better documentation for `Var` ([#491][491], [@endgame][endgame])+* Bump upper bounds for `ansi-terminal` ([#486][486], [@mpilgrem][mpilgrem])+* Better documentation for `Gen.filter[T]`, `Gen.mapMaybe[T]`, `Tree.prune` ([#485][485], [@ChickenProp][ChickenProp])+* Update Github CI actions, exclude Haddocks for old GHCs ([#482][482], [@ysangkok][ysangkok])+* Support GHC 9.6 ([#481][481], [@ysangkok][ysangkok])+* Bump upper bounds for `resourcet` and `primitive` ([#478][478], [@shlevy][shlevy])+* Export `Hedgehog.Internal.Seed.seed` ([#477][477], [@sol][sol])+* Better documentation for `sample` ([#468][468], [@parsonsmatt][parsonsmatt])+* Replace exceptions dependency with safe-exceptions ([#466][466], [@ocharles][ocharles])+* Generalise `Hedgehog.Gen.element` ([#411](411), [@ocharles][ocharles])+ ## Version 1.2 (2022-08-28) * Allow skipping to a specific test number or shrink result ([#454][454], [@ChickenProp][ChickenProp])@@ -8,6 +60,11 @@ * 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.2 (2022-09-02)++* Support GHC 9.4 ([#461][461], [@ysangkok][ysangkok])+* Allow newer dependencies ([#457][457], [@ysangkok][ysangkok])+ ## Version 1.1.1 (2022-01-29) * Support using fixed seed via `HEDGEHOG_SEED` ([#446][446], [@simfleischman][simfleischman] / [@moodmosaic][moodmosaic])@@ -260,8 +317,89 @@ https://github.com/mbg [jhrcek]: https://github.com/jhrcek-+[parsonsmatt]:+ https://github.com/parsonsmatt+[shlevy]:+ https://github.com/shlevy+[sol]:+ https://github.com/sol+[JackKelly-Bellroy]:+ https://github.com/JackKelly-Bellroy+[jchia]:+ https://github.com/jchia+[Vekhir]:+ https://github.com/Vekhir+[tmcgilchrist]:+ https://github.com/tmcgilchrist +[557]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/557+[556]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/556+[554]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/554+[544]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/544+[540]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/540+[538]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/538+[533]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/533+[531]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/531+[530]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/530+[529]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/529+[524]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/524+[523]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/523+[521]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/521+[520]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/520+[519]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/519+[516]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/516+[515]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/515+[514]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/514+[513]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/513+[510]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/510+[509]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/509+[505]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/505+[504]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/504+[499]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/499+[491]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/491+[489]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/489+[486]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/486+[485]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/485+[482]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/482+[481]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/481+[478]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/478+[477]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/477+[468]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/468+[466]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/466 [462]: https://github.com/hedgehogqa/haskell-hedgehog/pull/462 [461]:@@ -292,6 +430,8 @@ https://github.com/hedgehogqa/haskell-hedgehog/pull/413 [412]: https://github.com/hedgehogqa/haskell-hedgehog/pull/412+[411]:+ https://github.com/hedgehogqa/haskell-hedgehog/pull/411 [409]: https://github.com/hedgehogqa/haskell-hedgehog/pull/409 [408]:
README.md view
@@ -3,6 +3,8 @@ doesn't seem to render the HTML portion of the markdown spec so you may be better off paying us a visit on GitHub instead: https://github.com/hedgehogqa/haskell-hedgehog++https://preview.webflow.com/preview/hedgehogqa?utm_medium=preview_link&utm_source=dashboard&utm_content=hedgehogqa&preview=e42e956627c1ec686ee73fc48a20fb71&workflow=preview --> <div align="center">@@ -15,7 +17,7 @@ <div align="left"> -[Hedgehog](http://hedgehog.qa/) automatically generates a comprehensive array of test cases, exercising your software in ways human testers would never imagine.+[Hedgehog](https://hackage.haskell.org/package/hedgehog) automatically generates a comprehensive array of test cases, exercising your software in ways human testers would never imagine. Generate hundreds of test cases automatically, exposing even the most insidious of corner cases. Failures are automatically simplified, giving developers coherent, intelligible error messages. @@ -87,6 +89,16 @@ ``` +## In Memory of Jacob Stanley++As we come to the end of our guide to haskell-hedgehog, we'd like to take a moment to remember and honor one of its key contributors, our dear friend, author and co-founder, Jacob Stanley.++Jacob's passion for Haskell and his commitment to creating high-quality, reliable software was truly inspiring. His work has shaped haskell-hedgehog in countless ways, and without him, it wouldn't be the project it is today.++Jacob passed away unexpectedly on April 9th. His absence is deeply felt, but his impact on this project, and on all of us who had the privilege to work with him, remains. We continue to maintain and develop haskell-hedgehog in his memory and in honor of his dedication to excellence in programming.++As you explore haskell-hedgehog, and possibly contribute to its ongoing development, we invite you to join us in remembering Jacob Stanley — a tremendous developer, collaborator, and friend.+ <div align="center"> <br /> <img width="307" src="https://github.com/hedgehogqa/haskell-hedgehog/raw/master/img/hedgehog-logo-grey.png" />@@ -100,8 +112,8 @@ [hackage]: http://hackage.haskell.org/package/hedgehog [hackage-shield]: https://img.shields.io/hackage/v/hedgehog.svg?style=flat - [github-shield]: https://github.com/hedgehogqa/haskell-hedgehog/actions/workflows/ci.yaml/badge.svg- [github-ci]: https://github.com/hedgehogqa/haskell-hedgehog/actions/workflows/ci.yaml+ [github-shield]: https://github.com/hedgehogqa/haskell-hedgehog/actions/workflows/haskell-ci.yml/badge.svg+ [github-ci]: https://github.com/hedgehogqa/haskell-hedgehog/actions/workflows/haskell-ci.yml [haddock-hedgehog]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog.html [haddock-hedgehog-gen]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog-Gen.html
hedgehog.cabal view
@@ -1,4 +1,4 @@-version: 1.2+version: 1.7 name: hedgehog@@ -7,13 +7,13 @@ maintainer: Jacob Stanley <jacob@stanley.io> homepage:- https://hedgehog.qa+ http://github.com/hedgehogqa/haskell-hedgehog bug-reports: https://github.com/hedgehogqa/haskell-hedgehog/issues synopsis: Release with confidence. description:- <http://hedgehog.qa/ Hedgehog> automatically generates a comprehensive array+ <http://github.com/hedgehogqa/haskell-hedgehog/ Hedgehog> automatically generates a comprehensive array of test cases, exercising your software in ways human testers would never imagine. .@@ -33,47 +33,54 @@ build-type: Simple tested-with:- GHC == 8.0.2- , GHC == 8.2.2+ GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.3 , GHC == 8.10.1- , GHC == 9.2.1+ , GHC == 9.0.2+ , GHC == 9.2.7+ , GHC == 9.4.8+ , GHC == 9.6.6+ , GHC == 9.8.4+ , GHC == 9.10.1+ , GHC == 9.12.1+ extra-source-files: README.md CHANGELOG.md source-repository head type: git- location: git://github.com/hedgehogqa/haskell-hedgehog.git+ location: https://github.com/hedgehogqa/haskell-hedgehog library build-depends: -- GHC 8.0.1 / base-4.9.0.0 (May 2016) base >= 4.9 && < 5- , ansi-terminal >= 0.6 && < 0.12+ , ansi-terminal >= 0.6 && < 1.2 , async >= 2.0 && < 2.3- , barbies >= 1.0 && < 2.1- , bytestring >= 0.10 && < 0.12+ , barbies >= 1.0 && < 2.2+ , bytestring >= 0.10 && < 0.13 , concurrent-output >= 1.7 && < 1.11- , containers >= 0.4 && < 0.7- , deepseq >= 1.1.0.0 && < 1.5+ , containers >= 0.4 && < 0.9+ , deepseq >= 1.1.0.0 && < 1.6 , directory >= 1.2 && < 1.4 , erf >= 2.0 && < 2.1 , exceptions >= 0.7 && < 0.11- , lifted-async >= 0.7 && < 0.11+ , lifted-async >= 0.7 && < 0.12 , mmorph >= 1.0 && < 1.3 , monad-control >= 1.0 && < 1.1 , mtl >= 2.1 && < 2.4 , pretty-show >= 1.6 && < 1.11- , primitive >= 0.6 && < 0.8- , random >= 1.1 && < 1.3- , resourcet >= 1.1 && < 1.3+ , primitive >= 0.6 && < 0.10+ , random >= 1.1 && < 1.4+ , resourcet >= 1.1 && < 1.4+ , safe-exceptions >= 0.1 && < 0.2 , stm >= 2.4 && < 2.6- , template-haskell >= 2.10 && < 2.20- , text >= 1.1 && < 2.1- , time >= 1.4 && < 1.13+ , template-haskell >= 2.10 && < 2.24+ , text >= 1.1 && < 2.2+ , time >= 1.4 && < 1.15 , transformers >= 0.5 && < 0.7 , transformers-base >= 0.4.5.1 && < 0.5 , wl-pprint-annotated >= 0.0 && < 0.2@@ -143,11 +150,11 @@ build-depends: hedgehog , base >= 3 && < 5- , containers >= 0.4 && < 0.7+ , containers >= 0.4 && < 0.9 , mmorph >= 1.0 && < 1.3 , mtl >= 2.1 && < 2.4 , pretty-show >= 1.6 && < 1.11- , text >= 1.1 && < 2.1+ , text >= 1.1 && < 2.2 , transformers >= 0.3 && < 0.7 default-language:
src/Hedgehog/Internal/Exception.hs view
@@ -5,7 +5,7 @@ ) where import Control.Exception (Exception(..), AsyncException, SomeException(..), evaluate)-import Control.Monad.Catch (MonadCatch(..), throwM)+import Control.Exception.Safe (MonadCatch, catch, throwM) import System.IO.Unsafe (unsafePerformIO)
src/Hedgehog/Internal/Gen.hs view
@@ -175,11 +175,14 @@ , subtermMVec ) where -import Control.Applicative (Alternative(..),liftA2)+#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+#endif+import Control.Applicative (Alternative(..)) import Control.Monad (MonadPlus(..), filterM, guard, replicateM, join) import Control.Monad.Base (MonadBase(..))+import Control.Monad.Catch (MonadThrow(throwM), MonadCatch(catch)) import Control.Monad.Trans.Control (MonadBaseControl(..))-import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Morph (MFunctor(..), MMonad(..))@@ -228,6 +231,7 @@ import Hedgehog.Internal.Seed (Seed) import qualified Hedgehog.Internal.Seed as Seed import qualified Hedgehog.Internal.Shrink as Shrink+import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack) import Hedgehog.Internal.Tree (Tree, TreeT(..), NodeT(..)) import qualified Hedgehog.Internal.Tree as Tree import Hedgehog.Range (Size, Range)@@ -746,18 +750,19 @@ -- | Adjust the size parameter by transforming it with the given function. ---scale :: MonadGen m => (Size -> Size) -> m a -> m a+scale :: (HasCallStack, MonadGen m) => (Size -> Size) -> m a -> m a scale f =- withGenT $ \gen ->- GenT $ \size0 seed ->- let- size =- f size0- in- if size < 0 then- error "Hedgehog.Gen.scale: negative size"- else- runGenT size seed gen+ withFrozenCallStack $+ withGenT $ \gen ->+ GenT $ \size0 seed ->+ let+ size =+ f size0+ in+ if size < 0 then+ error "Hedgehog.Gen.scale: negative size"+ else+ runGenT size seed gen -- | Make a generator smaller by scaling its size parameter. --@@ -1188,10 +1193,10 @@ -- -- /The input list must be non-empty./ ---element :: MonadGen m => [a] -> m a-element = \case+element :: (HasCallStack, Foldable f, MonadGen m) => f a -> m a+element fa = withFrozenCallStack $ case toList fa of [] ->- error "Hedgehog.Gen.element: used with empty list"+ error "Hedgehog.Gen.element: used with empty Foldable" xs -> do n <- integral $ Range.constant 0 (length xs - 1) pure $ xs !! n@@ -1202,8 +1207,8 @@ -- -- /The input list must be non-empty./ ---element_ :: MonadGen m => [a] -> m a-element_ = \case+element_ :: (HasCallStack, MonadGen m) => [a] -> m a+element_ l = withFrozenCallStack $ case l of [] -> error "Hedgehog.Gen.element: used with empty list" xs -> do@@ -1216,8 +1221,8 @@ -- -- /The input list must be non-empty./ ---choice :: MonadGen m => [m a] -> m a-choice = \case+choice :: (HasCallStack, MonadGen m) => [m a] -> m a+choice l = withFrozenCallStack $ case l of [] -> error "Hedgehog.Gen.choice: used with empty list" xs -> do@@ -1231,8 +1236,8 @@ -- -- /The input list must be non-empty./ ---frequency :: MonadGen m => [(Int, m a)] -> m a-frequency = \case+frequency :: (HasCallStack, MonadGen m) => [(Int, m a)] -> m a+frequency l = withFrozenCallStack $ case l of [] -> error "Hedgehog.Gen.frequency: used with empty list" xs0 -> do@@ -1325,19 +1330,33 @@ -- | Generates a value that satisfies a predicate. ----- This is essentially:------ @--- filter p gen = 'mfilter' p gen '<|>' filter p gen--- @+-- Shrinks of the generated value will also satisfy the predicate. From the+-- original generator's shrink tree, any values that fail the predicate will+-- be removed, but any subsequent shrinks that satisfy it will be retained.+-- Compared to 'filter', shrinking may be slower but will be optimal. ----- It differs from the above in that we keep some state to avoid looping--- forever. If we trigger these limits then the whole generator is discarded.+-- It's possible that the predicate will never pass, or will only pass at a+-- larger size than we're currently running at. To avoid looping forever, we+-- limit the number of retries, and grow the size with each retry. If we retry+-- too many times then the whole generator is discarded. -- filter :: (MonadGen m, GenBase m ~ Identity) => (a -> Bool) -> m a -> m a filter p = mapMaybe (fromPred p) +-- | Generates a value which is the result of the given function returning a+-- 'Just'.+--+-- The original generator's shrink tree will be retained, with values+-- returning 'Nothing' removed. Subsequent shrinks of those values will be+-- retained. Compared to 'mapMaybeT', shrinking may be slower but will be+-- optimal.+--+-- It's possible that the function will never return 'Just', or will only do+-- so a larger size than we're currently running at. To avoid looping forever,+-- we limit the number of retries, and grow the size with each retry. If we+-- retry too many times then the whole generator is discarded.+-- mapMaybe :: (MonadGen m, GenBase m ~ Identity) => (a -> Maybe b) -> m a -> m b mapMaybe p gen0 = let@@ -1355,10 +1374,50 @@ in try 0 +-- | Generates a value that satisfies a predicate.+--+-- Shrinks of the generated value will also satisfy the predicate. From the+-- original generator's shrink tree, any values that fail the predicate will+-- be removed, along with their subsequent shrinks. Compared to 'filter',+-- shrinking may be faster but may also be less optimal.+--+-- The type is also more general, because the shrink behavior from 'filter'+-- would force the entire shrink tree to be evaluated when applied to an+-- impure tree.+--+-- This is essentially:+--+-- @+-- filterT p gen = 'mfilter' p gen '<|>' filterT p gen+-- @+--+-- But that could loop forever, if the predicate will never pass or will only+-- pass at a larger size than we're currently running at. We differ from the+-- above in keeping some state to avoid that. We limit the number of retries,+-- and grow the size with each retry. If we retry too many times then the+-- whole generator is discarded.+-- filterT :: MonadGen m => (a -> Bool) -> m a -> m a filterT p = mapMaybeT (fromPred p) +-- | Generates a value which is the result of the given function returning a+-- 'Just'.+--+-- The original generator's shrink tree will be retained, with values+-- returning 'Nothing' removed. Subsequent shrinks of those values will be+-- retained. Compared to 'mapMaybeT', shrinking may be slower but will be+-- optimal.+--+-- The type is also more general, because the shrink behavior from 'mapMaybe'+-- would force the entire shrink tree to be evaluated when applied to an+-- impure tree.+--+-- It's possible that the function will never return 'Just', or will only do+-- so a larger size than we're currently running at. To avoid looping forever,+-- we limit the number of retries, and grow the size with each retry. If we+-- retry too many times then the whole generator is discarded.+-- mapMaybeT :: MonadGen m => (a -> Maybe b) -> m a -> m b mapMaybeT p gen0 = let@@ -1744,22 +1803,37 @@ -- | Generate a sample from a generator. ---sample :: MonadIO m => Gen a -> m a+-- This function is useful for examining a 'Gen' in GHCi or other contexts.+-- It is not appropriate for use in a test suite directly. You will only+-- get a single sample from this function, and it will not give you+-- a property test. The seed is random, so the test is not deterministic.+--+-- If you only want a single test to run, then use @'withTests' 1@:+--+-- @+-- prop_OnlyRunOnce :: Property+-- prop_OnlyRunOnce =+-- 'withTests' 1 $ 'property' $ do+-- i <- Gen.int+-- i /== 0+-- @+sample :: (HasCallStack, MonadIO m) => Gen a -> m a sample gen =- liftIO $- let- loop n =- if n <= 0 then- error "Hedgehog.Gen.sample: too many discards, could not generate a sample"- else do- seed <- Seed.random- case evalGen 30 seed gen of- Nothing ->- loop (n - 1)- Just x ->- pure $ Tree.treeValue x- in- loop (100 :: Int)+ withFrozenCallStack $+ liftIO $+ let+ loop n =+ if n <= 0 then+ error "Hedgehog.Gen.sample: too many discards, could not generate a sample"+ else do+ seed <- Seed.random+ case evalGen 30 seed gen of+ Nothing ->+ loop (n - 1)+ Just x ->+ pure $ Tree.treeValue x+ in+ loop (100 :: Int) -- | Run a generator with a random seed and print the outcome, and the first -- level of shrinks.
src/Hedgehog/Internal/Property.hs view
@@ -136,10 +136,10 @@ import Control.Applicative (Alternative(..)) import Control.DeepSeq (NFData, rnf)+import Control.Exception.Safe (MonadThrow, MonadCatch)+import Control.Exception.Safe (SomeException(..), displayException) import Control.Monad (MonadPlus(..), (<=<)) import Control.Monad.Base (MonadBase(..))-import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))-import Control.Monad.Catch (SomeException(..), displayException) import Control.Monad.Error.Class (MonadError(..)) import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class (MonadIO(..))@@ -306,13 +306,17 @@ -- newtype TestCount = TestCount Int- deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)+ deriving (Eq, Ord, Num, Enum, Real, Integral, Lift) +instance Show TestCount where+ showsPrec p (TestCount n) =+ showsPrec p n+ -- | The number of tests a property had to discard. -- newtype DiscardCount = DiscardCount Int- deriving (Eq, Ord, Show, Num, Enum, Real, Integral)+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift) -- | The number of discards to allow before giving up. --@@ -355,7 +359,10 @@ -- | Skip to a specific test number. If it fails, shrink as normal. If it -- passes, move on to the next test. Coverage checks are disabled. --- | SkipToTest TestCount+ -- We also need to count discards, since failing "after 7 tests" points at a+ -- different generated value than failing "after 7 tests and 5 discards".+ --+ | SkipToTest TestCount DiscardCount -- | Skip to a specific test number and shrink state. If it fails, stop -- without shrinking further. If it passes, the property will pass without@@ -365,7 +372,7 @@ -- the direct path from the original test input to the target state - will -- be tested too, and their results discarded. --- | SkipToShrink TestCount ShrinkPath+ | SkipToShrink TestCount DiscardCount ShrinkPath deriving (Eq, Ord, Show, Lift) -- | We use this instance to support usage like@@ -402,13 +409,17 @@ -- roughly interpret it by eyeball. -- skipCompress :: Skip -> String-skipCompress = \case- SkipNothing ->- ""- SkipToTest (TestCount n) ->- show n- SkipToShrink (TestCount n) sp ->- show n ++ ":" ++ shrinkPathCompress sp+skipCompress =+ let+ showTD (TestCount t) (DiscardCount d) =+ show t ++ (if d == 0 then "" else "/" ++ show d)+ in \case+ SkipNothing ->+ ""+ SkipToTest t d->+ showTD t d+ SkipToShrink t d sp ->+ showTD t d ++ ":" ++ shrinkPathCompress sp -- | Compress a 'ShrinkPath' into a hopefully-short alphanumeric string. --@@ -446,14 +457,22 @@ Just SkipNothing else do let- (tcStr, spStr)+ (tcDcStr, spStr) = span (/= ':') str++ (tcStr, dcStr)+ = span (/= '/') tcDcStr+ tc <- TestCount <$> readMaybe tcStr+ dc <- DiscardCount <$> if null dcStr+ then Just 0+ else readMaybe (drop 1 dcStr)+ if null spStr then- Just $ SkipToTest tc+ Just $ SkipToTest tc dc else do sp <- shrinkPathDecompress $ drop 1 spStr- Just $ SkipToShrink tc sp+ Just $ SkipToShrink tc dc sp -- | Decompress a 'ShrinkPath'. --@@ -1016,7 +1035,7 @@ -- evalEitherM :: (MonadTest m, Show x, MonadCatch m, HasCallStack) => m (Either x a) -> m a evalEitherM =- evalEither <=< evalM+ withFrozenCallStack $ evalEither <=< evalM -- | Fails the test if the 'ExceptT' is 'Left', otherwise returns the value in -- the 'Right'.@@ -1028,7 +1047,7 @@ -- | Fails the test if the 'Maybe' is 'Nothing', otherwise returns the value in -- the 'Just'. ---evalMaybe :: (MonadTest m, Show a, HasCallStack) => Maybe a -> m a+evalMaybe :: (MonadTest m, HasCallStack) => Maybe a -> m a evalMaybe = \case Nothing -> withFrozenCallStack $ failWith Nothing "the value was Nothing"@@ -1038,9 +1057,9 @@ -- | Fails the test if the action throws an exception, or if the -- 'Maybe' is 'Nothing', otherwise returns the value in the 'Just'. ---evalMaybeM :: (MonadTest m, Show a, MonadCatch m, HasCallStack) => m (Maybe a) -> m a+evalMaybeM :: (MonadTest m, MonadCatch m, HasCallStack) => m (Maybe a) -> m a evalMaybeM =- evalMaybe <=< evalM+ withFrozenCallStack $ evalMaybe <=< evalM ------------------------------------------------------------------------ -- PropertyT
src/Hedgehog/Internal/Region.hs view
@@ -14,7 +14,7 @@ import Control.Concurrent.STM (STM, TVar) import qualified Control.Concurrent.STM.TMVar as TMVar import qualified Control.Concurrent.STM.TVar as TVar-import Control.Monad.Catch (MonadMask(..), bracket)+import Control.Exception.Safe (MonadMask, bracket) import Control.Monad.IO.Class (MonadIO(..)) import System.Console.Regions (ConsoleRegion, RegionLayout(..), LiftRegion(..))
src/Hedgehog/Internal/Report.hs view
@@ -22,13 +22,21 @@ , Style(..) , Markup(..) + , Config(..)+ , defaultConfig+ , Context(..)+ , Lines+ , PrintPrefixIcons(..)+ , renderProgress , renderResult+ , renderResultWith , renderSummary , renderDoc , ppProgress , ppResult+ , ppResultWith , ppSummary , fromResult@@ -181,7 +189,7 @@ data Line a = Line {- _lineAnnotation :: !a+ lineAnnotation :: !a , lineNumber :: !LineNo , _lineSource :: !String } deriving (Eq, Ord, Show, Functor)@@ -300,9 +308,10 @@ gutter m x = markup m ">" <+> x -icon :: Markup -> Char -> Doc Markup -> Doc Markup-icon m i x =- markup m (WL.char i) <+> x+icon :: PrintPrefixIcons -> Markup -> Char -> Doc Markup -> Doc Markup+icon p m i x = case p of+ DisablePrefixIcons -> x+ EnablePrefixIcons -> markup m (WL.char i) <+> x ppTestCount :: TestCount -> Doc a ppTestCount = \case@@ -553,9 +562,47 @@ pure $ mapSource (styleFailure . insertDoc) decl +type Annotation = (Style, [(Style, Doc Markup)])++newtype Lines = Lines Int+ deriving (Eq, Num)++instance Show Lines where+ showsPrec p (Lines n) = showsPrec p n++data Context = FullContext | Context Lines+ deriving (Eq, Show)++applyContext :: Context -> Declaration Annotation -> Declaration Annotation+applyContext context decl = case context of+ FullContext -> decl+ Context n -> decl { declarationSource = limitContextTo n (declarationSource decl) }++limitContextTo :: Lines -> Map LineNo (Line Annotation) -> Map LineNo (Line Annotation)+limitContextTo (Lines context) =+ let+ skipBoring xs = case span isBoring xs of+ (boring, []) -> take context boring+ (boring, rest) -> takeEnd context boring <> keepInteresting rest++ keepInteresting xs = case break isBoring xs of+ (interesting, rest) -> interesting <> take context rest <> skipBoring rest++ isBoring = isBoringAnnotation . lineAnnotation . snd+ in+ Map.fromList . skipBoring . Map.toList++takeEnd :: Int -> [a] -> [a]+takeEnd n = reverse . take n . reverse++isBoringAnnotation :: Annotation -> Bool+isBoringAnnotation = \ case+ (StyleDefault, []) -> True+ _ -> False+ ppDeclaration :: Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup-ppDeclaration decl =- case Map.maxView $ declarationSource decl of+ppDeclaration decl = let source = declarationSource decl in+ case Map.maxView source of Nothing -> mempty Just (lastLine, _) ->@@ -572,21 +619,36 @@ ppLineNo = WL.text . printf ("%" <> show digits <> "d") . unLineNo + ppEmptyNo :: Doc a ppEmptyNo = WL.text $ replicate digits ' ' + ppSource :: Style -> LineNo -> String -> Doc Markup ppSource style n src =+ (if isOmittedLine (pred n) then addVerticalEllipsis else id) $ markup (StyledLineNo style) (ppLineNo n) <+> markup (StyledBorder style) "┃" <+> markup (StyledSource style) (WL.text src) + addVerticalEllipsis =+ (verticalEllipsis <#>)++ verticalEllipsis =+ "\x22ee"++ isOmittedLine n =+ n >= firstLine && Map.notMember n source++ firstLine =+ fst $ Map.findMin source+ ppAnnot (style, doc) = markup (StyledLineNo style) ppEmptyNo <+> markup (StyledBorder style) "┃" <+> doc ppLines = do- Line (style, xs) n src <- Map.elems $ declarationSource decl+ Line (style, xs) n src <- Map.elems source ppSource style n src : fmap ppAnnot xs in WL.vsep (ppLocation : ppLines)@@ -622,8 +684,8 @@ ppTextLines = fmap WL.text . List.lines -ppFailureReport :: MonadIO m => Maybe PropertyName -> TestCount -> Seed -> FailureReport -> m [Doc Markup]-ppFailureReport name tests seed (FailureReport _ shrinkPath mcoverage inputs0 mlocation0 msg mdiff msgs0) = do+ppFailureReport :: MonadIO m => Config -> Maybe PropertyName -> TestCount -> DiscardCount -> Seed -> FailureReport -> m [Doc Markup]+ppFailureReport config name tests discards seed (FailureReport _ shrinkPath mcoverage inputs0 mlocation0 msg mdiff msgs0) = do let basic = -- Move the failure message to the end section if we have@@ -677,10 +739,10 @@ (args, idecls) <- fmap partitionEithers $ zipWithM ppFailedInput [0..] inputs0 let+ decls :: [Declaration (Style, [(Style, Doc Markup)])] decls =- mergeDeclarations .- catMaybes $- mlocation : coverageLocations <> fmap pure idecls+ mergeDeclarations $+ catMaybes (mlocation : coverageLocations) <> idecls with xs f = if null xs then@@ -694,54 +756,63 @@ else f xs - bottom =- maybe- [ppReproduce name seed (SkipToShrink tests shrinkPath)]- (const [])- mcoverage+ bottom = case mcoverage of+ Nothing | configPrintReproduceMessage config ->+ [ppReproduce name seed (SkipToShrink tests discards shrinkPath)]+ _ ->+ [] pure . whenSome (mempty :) . whenSome (++ [mempty]) . WL.punctuate WL.line .- fmap (WL.vsep . fmap (WL.indent 2)) .+ fmap (WL.vsep . fmap (indentBy $ configPrintPrefixIcons config)) . fmap (id :: [Doc Markup] -> [Doc Markup]) . List.filter (not . null) $ concat [ with args $ WL.punctuate WL.line , with decls $- WL.punctuate WL.line . fmap ppDeclaration+ WL.punctuate WL.line . fmap (ppDeclaration . applyContext (configContext config)) , with msgs1 $ id , with bottom $ id ] +indentBy :: PrintPrefixIcons -> Doc a -> Doc a+indentBy = \case+ DisablePrefixIcons ->+ id+ EnablePrefixIcons ->+ WL.indent 2+ ppName :: Maybe PropertyName -> Doc a ppName = \case Nothing ->- "<interactive>"+ "<interactive>" <> WL.space+ Just "" ->+ mempty Just (PropertyName name) ->- WL.text name+ WL.text name <> WL.space ppProgress :: MonadIO m => Maybe PropertyName -> Report Progress -> m (Doc Markup) ppProgress name (Report tests discards coverage _ status) = case status of Running -> pure . WL.vsep $ [- icon RunningIcon '●' . WL.annotate RunningHeader $- ppName name <+>+ icon EnablePrefixIcons RunningIcon '●' . WL.annotate RunningHeader $+ ppName name <> "passed" <+> ppTestCount tests <> ppWithDiscardCount discards <+> "(running)" ] ++- ppCoverage tests coverage+ ppCoverage EnablePrefixIcons tests coverage Shrinking failure ->- pure . icon ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $- ppName name <+>+ pure . icon EnablePrefixIcons ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $+ ppName name <> "failed" <+> ppFailedAtLocation (failureLocation failure) <#> "after" <+> ppTestCount tests <>@@ -749,45 +820,58 @@ "(shrinking)" ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup)-ppResult name (Report tests discards coverage seed result) = do+ppResult = ppResultWith defaultConfig++ppResultWith :: MonadIO m => Config -> Maybe PropertyName -> Report Result -> m (Doc Markup)+ppResultWith config name (Report tests discards coverage seed result) = do case result of Failed failure -> do- pfailure <- ppFailureReport name tests seed failure+ pfailure <- ppFailureReport config name tests discards seed failure pure . WL.vsep $ [- icon FailedIcon '✗' . WL.align . WL.annotate FailedText $- ppName name <+>- "failed" <+> ppFailedAtLocation (failureLocation failure) <#>- "after" <+>+ icon (configPrintPrefixIcons config) FailedIcon '✗' . WL.align . WL.annotate FailedText $+ ppName name <>+ (+ if configPrintFailedAtLocation config then+ "failed" <+> ppFailedAtLocation (failureLocation failure) <#> "after"+ else+ "failed after"+ ) <+> ppTestCount tests <> ppShrinkDiscard (failureShrinks failure) discards <>- "." <#>- "shrink path:" <+>- ppSkip (SkipToShrink tests $ failureShrinkPath failure)+ "." <>+ (+ if configPrintShrinkPath config then+ WL.line <>+ "shrink path:" <+>+ ppSkip (SkipToShrink tests discards $ failureShrinkPath failure)+ else+ mempty+ ) ] ++- ppCoverage tests coverage +++ ppCoverage (configPrintPrefixIcons config) tests coverage ++ pfailure GaveUp -> pure . WL.vsep $ [- icon GaveUpIcon '⚐' . WL.annotate GaveUpText $- ppName name <+>+ icon (configPrintPrefixIcons config) GaveUpIcon '⚐' . WL.annotate GaveUpText $+ ppName name <> "gave up after" <+> ppDiscardCount discards <> ", passed" <+> ppTestCount tests <> "." ] ++- ppCoverage tests coverage+ ppCoverage (configPrintPrefixIcons config) tests coverage OK -> pure . WL.vsep $ [- icon SuccessIcon '✓' . WL.annotate SuccessText $- ppName name <+>+ icon (configPrintPrefixIcons config) SuccessIcon '✓' . WL.annotate SuccessText $+ ppName name <> "passed" <+> ppTestCount tests <> "." ] ++- ppCoverage tests coverage+ ppCoverage (configPrintPrefixIcons config) tests coverage ppFailedAtLocation :: Maybe Span -> Doc Markup ppFailedAtLocation = \case@@ -799,12 +883,12 @@ Nothing -> mempty -ppCoverage :: TestCount -> Coverage CoverCount -> [Doc Markup]-ppCoverage tests x =+ppCoverage :: PrintPrefixIcons -> TestCount -> Coverage CoverCount -> [Doc Markup]+ppCoverage icons tests x = if Map.null (coverageLabels x) then mempty else- fmap (ppLabel tests (coverageWidth tests x)) .+ fmap (ppLabel icons tests (coverageWidth tests x)) . List.sortOn labelLocation $ Map.elems (coverageLabels x) @@ -876,8 +960,8 @@ in pad <> doc -ppLabel :: TestCount -> ColumnWidth -> Label CoverCount -> Doc Markup-ppLabel tests w x@(MkLabel name _ minimum_ count) =+ppLabel :: PrintPrefixIcons -> TestCount -> ColumnWidth -> Label CoverCount -> Doc Markup+ppLabel icons tests w x@(MkLabel name _ minimum_ count) = let covered = labelCovered tests x@@ -891,11 +975,14 @@ lborder = WL.annotate (StyledBorder StyleDefault) - licon =- if not covered then- WL.annotate CoverageText "⚠ "- else- " "+ licon = case icons of+ DisablePrefixIcons ->+ mempty+ EnablePrefixIcons ->+ if not covered then+ WL.annotate CoverageText "⚠ "+ else+ " " lname = WL.fill (widthName w) (ppLabelName name)@@ -1049,13 +1136,13 @@ annotateSummary :: Summary -> Doc Markup -> Doc Markup annotateSummary summary = if summaryFailed summary > 0 then- icon FailedIcon '✗' . WL.annotate FailedText+ icon EnablePrefixIcons FailedIcon '✗' . WL.annotate FailedText else if summaryGaveUp summary > 0 then- icon GaveUpIcon '⚐' . WL.annotate GaveUpText+ icon EnablePrefixIcons GaveUpIcon '⚐' . WL.annotate GaveUpText else if summaryWaiting summary > 0 || summaryRunning summary > 0 then- icon WaitingIcon '○' . WL.annotate WaitingHeader+ icon EnablePrefixIcons WaitingIcon '○' . WL.annotate WaitingHeader else- icon SuccessIcon '✓' . WL.annotate SuccessText+ icon EnablePrefixIcons SuccessIcon '✓' . WL.annotate SuccessText ppSummary :: MonadIO m => Summary -> m (Doc Markup) ppSummary summary =@@ -1224,8 +1311,32 @@ renderDoc color =<< ppProgress name x renderResult :: MonadIO m => UseColor -> Maybe PropertyName -> Report Result -> m String-renderResult color name x =- renderDoc color =<< ppResult name x+renderResult = renderResultWith defaultConfig++data Config =+ Config {+ configContext :: Context+ , configPrintFailedAtLocation :: Bool+ , configPrintShrinkPath :: Bool+ , configPrintReproduceMessage :: Bool+ , configPrintPrefixIcons :: PrintPrefixIcons+ } deriving (Eq, Show)++-- | Whether to add icons to the start of important output lines or not.+--+data PrintPrefixIcons =+ DisablePrefixIcons+ -- ^ Do not add icons to the start of important output lines.+ | EnablePrefixIcons+ -- ^ Add icons to the start of important output lines.+ deriving (Eq, Show)++defaultConfig :: Config+defaultConfig = Config FullContext True True True EnablePrefixIcons++renderResultWith :: MonadIO m => Config -> UseColor -> Maybe PropertyName -> Report Result -> m String+renderResultWith config color name x =+ renderDoc color =<< ppResultWith config name x renderSummary :: MonadIO m => UseColor -> Summary -> m String renderSummary color x =
src/Hedgehog/Internal/Runner.hs view
@@ -29,7 +29,7 @@ import Control.Concurrent.STM (TVar, atomically) import qualified Control.Concurrent.STM.TVar as TVar-import Control.Monad.Catch (MonadCatch(..), catchAll)+import Control.Exception.Safe (MonadCatch, catchAny) import Control.Monad.IO.Class (MonadIO(..)) import Data.Maybe (isJust) @@ -220,13 +220,13 @@ case skip of SkipNothing -> (Nothing, Nothing)- SkipToTest t ->- (Just t, Nothing)- SkipToShrink t s ->- (Just t, Just s)+ SkipToTest t d ->+ (Just (t, d), Nothing)+ SkipToShrink t d s ->+ (Just (t, d), Just s) test =- catchAll test0 (fail . show)+ catchAny test0 (fail . show) terminationCriteria = propertyTerminationCriteria cfg@@ -323,7 +323,7 @@ successReport else failureReport $- "Labels not sufficently covered after " <> show tests <> " tests"+ "Labels not sufficiently covered after " <> show tests <> " tests" else if discards >= fromIntegral (propertyDiscardLimit cfg) then -- we've hit the discard limit, give up@@ -335,8 +335,11 @@ -- If the report says failed "after 32 tests", the test number that -- failed was 31, but we want the user to be able to skip to 32 and -- start with the one that failed.- (Just n, _) | n > tests + 1 ->- loop (tests + 1) discards (size + 1) s1 coverage0+ (Just (n, d), _)+ | n > tests + 1 ->+ loop (tests + 1) discards (size + 1) s1 coverage0+ | d > discards ->+ loop tests (discards + 1) (size + 1) s1 coverage0 (Just _, Just shrinkPath) -> do node <- runTreeT . evalGenT size s0 . runTestT $ unPropertyT test
src/Hedgehog/Internal/Seed.hs view
@@ -46,6 +46,7 @@ , mix64variant13 , mix32 , mixGamma+ , global ) where import Control.Monad.IO.Class (MonadIO(..))
src/Hedgehog/Internal/State.hs view
@@ -35,7 +35,6 @@ -- * Commands , Command(..) , Callback(..)- , commandGenOK -- * Actions , Action(..)@@ -52,8 +51,8 @@ ) where import qualified Control.Concurrent.Async.Lifted as Async+import Control.Exception.Safe (MonadCatch) import Control.Monad (foldM, foldM_)-import Control.Monad.Catch (MonadCatch) import Control.Monad.State.Class (MonadState, get, put, modify) import Control.Monad.Morph (MFunctor(..)) import Control.Monad.Trans.Class (lift)@@ -170,8 +169,8 @@ -- type of variable because it is used in both the generation and the -- execution phase. ----- The order of arguments makes 'Var' 'HTraverable', which is how 'Symbolic'--- values are turned into 'Concrete' ones.+-- The order of arguments makes 'Var' 'FunctorB' and 'TraversableB', which is+-- how 'Symbolic' values are turned into 'Concrete' ones. -- newtype Var a v = Var (v a)@@ -402,12 +401,27 @@ [Callback input output state] } --- | Checks that input for a command can be executed in the given state.++-- | An actionable command is a command that can generate an action given+-- the current symbolic state, that is, its @commandGen@ returns @Just@. ---commandGenOK :: Command gen m state -> state Symbolic -> Bool-commandGenOK (Command inputGen _ _) state =- Maybe.isJust (inputGen state)+-- This is an internal type required to hold on to the existential+-- types when building actions.+--+data Actionable gen m (state :: (Type -> Type) -> Type) =+ forall input output.+ (TraversableB input, Show (input Symbolic), Show output, Typeable output) =>+ Actionable {+ _actionableGen ::+ gen (input Symbolic) + , _actionableExecute ::+ input Concrete -> m output++ , _actionableCallbacks ::+ [Callback input output state]+ }+ -- | An instantiation of a 'Command' which can be executed, and its effect -- evaluated. --@@ -545,21 +559,19 @@ Gen.justT $ do Context state0 _ <- get - Command mgenInput exec callbacks <-- Gen.element_ $ filter (\c -> commandGenOK c state0) commands+ Actionable genInput exec callbacks <-+ Gen.element_+ [ Actionable gen exec callbacks+ | Command inputGen exec callbacks <- commands+ , Just gen <- [inputGen state0]+ ] -- 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 ->- error "genCommand: internal error, tried to use generator with invalid state."- Just gen ->- hoist lift $ Gen.toGenT gen+ input <- hoist lift $ Gen.toGenT genInput if not $ callbackRequire callbacks state0 input then pure Nothing@@ -650,7 +662,7 @@ -> [Command gen m state] -> gen (Sequential m state) sequential range initial commands =- fmap (Sequential . fst) $+ Sequential . fst <$> genActions range commands (mkContext initial) -- | A sequential prefix of actions to execute, with two branches to execute in parallel.@@ -808,9 +820,8 @@ withFrozenCallStack $ let ok =- any successful .- fmap (checkActions initial) $- interleave branch1 branch2+ any (successful . checkActions initial) $+ interleave branch1 branch2 in if ok then pure ()
src/Hedgehog/Internal/Tree.hs view
@@ -49,11 +49,15 @@ , renderT ) where -import Control.Applicative (Alternative(..), liftA2)+#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+#endif+import Control.Applicative (Alternative(..))+import Control.Exception.Safe (Exception) import Control.Monad (MonadPlus(..), guard, join) import Control.Monad.Base (MonadBase(..))+import Control.Monad.Catch (MonadThrow(throwM), MonadCatch(catch)) import Control.Monad.Trans.Control ()-import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), Exception) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Morph (MFunctor(..), MMonad(..), generalize)@@ -184,7 +188,7 @@ pure . NodeT x $ fmap (expand f) xs ++ unfoldForest f x --- | Throw away @n@ levels of a tree's children.+-- | Throw away all but the top @n@ levels of a tree's children. -- -- /@prune 0@ will throw away all of a tree's children./ --
test/Test/Hedgehog/Skip.hs view
@@ -7,6 +7,7 @@ module Test.Hedgehog.Skip where +import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) import Data.Foldable (for_)@@ -25,24 +26,27 @@ -- | We use this property to help test skipping. It keeps a log of every time it -- runs in the 'IORef' it's passed. ----- It ignores its seed. It fails at size 2. When it shrinks, it initially--- shrinks to something that will pass, and then to something that will fail.+-- It ignores its seed. It discards at size 1 and fails at size 2. When it+-- shrinks, it initially shrinks to something that will pass, and then to+-- something that will fail. ---skipTestProperty :: IORef [(Size, Int, Bool)] -> Property+skipTestProperty :: IORef [(Size, Int, Bool, Bool)] -> Property skipTestProperty logRef = withTests 5 . property $ do- val@(curSize, _, shouldPass) <- forAll $ do+ val@(curSize, _, shouldDiscard, shouldPass) <- forAll $ do curSize <- Gen.sized pure- (shouldPass, nShrinks) <-- (,)- <$> Gen.shrink (\b -> if b then [] else [True]) (pure $ curSize /= 2)+ (shouldDiscard, shouldPass, nShrinks) <-+ (,,)+ <$> pure (curSize == 1)+ <*> Gen.shrink (\b -> if b then [] else [True]) (pure $ curSize /= 2) <*> Gen.shrink (\n -> reverse [0 .. n-1]) (pure 3)- pure (curSize, nShrinks, shouldPass)+ pure (curSize, nShrinks, shouldDiscard, shouldPass) -- Fail coverage to make sure we disable it when shrinking. cover 100 "Not 4" (curSize /= 4) liftIO $ IORef.modifyIORef' logRef (val :)+ when shouldDiscard discard assert shouldPass checkProp :: MonadIO m => Property -> m (Report Result)@@ -69,21 +73,22 @@ failureShrinks f === 3 failureShrinkPath f === ShrinkPath [1, 1, 1] - _ ->+ _ -> do+ annotateShow report failure logs <- liftIO $ reverse <$> IORef.readIORef logRef logs ===- [ (0, 3, True)- , (1, 3, True)- , (2, 3, False)- , (2, 3, True)- , (2, 2, False)- , (2, 2, True)- , (2, 1, False)- , (2, 1, True)- , (2, 0, False)- , (2, 0, True)+ [ (0, 3, False, True)+ , (1, 3, True, True)+ , (2, 3, False, False)+ , (2, 3, False, True)+ , (2, 2, False, False)+ , (2, 2, False, True)+ , (2, 1, False, False)+ , (2, 1, False, True)+ , (2, 0, False, False)+ , (2, 0, False, True) ] prop_SkipToFailingTest :: Property@@ -105,14 +110,14 @@ logs <- liftIO $ reverse <$> IORef.readIORef logRef logs ===- [ (2, 3, False)- , (2, 3, True)- , (2, 2, False)- , (2, 2, True)- , (2, 1, False)- , (2, 1, True)- , (2, 0, False)- , (2, 0, True)+ [ (2, 3, False, False)+ , (2, 3, False, True)+ , (2, 2, False, False)+ , (2, 2, False, True)+ , (2, 1, False, False)+ , (2, 1, False, True)+ , (2, 0, False, False)+ , (2, 0, False, True) ] prop_SkipPastFailingTest :: Property@@ -127,7 +132,7 @@ reportStatus report === OK logs <- liftIO $ reverse <$> IORef.readIORef logRef- logs === [(3, 3, True), (4, 3, True)]+ logs === [(3, 3, False, True), (4, 3, False, True)] prop_SkipToNoShrink :: Property prop_SkipToNoShrink =@@ -147,7 +152,7 @@ failure logs <- liftIO $ reverse <$> IORef.readIORef logRef- logs === [(2, 3, False)]+ logs === [(2, 3, False, False)] prop_SkipToFailingShrink :: Property prop_SkipToFailingShrink =@@ -167,7 +172,7 @@ failure logs <- liftIO $ reverse <$> IORef.readIORef logRef- logs === [(2, 3, False), (2, 2, False), (2, 1, False)]+ logs === [(2, 3, False, False), (2, 2, False, False), (2, 1, False, False)] prop_SkipToPassingShrink :: Property prop_SkipToPassingShrink =@@ -181,8 +186,40 @@ reportStatus report === OK logs <- liftIO $ reverse <$> IORef.readIORef logRef- logs === [(2, 3, False), (2, 2, False), (2, 2, True)]+ logs === [(2, 3, False, False), (2, 2, False, False), (2, 2, False, True)] +prop_SkipToReportedShrink :: Property+prop_SkipToReportedShrink =+ withTests 1 . property $ do+ logRef <- liftIO $ IORef.newIORef []++ report1 <- checkProp $ skipTestProperty logRef+ failure1 <- case reportStatus report1 of+ Failed f -> pure f+ _ -> do+ annotateShow report1+ failure++ let+ skip = SkipToShrink (reportTests report1)+ (reportDiscards report1)+ (failureShrinkPath failure1)+++ report2 <- checkProp $ withSkip skip $ skipTestProperty logRef+ failure2 <- case reportStatus report2 of+ Failed f -> pure f+ _ -> do+ annotateShow report2+ failure++ failure1 === failure2++ reportTests report1 === 2+ reportTests report2 === 2+ reportDiscards report1 === 1+ reportDiscards report2 === 1+ genSkip :: Gen Skip genSkip = let@@ -192,13 +229,16 @@ genTestCount = Property.TestCount <$> Gen.int range + genDiscardCount =+ Property.DiscardCount <$> Gen.int range+ genShrinkPath = Property.ShrinkPath <$> Gen.list range (Gen.int range) in Gen.choice [ pure SkipNothing- , SkipToTest <$> genTestCount- , SkipToShrink <$> genTestCount <*> genShrinkPath+ , SkipToTest <$> genTestCount <*> genDiscardCount+ , SkipToShrink <$> genTestCount <*> genDiscardCount <*> genShrinkPath ] -- | Test that `skipCompress` and `skipDecompress` roundtrip.@@ -224,15 +264,15 @@ -- strings that would decompress to the same Skip. testCases = [ (SkipNothing, "", [])- , (SkipToTest 3, "3", ["03", "003"])- , (SkipToTest 197, "197", ["0197", "00197"])- , ( SkipToShrink 5 $ Property.ShrinkPath [2, 3, 0]+ , (SkipToTest 3 0, "3", ["03", "003", "3/0", "03/00"])+ , (SkipToTest 197 1, "197/1", ["0197/1", "00197/01"])+ , ( SkipToShrink 5 0 $ Property.ShrinkPath [2, 3, 0] , "5:cDa" , ["5:CdA", "05:c1b0D1A1"] )- , ( SkipToShrink 21 $ Property.ShrinkPath [5, 3, 27, 27, 26]- , "21:fDbb2BA"- , ["21:fDbbBBba"]+ , ( SkipToShrink 21 3 $ Property.ShrinkPath [5, 3, 27, 27, 26]+ , "21/3:fDbb2BA"+ , ["21/3:fDbbBBba"] ) ]