hedgehog 1.1.2 → 1.7
raw patch · 17 files changed
Files
- CHANGELOG.md +164/−1
- README.md +15/−3
- hedgehog.cabal +33/−25
- src/Hedgehog.hs +6/−1
- src/Hedgehog/Gen.hs +1/−0
- src/Hedgehog/Internal/Config.hs +28/−0
- src/Hedgehog/Internal/Exception.hs +1/−1
- src/Hedgehog/Internal/Gen.hs +147/−44
- src/Hedgehog/Internal/Property.hs +213/−9
- src/Hedgehog/Internal/Region.hs +1/−1
- src/Hedgehog/Internal/Report.hs +194/−67
- src/Hedgehog/Internal/Runner.hs +159/−71
- src/Hedgehog/Internal/Seed.hs +1/−0
- src/Hedgehog/Internal/State.hs +37/−22
- src/Hedgehog/Internal/Tree.hs +7/−3
- test/Test/Hedgehog/Skip.hs +286/−0
- test/test.hs +2/−0
CHANGELOG.md view
@@ -1,3 +1,65 @@+## 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])+ * 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.2 (2022-09-02) * Support GHC 9.4 ([#461][461], [@ysangkok][ysangkok])@@ -6,6 +68,7 @@ ## 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 +309,115 @@ 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+[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]: 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]:@@ -269,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.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,48 +33,55 @@ 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.3+ , 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- , transformers >= 0.5 && < 0.6+ , 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 @@ -136,18 +143,19 @@ Test.Hedgehog.Filter Test.Hedgehog.Maybe Test.Hedgehog.Seed+ Test.Hedgehog.Skip Test.Hedgehog.Text Test.Hedgehog.Zip 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.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.2+ , transformers >= 0.3 && < 0.7 default-language: Haskell2010
src/Hedgehog.hs view
@@ -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(..))
src/Hedgehog/Gen.hs view
@@ -94,6 +94,7 @@ -- ** Combinations & Permutations , subsequence+ , subset , shuffle -- ** Abstract State Machine
src/Hedgehog/Internal/Config.hs view
@@ -18,11 +18,15 @@ , WorkerCount(..) , resolveWorkers + , Skip(..)+ , resolveSkip+ , detectMark , detectColor , detectSeed , detectVerbosity , detectWorkers+ , detectSkip ) where import Control.Monad.IO.Class (MonadIO(..))@@ -33,6 +37,7 @@ import Hedgehog.Internal.Seed (Seed(..)) import qualified Hedgehog.Internal.Seed as Seed+import Hedgehog.Internal.Property (Skip(..), skipDecompress) import Language.Haskell.TH.Syntax (Lift) @@ -166,6 +171,22 @@ Just env -> pure $ WorkerCount env +detectSkip :: MonadIO m => m Skip+detectSkip =+ liftIO $ do+ menv <- lookupEnv "HEDGEHOG_SKIP"+ case menv of+ Nothing ->+ pure SkipNothing+ Just env ->+ case skipDecompress env of+ Nothing ->+ -- It's clearer for the user if we error out here, rather than+ -- silently defaulting to SkipNothing.+ error "HEDGEHOG_SKIP is not a valid Skip."+ Just skip ->+ pure skip+ resolveColor :: MonadIO m => Maybe UseColor -> m UseColor resolveColor = \case Nothing ->@@ -191,5 +212,12 @@ resolveWorkers = \case Nothing -> detectWorkers+ Just x ->+ pure x++resolveSkip :: MonadIO m => Maybe Skip -> m Skip+resolveSkip = \case+ Nothing ->+ detectSkip Just x -> pure x
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
@@ -130,6 +130,7 @@ -- ** Combinations & Permutations , subsequence+ , subset , shuffle , shuffleSeq @@ -174,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(..))@@ -216,6 +220,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@@ -226,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)@@ -744,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. --@@ -1186,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@@ -1200,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@@ -1214,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@@ -1229,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@@ -1323,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@@ -1353,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@@ -1662,10 +1723,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/@@ -1715,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
@@ -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(..)@@ -129,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(..))@@ -165,7 +172,7 @@ import qualified Data.Map.Strict as Map import Data.Number.Erf (invnormcdf) import qualified Data.List as List-import Data.String (IsString)+import Data.String (IsString(..)) import Data.Ratio ((%)) import Data.Typeable (typeOf) @@ -179,7 +186,10 @@ import Language.Haskell.TH.Syntax (Lift) +import qualified Numeric +import Text.Read (readMaybe)+ ------------------------------------------------------------------------ -- | A property test, along with some configurable limits like how many times@@ -273,6 +283,10 @@ , propertyShrinkLimit :: !ShrinkLimit , propertyShrinkRetries :: !ShrinkRetries , propertyTerminationCriteria :: !TerminationCriteria++ -- | If this is 'Nothing', we take the Skip from the environment variable+ -- @HEDGEHOG_SKIP@.+ , propertySkip :: Maybe Skip } deriving (Eq, Ord, Show, Lift) -- | The number of successful tests that need to be run before a property test@@ -292,13 +306,17 @@ -- newtype TestCount = TestCount Int- deriving (Eq, Ord, Show, Num, Enum, Real, Integral)+ 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. --@@ -331,6 +349,184 @@ 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.+ --+ -- 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+ -- 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 DiscardCount 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 =+ 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.+--+-- 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+ (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 dc+ else do+ sp <- shrinkPathDecompress $ drop 1 spStr+ Just $ SkipToShrink tc dc 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.@@ -839,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'.@@ -851,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"@@ -861,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@@ -991,6 +1187,8 @@ 0 , propertyTerminationCriteria = NoConfidenceTermination defaultMinTests+ , propertySkip =+ Nothing } -- | The minimum amount of tests to run for a 'Property'@@ -1076,6 +1274,12 @@ withRetries :: ShrinkRetries -> Property -> Property withRetries n = mapConfig $ \config -> config { propertyShrinkRetries = n }++-- | Set the target that a property will skip to before it starts to run.+--+withSkip :: Skip -> Property -> Property+withSkip s =+ mapConfig $ \config -> config { propertySkip = Just s } -- | Creates a property with the default configuration. --
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@@ -62,10 +70,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 +99,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 +134,7 @@ reportTests :: !TestCount , reportDiscards :: !DiscardCount , reportCoverage :: !(Coverage CoverCount)+ , reportSeed :: !Seed , reportStatus :: !a } deriving (Show, Functor, Foldable, Traversable) @@ -181,7 +189,7 @@ data Line a = Line {- _lineAnnotation :: !a+ lineAnnotation :: !a , lineNumber :: !LineNo , _lineSource :: !String } deriving (Eq, Ord, Show, Functor)@@ -267,16 +275,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 +291,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@@ -301,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@@ -326,6 +334,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@@ -542,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, _) ->@@ -561,34 +619,49 @@ 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) -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 +684,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 => 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@@ -666,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@@ -683,51 +756,63 @@ else f xs - bottom =- maybe [ppReproduce name size seed] (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) =+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 <>@@ -735,43 +820,58 @@ "(shrinking)" ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup)-ppResult name (Report tests discards coverage 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 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 <>- "."+ "." <>+ (+ 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@@ -783,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) @@ -860,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@@ -875,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)@@ -1033,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 =@@ -1208,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
@@ -13,6 +13,7 @@ -- * Running Individual Properties check , recheck+ , recheckAt -- * Running Groups of Properties , RunnerConfig(..)@@ -28,8 +29,9 @@ 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) import Hedgehog.Internal.Config import Hedgehog.Internal.Gen (evalGenT)@@ -39,12 +41,13 @@ import Hedgehog.Internal.Property (Journal(..), Coverage(..), CoverCount(..)) import Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..)) import Hedgehog.Internal.Property (PropertyT(..), Failure(..), runTestT)-import Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withTests)+import Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withTests, withSkip) import Hedgehog.Internal.Property (TerminationCriteria(..)) import Hedgehog.Internal.Property (TestCount(..), PropertyCount(..)) import Hedgehog.Internal.Property (confidenceSuccess, confidenceFailure) import Hedgehog.Internal.Property (coverageSuccess, journalCoverage) import Hedgehog.Internal.Property (defaultMinTests)+import Hedgehog.Internal.Property (ShrinkPath(..)) import Hedgehog.Internal.Queue import Hedgehog.Internal.Region import Hedgehog.Internal.Report@@ -116,41 +119,89 @@ takeSmallest :: MonadIO m- => Size- -> Seed- -> ShrinkCount+ => ShrinkCount+ -> ShrinkPath -> ShrinkLimit -> ShrinkRetries -> (Progress -> m ()) -> NodeT m (Maybe (Either Failure (), Journal)) -> m Result-takeSmallest size seed shrinks slimit retries updateUI = \case- NodeT Nothing _ ->- pure GaveUp+takeSmallest shrinks0 (ShrinkPath shrinkPath0) slimit retries updateUI =+ let+ loop shrinks revShrinkPath = \case+ NodeT Nothing _ ->+ pure GaveUp - NodeT (Just (x, (Journal logs))) xs ->- case x of- Left (Failure loc err mdiff) -> do- let- failure =- mkFailure size seed shrinks Nothing loc err mdiff (reverse logs)+ NodeT (Just (x, (Journal logs))) xs ->+ case x of+ Left (Failure loc err mdiff) -> do+ let+ shrinkPath =+ ShrinkPath $ reverse revShrinkPath+ failure =+ mkFailure shrinks shrinkPath Nothing loc err mdiff (reverse logs) - updateUI $ Shrinking failure+ updateUI $ Shrinking failure - if shrinks >= fromIntegral slimit then- -- if we've hit the shrink limit, don't shrink any further- pure $ Failed failure- else- findM xs (Failed failure) $ \m -> do- o <- runTreeN retries m- if isFailure o then- Just <$> takeSmallest size seed (shrinks + 1) slimit retries updateUI o+ if shrinks >= fromIntegral slimit then+ -- if we've hit the shrink limit, don't shrink any further+ pure $ Failed failure else- return Nothing+ findM (zip [0..] xs) (Failed failure) $ \(n, m) -> do+ o <- runTreeN retries m+ if isFailure o then+ Just <$> loop (shrinks + 1) (n : revShrinkPath) o+ else+ return Nothing - Right () ->- return OK+ Right () ->+ return OK+ in+ loop shrinks0 (reverse shrinkPath0) +-- | Follow a given shrink path, instead of searching exhaustively. Assume that+-- the end of the path is minimal, and don't try to shrink any further than+-- that.+--+-- This evaluates the test for all the shrinks on the path, but not ones+-- off-path. Because the generator is mixed with the test code, it's probably+-- not possible to avoid this.+skipToShrink ::+ MonadIO m+ => ShrinkPath+ -> (Progress -> m ())+ -> NodeT m (Maybe (Either Failure (), Journal))+ -> m Result+skipToShrink (ShrinkPath shrinkPath) updateUI =+ let+ loop shrinks [] = \case+ NodeT Nothing _ ->+ pure GaveUp++ NodeT (Just (x, (Journal logs))) _ ->+ case x of+ Left (Failure loc err mdiff) -> do+ let+ failure =+ mkFailure shrinks (ShrinkPath shrinkPath) Nothing loc err mdiff (reverse logs)++ updateUI $ Shrinking failure+ pure $ Failed failure++ Right () ->+ return OK++ loop shrinks (s0:ss) = \case+ NodeT _ xs ->+ case drop s0 xs of+ [] ->+ pure GaveUp+ (x:_) -> do+ o <- runTreeT x+ loop (shrinks + 1) ss o+ in+ loop 0 shrinkPath+ checkReport :: forall m. MonadIO m@@ -161,10 +212,21 @@ -> 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 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@@ -198,7 +260,7 @@ -> Coverage CoverCount -> m (Report Result) loop !tests !discards !size !seed !coverage0 = do- updateUI $ Report tests discards coverage0 Running+ updateUI $ Report tests discards coverage0 seed0 Running let coverageReached =@@ -221,13 +283,12 @@ coverageSuccess tests coverage0 successReport =- Report tests discards coverage0 OK+ Report tests discards coverage0 seed0 OK failureReport message =- Report tests discards coverage0 . Failed $ mkFailure- size- seed+ Report tests discards coverage0 seed0 . Failed $ mkFailure 0+ (ShrinkPath []) (Just coverage0) Nothing message@@ -249,54 +310,73 @@ -- 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 sufficiently 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 ->+ (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, 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+ let+ mkReport =+ Report (tests + 1) discards coverage0 seed0+ mkReport <$> skipToShrink shrinkPath (updateUI . mkReport) node+ _ -> do+ node@(NodeT x _) <-+ runTreeT . evalGenT size s0 . runTestT $ unPropertyT test+ case x of+ Nothing ->+ loop tests (discards + 1) (size + 1) s1 coverage0 - Just (Left _, _) ->- let- mkReport =- Report (tests + 1) discards coverage0- in- fmap mkReport $- takeSmallest- size- seed- 0- (propertyShrinkLimit cfg)- (propertyShrinkRetries cfg)- (updateUI . mkReport)- node+ Just (Left _, _) ->+ let+ mkReport =+ Report (tests + 1) discards coverage0 seed0+ in+ fmap mkReport $+ takeSmallest+ 0+ (ShrinkPath [])+ (propertyShrinkLimit cfg)+ (propertyShrinkRetries cfg)+ (updateUI . mkReport)+ node - Just (Right (), journal) ->- let- coverage =- journalCoverage journal <> coverage0- in- loop (tests + 1) discards (size + 1) s1 coverage- in- loop 0 0 size0 seed0 mempty+ Just (Right (), journal) ->+ let+ coverage =+ journalCoverage journal <> coverage0+ in+ loop (tests + 1) discards (size + 1) s1 coverage + loop 0 0 size0 seed0 mempty+ checkRegion :: MonadIO m => Region@@ -356,6 +436,14 @@ let prop = withTests 1 prop0 _ <- liftIO . displayRegion $ \region -> checkRegion region color Nothing size seed prop+ pure ()++recheckAt :: MonadIO m => Seed -> Skip -> Property -> m ()+recheckAt seed skip prop0 = do+ color <- detectColor+ let prop = withSkip skip prop0+ _ <- liftIO . displayRegion $ \region ->+ checkRegion region color Nothing 0 seed prop pure () -- | Check a group of properties using the specified runner config.
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,22 +559,24 @@ 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]+ ] - input <-- case mgenInput state0 of- Nothing ->- error "genCommand: internal error, tried to use generator with invalid state."- Just gen ->- hoist lift $ Gen.toGenT gen+ -- 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 <- hoist lift $ Gen.toGenT genInput if not $ callbackRequire callbacks state0 input then pure Nothing else do- output <- contextNewVar- contextUpdate $ callbackUpdate callbacks state0 input (Var output) @@ -646,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.@@ -804,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
@@ -0,0 +1,286 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module Test.Hedgehog.Skip where++import Control.Monad (when)+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 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, Bool)] -> Property+skipTestProperty logRef =+ withTests 5 . property $ do+ val@(curSize, _, shouldDiscard, shouldPass) <- forAll $ do+ curSize <- Gen.sized pure+ (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, 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)+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]++ _ -> do+ annotateShow report+ failure++ logs <- liftIO $ reverse <$> IORef.readIORef logRef+ logs ===+ [ (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+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, 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+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, False, True), (4, 3, False, 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, 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, False), (2, 2, False, False), (2, 1, False, 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, 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+ range =+ Range.linear 0 100++ 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 <*> genDiscardCount+ , SkipToShrink <$> genTestCount <*> genDiscardCount <*> 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 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 3 $ Property.ShrinkPath [5, 3, 27, 27, 26]+ , "21/3:fDbb2BA"+ , ["21/3:fDbbBBba"]+ )+ ]++ for_ testCases $ \(skip, compressed, otherCompressions) -> do+ skipCompress skip === compressed+ for_ (compressed : otherCompressions) $ \c ->+ skipDecompress c === Just skip++tests :: IO Bool+tests =+ checkParallel $$(discover)
test/test.hs view
@@ -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 ]