hedgehog-1.0.3/0000755060175106010010000000000013675366474012540 5ustar00Nikos00000000000000hedgehog-1.0.3/CHANGELOG.md0000644060175106010010000003466113675347205014352 0ustar00Nikos00000000000000## Version 1.0.3 (2020-06-26) - Don't swallow errors if we can't find the source file ([#387][387], [@HuwCampbell][HuwCampbell]) - Add `Property.evalNF` ([#384][384], [@dcastro][dcastro]) - Add `Gen.either` and `Gen.either_` ([#382][382], [@dcastro][dcastro]) - Add `filterT`, `justT`, and `mapMaybeT` to `Gen` exports ([#366][366], [@kquick][kquick]) - Bump pretty-show to 1.10 which supports quasi-quotes ([#365][365], [@jacobstanley][jacobstanley]) - Remove `undefined` in `GenT`'s `MonadWriter` instance ([#344][344], [@HuwCampbell][HuwCampbell]) - Make `Tree.interleave` logarithmtic rather than linear ([#313][313], [@edsko][edsko]) ## Version 1.0.2 (2020-01-10) - Support GHC 8.10 ([#376][376], [@sjakobi][sjakobi]) - Speed up `Tree.splits` ([#349][349], [@treeowl][treeowl]) - Speed up `Gen.shuffle` ([#348][348], [@treeowl][treeowl]) - Add docs on the bounds of `Size` ([#346][346], [@chris-martin][chris-martin]) - Fix performance issues with color handling ([#345][345], [@stolyaroleh][stolyaroleh]) - Add `mapMaybe`, `mapMaybeT`, in `Tree` and `Gen` ([#339][339], [@treeowl][treeowl]) - Fix some formatting bugs in Haddock ([#332][332], [@sshine][sshine]) - Add `MonadGen` instances for `StateT` ([#321][321], [#330][330], [@HuwCampbell][HuwCampbell] / [@tomjaguarpaw][tomjaguarpaw] / [@symbiont-sam-halliday][symbiont-sam-halliday]) - Add `MonadBaseControl` instance for `PropertyT` ([#328][328], [@treeowl][treeowl]) ## Version 1.0.1 (2019-09-16) - Add compatibility with GHC 8.8 ([#319][319], [@erikd][erikd]) - Include location of failed assertion in report. This enables editors to more easily parse the location of failed test assertions, and provide links/jump functionality ([#308][308], [@owickstrom][owickstrom]) - Stop using filter to define unicode ([#303][303], [@ajmcmiddlin][ajmcmiddlin]) - Export LabelName from main module ([#299][299], [@erikd][erikd]) ## Version 1.0 (2019-05-13) - Add histograms to labels / coverage ([#289][289], [@jacobstanley][jacobstanley]) - Improved shrinking of lists ([#276][276], [@jacobstanley][jacobstanley] / [@edsko][edsko]) - Simplify `MonadGen`, this breaks the use of `StateT` on the outside of a `GenT` for the time being, it still works fine on the inside though and you can use `distributeT` to run it ([#276][276], [@jacobstanley][jacobstanley]) - Change `Applicative` `GenT` to use zipping ([#272][272], [@jacobstanley][jacobstanley] / [@edsko][edsko]) - Rename `Tree` -> `TreeT`, `Node` -> `NodeT` ([#272][272], [@jacobstanley][jacobstanley]) - `diff` function which takes any `a -> a -> Bool` comparison function ([#196][196], [@chessai][chessai] / [@jacobstanley][jacobstanley]) - Labelling of test runs via `label`, `collect` ([#262][262], [@ruhatch][ruhatch] / [@jacobstanley][jacobstanley]) - Classification of test runs via `cover`, `classify` ([#253][253], [@felixmulder][felixmulder] / [@jacobstanley][jacobstanley]) - Define proper `Applicative` instances for `NodeT`, `TreeT` and `GenT` ([#173][173][@sjakobi][sjakobi]) - `MonadFail` instance for `PropertyT` ([#267][267], [@geigerzaehler][geigerzaehler]) - `MonadResource` instance for `PropertyT` ([#268][268], [@geigerzaehler][geigerzaehler]) - Example for the `tripping` function ([#258][258], [@HuwCampbell][HuwCampbell]) - Improve documentation for state machine testing ([#252][252], [@endgame][endgame]) - `runTests` function for running tests from a top level executable, this was later renamed to `defaultMain` as is the de facto convention ([#168][168], [@erikd][erikd]) - Show output variables when parallel state machine testing fails to linearise ([#235][235], [@HuwCampbell][HuwCampbell]) - Note about `enumBounded` danger ([#202][202], [@thumphries][thumphries]) - Expose `discoverPrefix` to find prefixed properties ([#229][229], [@ruhatch][ruhatch]) - Remove use of `unix` package and replace with `lookupEnv` ([#226][226], [@puffnfresh][puffnfresh]) ## Version 0.6.1 (2018-09-22) - Fix UTF-8 related rendering bugs on Windows ([#218][218], [@moodmosaic][moodmosaic]) - Verify that our SplitMix/Seed avoids pathological γ-values ([#207][207], [@moodmosaic][moodmosaic]) - Avoid weak gamma values in Hedgehog.Internal.Seed ([#198][198], [@moodmosaic][moodmosaic]) ## Version 0.6 (2018-05-14) - Pass [Dieharder][Dieharder] statistical/randomness tests ([#185][185], [@moodmosaic][moodmosaic]) - Catch `readFile` exceptions on the repl ([#184][184], [@thumphries][thumphries]) ## Version 0.5.3 (2018-03-12) - Add `Semigroup` and `Monoid` instances for `GenT` that lift the inner `Monoid` ([#156][156], [@andrewthad][andrewthad]) - `Gen.unicode` no longer generates non-characters ([#154][154], [@johnchandlerburnham][johnchandlerburnham]) - Documentation improvements ([#162][162], [@fisx][fisx]) - Documentation fixes ([#157][157], [@dredozubov][dredozubov]) ## Version 0.5.2 (2018-02-05) - Add doc explaining use of `withTests 1` ([#134][134], [@chris-martin][chris-martin]) - Explicitly define `Semigroup` instance for `Summary` ([#142][142], [@gwils][gwils]) - Depend on `semigroups` ([#140][140], [@LightAndLight][LightAndLight]) - Support `transformers-0.4` ([#150][150], [@gwils][gwils]) ## Version 0.5.1 (2017-12-06) - Only invoke `setNumCapabilities` when using the `-threaded` runtime ([#130][130], [@ekmett][ekmett]) - Correct `mixGamma` oddness check ([#124][124], [@markhibberd][markhibberd]) ## Version 0.5 (2017-07-16) - Parallel state machine testing, allows detection of commands which are not-atomic ([#98][98], [@jacobstanley][jacobstanley]) - Easier to use variables for state machine testing ([#94][94], [@jacobstanley][jacobstanley]) - `MonadGen` class allows the use of transformers like `ReaderT` and `StateT` on the outside of generators ([#99][99], [@jacobstanley][jacobstanley]) - Better error messages for tests which throw exceptions ([#95][95], [@jacobstanley][jacobstanley]) - Separated test input generation and assertions in to `PropertyT` and `TestT` respectively, this allows `TestT` to have a `MonadBaseControl` instance ([#96][96], [@jacobstanley][jacobstanley]) - This document grew links to the pull requests which introduced various changes ([#93][93], [@moodmosaic][moodmosaic]) ## Version 0.4.1 (2017-06-28) - Fixed runtime type error that could occur when shrinking state machine commands ([#91][91], [@jacobstanley][jacobstanley]) ## Version 0.4 (2017-06-28) - Abstract state machine testing, check out Tim Humphries' great [blog post](http://teh.id.au/posts/2017/07/15/state-machine-testing) or the [process registry example](https://github.com/hedgehogqa/haskell-hedgehog/blob/master/hedgehog-example/test/Test/Example/Registry.hs) to see how it works ([#89][89], [@jacobstanley][jacobstanley]) - `liftCatch`, `liftCatchIO`, `withCatch` functions for isolating exceptions during tests ([#89][89], [@jacobstanley][jacobstanley]) ## Version 0.3 (2017-06-11) - Exponential range combinators ([#43][43], [@chris-martin][chris-martin]) - Roundtrip example, check out the [blog post](http://teh.id.au/posts/2017/06/07/round-trip-property/) ([#85][85], [@thumphries][thumphries]) - `tripping` now displays intermediate value ([#85][85], [@jacobstanley][jacobstanley]) - `distribute` function for pulling a transformer out to the top level ([#83][83], [@jacobstanley][jacobstanley]) - `withExceptT` function for executing tests with an inner `ExceptT` (e.g. `Test (ExceptT x m) a`) ([#83][83], [@jacobstanley][jacobstanley]) ## Version 0.2.2 (2017-05-16) - Fixed scope of `unicode` character generators ([#76][76], [@moodmosaic][moodmosaic]) - Widen version bounds for some dependencies ([#80][80], [@amarpotghan][amarpotghan]) - Expose test modules to fix build on nix / hydra ([#78][78], [@amarpotghan][amarpotghan]) - Fixes for GHC 8.2 RC2 ([#77][77], [@erikd][erikd]) ## Version 0.2.1 (2017-05-09) - Added `ascii`, `latin1`, `unicode` character generators ([#73][73], [@jacobstanley][jacobstanley]) ## Version 0.2 (2017-05-06) - Added a quiet test runner which can be activated by setting `HEDGEHOG_VERBOSITY=0` ([@jacobstanley][jacobstanley]) - Concurrent test runner does not display tests until they are executing ([@jacobstanley][jacobstanley]) - Test runner now outputs a summary of how many successful / failed tests were run ([@jacobstanley][jacobstanley]) - `checkSequential` and `checkParallel` now allow for tests to be run without Template Haskell ([@jacobstanley][jacobstanley]) - Auto-discovery of properties is now available via `discover` instead of being baked in ([@jacobstanley][jacobstanley]) - `annotate` allows source code to be annotated inline with extra information ([@jacobstanley][jacobstanley]) - `forAllWith` can be used to generate values without a `Show` instance ([@jacobstanley][jacobstanley]) - Removed uses of `Typeable` to allow for generating types which cannot implement it ([@jacobstanley][jacobstanley]) [Dieharder]: https://webhome.phy.duke.edu/~rgb/General/dieharder.php [jacobstanley]: https://github.com/jacobstanley [chris-martin]: https://github.com/chris-martin [thumphries]: https://github.com/thumphries [moodmosaic]: https://github.com/moodmosaic [amarpotghan]: https://github.com/amarpotghan [erikd]: https://github.com/erikd [ekmett]: https://github.com/ekmett [markhibberd]: https://github.com/markhibberd [gwils]: https://github.com/gwils [LightAndLight]: https://github.com/LightAndLight [johnchandlerburnham]: https://github.com/johnchandlerburnham [andrewthad]: https://github.com/andrewthad [dredozubov]: https://github.com/dredozubov [fisx]: https://github.com/fisx [puffnfresh]: https://github.com/puffnfresh [ruhatch]: https://github.com/ruhatch [HuwCampbell]: https://github.com/HuwCampbell [endgame]: https://github.com/endgame [geigerzaehler]: https://github.com/geigerzaehler [sjakobi]: https://github.com/sjakobi [felixmulder]: https://github.com/felixmulder [chessai]: https://github.com/chessai [edsko]: https://github.com/edsko [ajmcmiddlin]: https://github.com/ajmcmiddlin [owickstrom]: https://github.com/owickstrom [treeowl]: https://github.com/treeowl [tomjaguarpaw]: https://github.com/tomjaguarpaw [symbiont-sam-halliday]: https://github.com/symbiont-sam-halliday [sshine]: https://github.com/sshine [stolyaroleh]: https://github.com/stolyaroleh [kquick]: https://github.com/kquick [dcastro]: https://github.com/dcastro [387]: https://github.com/hedgehogqa/haskell-hedgehog/pull/387 [384]: https://github.com/hedgehogqa/haskell-hedgehog/pull/384 [382]: https://github.com/hedgehogqa/haskell-hedgehog/pull/382 [376]: https://github.com/hedgehogqa/haskell-hedgehog/pull/376 [366]: https://github.com/hedgehogqa/haskell-hedgehog/pull/366 [365]: https://github.com/hedgehogqa/haskell-hedgehog/pull/365 [349]: https://github.com/hedgehogqa/haskell-hedgehog/pull/349 [348]: https://github.com/hedgehogqa/haskell-hedgehog/pull/348 [346]: https://github.com/hedgehogqa/haskell-hedgehog/pull/346 [345]: https://github.com/hedgehogqa/haskell-hedgehog/pull/345 [344]: https://github.com/hedgehogqa/haskell-hedgehog/pull/344 [339]: https://github.com/hedgehogqa/haskell-hedgehog/pull/339 [332]: https://github.com/hedgehogqa/haskell-hedgehog/pull/332 [330]: https://github.com/hedgehogqa/haskell-hedgehog/pull/330 [328]: https://github.com/hedgehogqa/haskell-hedgehog/pull/328 [321]: https://github.com/hedgehogqa/haskell-hedgehog/pull/321 [319]: https://github.com/hedgehogqa/haskell-hedgehog/pull/319 [313]: https://github.com/hedgehogqa/haskell-hedgehog/pull/313 [308]: https://github.com/hedgehogqa/haskell-hedgehog/pull/308 [303]: https://github.com/hedgehogqa/haskell-hedgehog/pull/303 [299]: https://github.com/hedgehogqa/haskell-hedgehog/pull/299 [289]: https://github.com/hedgehogqa/haskell-hedgehog/pull/289 [276]: https://github.com/hedgehogqa/haskell-hedgehog/pull/276 [272]: https://github.com/hedgehogqa/haskell-hedgehog/pull/272 [268]: https://github.com/hedgehogqa/haskell-hedgehog/pull/268 [267]: https://github.com/hedgehogqa/haskell-hedgehog/pull/267 [262]: https://github.com/hedgehogqa/haskell-hedgehog/pull/262 [258]: https://github.com/hedgehogqa/haskell-hedgehog/pull/258 [253]: https://github.com/hedgehogqa/haskell-hedgehog/pull/253 [252]: https://github.com/hedgehogqa/haskell-hedgehog/pull/252 [235]: https://github.com/hedgehogqa/haskell-hedgehog/pull/235 [229]: https://github.com/hedgehogqa/haskell-hedgehog/pull/229 [226]: https://github.com/hedgehogqa/haskell-hedgehog/pull/226 [218]: https://github.com/hedgehogqa/haskell-hedgehog/pull/218 [207]: https://github.com/hedgehogqa/haskell-hedgehog/pull/207 [202]: https://github.com/hedgehogqa/haskell-hedgehog/pull/202 [198]: https://github.com/hedgehogqa/haskell-hedgehog/pull/198 [196]: https://github.com/hedgehogqa/haskell-hedgehog/pull/196 [185]: https://github.com/hedgehogqa/haskell-hedgehog/pull/185 [184]: https://github.com/hedgehogqa/haskell-hedgehog/pull/184 [173]: https://github.com/hedgehogqa/haskell-hedgehog/pull/173 [168]: https://github.com/hedgehogqa/haskell-hedgehog/pull/168 [162]: https://github.com/hedgehogqa/haskell-hedgehog/pull/162 [157]: https://github.com/hedgehogqa/haskell-hedgehog/pull/157 [156]: https://github.com/hedgehogqa/haskell-hedgehog/pull/156 [154]: https://github.com/hedgehogqa/haskell-hedgehog/pull/154 [150]: https://github.com/hedgehogqa/haskell-hedgehog/pull/150 [142]: https://github.com/hedgehogqa/haskell-hedgehog/pull/142 [140]: https://github.com/hedgehogqa/haskell-hedgehog/pull/140 [134]: https://github.com/hedgehogqa/haskell-hedgehog/pull/134 [130]: https://github.com/hedgehogqa/haskell-hedgehog/pull/130 [124]: https://github.com/hedgehogqa/haskell-hedgehog/pull/124 [99]: https://github.com/hedgehogqa/haskell-hedgehog/pull/99 [98]: https://github.com/hedgehogqa/haskell-hedgehog/pull/98 [96]: https://github.com/hedgehogqa/haskell-hedgehog/pull/96 [95]: https://github.com/hedgehogqa/haskell-hedgehog/pull/95 [94]: https://github.com/hedgehogqa/haskell-hedgehog/pull/94 [93]: https://github.com/hedgehogqa/haskell-hedgehog/pull/93 [91]: https://github.com/hedgehogqa/haskell-hedgehog/pull/91 [89]: https://github.com/hedgehogqa/haskell-hedgehog/pull/89 [85]: https://github.com/hedgehogqa/haskell-hedgehog/pull/85 [83]: https://github.com/hedgehogqa/haskell-hedgehog/pull/83 [80]: https://github.com/hedgehogqa/haskell-hedgehog/pull/80 [78]: https://github.com/hedgehogqa/haskell-hedgehog/pull/78 [77]: https://github.com/hedgehogqa/haskell-hedgehog/pull/77 [76]: https://github.com/hedgehogqa/haskell-hedgehog/pull/76 [73]: https://github.com/hedgehogqa/haskell-hedgehog/pull/73 [43]: https://github.com/hedgehogqa/haskell-hedgehog/pull/43 hedgehog-1.0.3/hedgehog.cabal0000644060175106010010000001101613675366374015274 0ustar00Nikos00000000000000version: 1.0.3 name: hedgehog author: Jacob Stanley maintainer: Jacob Stanley homepage: https://hedgehog.qa bug-reports: https://github.com/hedgehogqa/haskell-hedgehog/issues synopsis: Release with confidence. description: 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. . To get started quickly, see the . category: Testing license: BSD3 license-file: LICENSE cabal-version: >= 1.10 build-type: Simple tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.3 , GHC == 8.10.1 extra-source-files: README.md CHANGELOG.md source-repository head type: git location: git://github.com/hedgehogqa/haskell-hedgehog.git library build-depends: -- GHC 8.0.1 / base-4.9.0.0 (May 2016) base >= 4.9 && < 5 , ansi-terminal >= 0.6 && < 0.11 , async >= 2.0 && < 2.3 , bytestring >= 0.10 && < 0.11 , concurrent-output >= 1.7 && < 1.11 , containers >= 0.4 && < 0.7 , deepseq >= 1.1.0.0 && < 1.5 , directory >= 1.2 && < 1.4 , erf >= 2.0 && < 2.1 , exceptions >= 0.7 && < 0.11 , fail >= 4.9 && < 5 , lifted-async >= 0.7 && < 0.11 , mmorph >= 1.0 && < 1.2 , monad-control >= 1.0 && < 1.1 , mtl >= 2.1 && < 2.3 , pretty-show >= 1.6 && < 1.11 , primitive >= 0.6 && < 0.8 , random >= 1.1 && < 1.2 , resourcet >= 1.1 && < 1.3 , semigroups >= 0.16 && < 0.20 , stm >= 2.4 && < 2.6 , template-haskell >= 2.10 && < 2.17 , text >= 1.1 && < 1.3 , time >= 1.4 && < 1.10 , transformers >= 0.5 && < 0.6 , transformers-base >= 0.4.5.1 && < 0.5 , wl-pprint-annotated >= 0.0 && < 0.2 ghc-options: -Wall if impl(ghc >= 8.0) ghc-options: -Wnoncanonical-monad-instances hs-source-dirs: src exposed-modules: Hedgehog Hedgehog.Gen Hedgehog.Main Hedgehog.Range Hedgehog.Internal.Config Hedgehog.Internal.Discovery Hedgehog.Internal.Distributive Hedgehog.Internal.Exception Hedgehog.Internal.Gen Hedgehog.Internal.HTraversable Hedgehog.Internal.Opaque Hedgehog.Internal.Prelude Hedgehog.Internal.Property Hedgehog.Internal.Queue Hedgehog.Internal.Range Hedgehog.Internal.Region Hedgehog.Internal.Report Hedgehog.Internal.Runner Hedgehog.Internal.Seed Hedgehog.Internal.Show Hedgehog.Internal.Shrink Hedgehog.Internal.Source Hedgehog.Internal.State Hedgehog.Internal.TH Hedgehog.Internal.Tree Hedgehog.Internal.Tripping default-language: Haskell2010 test-suite test type: exitcode-stdio-1.0 main-is: test.hs ghc-options: -Wall -threaded -O2 hs-source-dirs: test other-modules: Test.Hedgehog.Applicative Test.Hedgehog.Confidence Test.Hedgehog.Filter Test.Hedgehog.Maybe Test.Hedgehog.Seed Test.Hedgehog.Text Test.Hedgehog.Zip build-depends: hedgehog , base >= 3 && < 5 , containers >= 0.4 && < 0.7 , mmorph >= 1.0 && < 1.2 , mtl >= 2.1 && < 2.3 , pretty-show >= 1.6 && < 1.11 , semigroups >= 0.16 && < 0.20 , text >= 1.1 && < 1.3 , transformers >= 0.3 && < 0.6 default-language: Haskell2010 hedgehog-1.0.3/LICENSE0000644060175106010010000000275413675330725013543 0ustar00Nikos00000000000000Copyright 2017-2018, Jacob Stanley All Rights Reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hedgehog-1.0.3/README.md0000644060175106010010000000662213675330725014013 0ustar00Nikos00000000000000
# Release with confidence. [![Hackage][hackage-shield]][hackage] [![Travis][travis-shield]][travis] [![AppVeyor][appveyor-shield]][appveyor]
[Hedgehog](http://hedgehog.qa/) 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. ## Features - Integrated shrinking, shrinks obey invariants by construction. - Abstract state machine testing. - Generators allow monadic effects. - Range combinators for full control over the scope of generated numbers and collections. - Equality and roundtrip assertions show a diff instead of the two inequal values. - Template Haskell test runner which executes properties concurrently. ## Example The main module, [Hedgehog][haddock-hedgehog], includes almost everything you need to get started writing property tests with Hedgehog. It is designed to be used alongside [Hedgehog.Gen][haddock-hedgehog-gen] and [Hedgehog.Range][haddock-hedgehog-range] which should be imported qualified. You also need to enable Template Haskell so the Hedgehog test runner can find your properties. ```hs {-# LANGUAGE TemplateHaskell #-} import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range ``` Once you have your imports set up, you can write a simple property: ```hs prop_reverse :: Property prop_reverse = property $ do xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha reverse (reverse xs) === xs ``` And add the Template Haskell splice which will discover your properties: ```hs tests :: IO Bool tests = checkParallel $$(discover) ``` If you prefer to avoid macros, you can specify the group of properties to run manually instead: ```hs {-# LANGUAGE OverloadedStrings #-} tests :: IO Bool tests = checkParallel $ Group "Test.Example" [ ("prop_reverse", prop_reverse) ] ``` You can then load the module in GHCi, and run it: ``` λ tests ━━━ Test.Example ━━━ ✓ prop_reverse passed 100 tests. ```

[hackage]: http://hackage.haskell.org/package/hedgehog [hackage-shield]: https://img.shields.io/hackage/v/hedgehog.svg?style=flat [travis]: https://travis-ci.org/hedgehogqa/haskell-hedgehog [travis-shield]: https://travis-ci.org/hedgehogqa/haskell-hedgehog.svg?branch=master [appveyor]: https://ci.appveyor.com/project/hedgehogqa/haskell-hedgehog [appveyor-shield]: https://ci.appveyor.com/api/projects/status/o4rlstbc80sum3on/branch/master?svg=true [haddock-hedgehog]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog.html [haddock-hedgehog-gen]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog-Gen.html [haddock-hedgehog-range]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog-Range.html hedgehog-1.0.3/Setup.hs0000644060175106010010000000005613605612514014153 0ustar00Nikos00000000000000import Distribution.Simple main = defaultMain hedgehog-1.0.3/src/0000755060175106010010000000000013675361065013316 5ustar00Nikos00000000000000hedgehog-1.0.3/src/Hedgehog/0000755060175106010010000000000013675361065015030 5ustar00Nikos00000000000000hedgehog-1.0.3/src/Hedgehog/Gen.hs0000644060175106010010000000257513675330725016105 0ustar00Nikos00000000000000module Hedgehog.Gen ( -- ** Shrinking shrink , prune -- ** Size , small , scale , resize , sized -- ** Integral , integral , integral_ , int , int8 , int16 , int32 , int64 , word , word8 , word16 , word32 , word64 -- ** Floating-point , realFloat , realFrac_ , float , double -- ** Enumeration , enum , enumBounded , bool , bool_ -- ** Characters , binit , octit , digit , hexit , lower , upper , alpha , alphaNum , ascii , latin1 , unicode , unicodeAll -- ** Strings , string , text , utf8 , bytes -- ** Choice , constant , element , choice , frequency , recursive -- ** Conditional , discard , filter , filterT , mapMaybe , mapMaybeT , just , justT -- ** Collections , maybe , either , either_ , list , seq , nonEmpty , set , map -- ** Subterms , freeze , subterm , subtermM , subterm2 , subtermM2 , subterm3 , subtermM3 -- ** Combinations & Permutations , subsequence , shuffle -- ** Abstract State Machine , sequential , parallel -- * Sampling Generators , sample , print , printTree , printWith , printTreeWith ) where import Hedgehog.Internal.Gen import Hedgehog.Internal.State (sequential, parallel) import Prelude hiding (either, filter, print, maybe, map, seq) hedgehog-1.0.3/src/Hedgehog/Internal/0000755060175106010010000000000013675361065016604 5ustar00Nikos00000000000000hedgehog-1.0.3/src/Hedgehog/Internal/Config.hs0000644060175106010010000000671613675330725020356 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Hedgehog.Internal.Config ( UseColor(..) , resolveColor , Verbosity(..) , resolveVerbosity , WorkerCount(..) , resolveWorkers , detectMark , detectColor , detectVerbosity , detectWorkers ) where import Control.Monad.IO.Class (MonadIO(..)) import qualified GHC.Conc as Conc import Language.Haskell.TH.Syntax (Lift) import System.Console.ANSI (hSupportsANSI) import System.Environment (lookupEnv) import System.IO (stdout) import Text.Read (readMaybe) -- | Whether to render output using ANSI colors or not. -- data UseColor = DisableColor -- ^ Disable ANSI colors in report output. | EnableColor -- ^ Enable ANSI colors in report output. deriving (Eq, Ord, Show, Lift) -- | How verbose should the report output be. -- data Verbosity = Quiet -- ^ Only display the summary of the test run. | Normal -- ^ Display each property as it is running, as well as the summary. deriving (Eq, Ord, Show, Lift) -- | The number of workers to use when running properties in parallel. -- newtype WorkerCount = WorkerCount Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift) detectMark :: MonadIO m => m Bool detectMark = do user <- liftIO $ lookupEnv "USER" pure $ user == Just "mth" lookupBool :: MonadIO m => String -> m (Maybe Bool) lookupBool key = liftIO $ do menv <- lookupEnv key case menv of Just "0" -> pure $ Just False Just "no" -> pure $ Just False Just "false" -> pure $ Just False Just "1" -> pure $ Just True Just "yes" -> pure $ Just True Just "true" -> pure $ Just True _ -> pure Nothing detectColor :: MonadIO m => m UseColor detectColor = liftIO $ do ok <- lookupBool "HEDGEHOG_COLOR" case ok of Just False -> pure DisableColor Just True -> pure EnableColor Nothing -> do mth <- detectMark if mth then pure DisableColor -- avoid getting fired :) else do enable <- hSupportsANSI stdout if enable then pure EnableColor else pure DisableColor detectVerbosity :: MonadIO m => m Verbosity detectVerbosity = liftIO $ do menv <- (readMaybe =<<) <$> lookupEnv "HEDGEHOG_VERBOSITY" case menv of Just (0 :: Int) -> pure Quiet Just (1 :: Int) -> pure Normal _ -> do mth <- detectMark if mth then pure Quiet else pure Normal detectWorkers :: MonadIO m => m WorkerCount detectWorkers = do liftIO $ do menv <- (readMaybe =<<) <$> lookupEnv "HEDGEHOG_WORKERS" case menv of Nothing -> WorkerCount <$> Conc.getNumProcessors Just env -> pure $ WorkerCount env resolveColor :: MonadIO m => Maybe UseColor -> m UseColor resolveColor = \case Nothing -> detectColor Just x -> pure x resolveVerbosity :: MonadIO m => Maybe Verbosity -> m Verbosity resolveVerbosity = \case Nothing -> detectVerbosity Just x -> pure x resolveWorkers :: MonadIO m => Maybe WorkerCount -> m WorkerCount resolveWorkers = \case Nothing -> detectWorkers Just x -> pure x hedgehog-1.0.3/src/Hedgehog/Internal/Discovery.hs0000644060175106010010000001332613675330725021113 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} module Hedgehog.Internal.Discovery ( PropertySource(..) , readProperties , findProperties , readDeclaration , Pos(..) , Position(..) ) where import Control.Exception (IOException, handle) import Control.Monad.IO.Class (MonadIO(..)) import qualified Data.Char as Char import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Ord as Ord import Hedgehog.Internal.Property (PropertyName(..)) import Hedgehog.Internal.Source (LineNo(..), ColumnNo(..)) #if __GLASGOW_HASKELL__ < 808 import Data.Semigroup (Semigroup(..)) #endif ------------------------------------------------------------------------ -- Property Extraction newtype PropertySource = PropertySource { propertySource :: Pos String } deriving (Eq, Ord, Show) readProperties :: MonadIO m => String -> FilePath -> m (Map PropertyName PropertySource) readProperties prefix path = findProperties prefix path <$> liftIO (readFile path) readDeclaration :: MonadIO m => FilePath -> LineNo -> m (Maybe (String, Pos String)) readDeclaration path line = do mfile <- liftIO $ readFileSafe path pure $ do file <- mfile takeHead . List.sortBy (Ord.comparing $ Ord.Down . posLine . posPostion . snd) . filter ((<= line) . posLine . posPostion . snd) $ Map.toList (findDeclarations path file) readFileSafe :: MonadIO m => FilePath -> m (Maybe String) readFileSafe path = liftIO $ handle (\(_ :: IOException) -> pure Nothing) (Just <$> readFile path) takeHead :: [a] -> Maybe a takeHead = \case [] -> Nothing x : _ -> Just x findProperties :: String -> FilePath -> String -> Map PropertyName PropertySource findProperties prefix path = Map.map PropertySource . Map.mapKeysMonotonic PropertyName . Map.filterWithKey (\k _ -> List.isPrefixOf prefix k) . findDeclarations path findDeclarations :: FilePath -> String -> Map String (Pos String) findDeclarations path = declarations . classified . positioned path ------------------------------------------------------------------------ -- Declaration Identification declarations :: [Classified (Pos Char)] -> Map String (Pos String) declarations = let loop = \case [] -> [] x : xs -> let (ys, zs) = break isDeclaration xs in tagWithName (forget x $ trimEnd ys) : loop zs in Map.fromListWith (<>) . loop . dropWhile (not . isDeclaration) trimEnd :: [Classified (Pos Char)] -> [Classified (Pos Char)] trimEnd xs = let (space0, code) = span isWhitespace $ reverse xs (line_tail0, space) = span (\(Classified _ (Pos _ x)) -> x /= '\n') $ reverse space0 line_tail = case space of [] -> line_tail0 x : _ -> line_tail0 ++ [x] in reverse code ++ line_tail isWhitespace :: Classified (Pos Char) -> Bool isWhitespace (Classified c (Pos _ x)) = c == Comment || Char.isSpace x tagWithName :: Pos String -> (String, Pos String) tagWithName (Pos p x) = (takeName x, Pos p x) takeName :: String -> String takeName xs = case words xs of [] -> "" x : _ -> x forget :: Classified (Pos Char) -> [Classified (Pos Char)] -> Pos String forget (Classified _ (Pos p x)) xs = Pos p $ x : fmap (posValue . classifiedValue) xs isDeclaration :: Classified (Pos Char) -> Bool isDeclaration (Classified c (Pos p x)) = c == NotComment && posColumn p == 1 && (Char.isLower x || x == '_') ------------------------------------------------------------------------ -- Comment Classification data Class = NotComment | Comment deriving (Eq, Ord, Show) data Classified a = Classified { _classifiedClass :: !Class , classifiedValue :: !a } deriving (Eq, Ord, Show) classified :: [Pos Char] -> [Classified (Pos Char)] classified = let ok = Classified NotComment ko = Classified Comment loop nesting in_line = \case [] -> [] x@(Pos _ '\n') : xs | in_line -> ok x : loop nesting False xs x : xs | in_line -> ko x : loop nesting in_line xs x@(Pos _ '{') : y@(Pos _ '-') : xs -> ko x : ko y : loop (nesting + 1) in_line xs x@(Pos _ '-') : y@(Pos _ '}') : xs | nesting > 0 -> ko x : ko y : loop (nesting - 1) in_line xs x : xs | nesting > 0 -> ko x : loop nesting in_line xs -- FIXME This is not technically correct, we should allow arbitrary runs -- FIXME of dashes followed by a symbol character. Here we have only -- FIXME allowed two. x@(Pos _ '-') : y@(Pos _ '-') : z@(Pos _ zz) : xs | not (Char.isSymbol zz) -> ko x : ko y : loop nesting True (z : xs) x : xs -> ok x : loop nesting in_line xs in loop (0 :: Int) False ------------------------------------------------------------------------ -- Character Positioning data Position = Position { _posPath :: !FilePath , posLine :: !LineNo , posColumn :: !ColumnNo } deriving (Eq, Ord, Show) data Pos a = Pos { posPostion :: !Position , posValue :: a } deriving (Eq, Ord, Show, Functor) instance Semigroup a => Semigroup (Pos a) where (<>) (Pos p x) (Pos q y) = if p < q then Pos p (x <> y) else Pos q (y <> x) positioned :: FilePath -> [Char] -> [Pos Char] positioned path = let loop l c = \case [] -> [] '\n' : xs -> Pos (Position path l c) '\n' : loop (l + 1) 1 xs x : xs -> Pos (Position path l c) x : loop l (c + 1) xs in loop 1 1 hedgehog-1.0.3/src/Hedgehog/Internal/Distributive.hs0000644060175106010010000000657313675330725021627 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Hedgehog.Internal.Distributive ( MonadTransDistributive(..) ) where import Control.Monad (join) import Control.Monad.Morph (MFunctor(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Identity (IdentityT(..)) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..)) import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..)) import Control.Monad.Trans.Reader (ReaderT(..)) import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Strict as Strict import GHC.Exts (Constraint) ------------------------------------------------------------------------ -- * MonadTransDistributive class MonadTransDistributive g where type Transformer (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *) (m :: * -> *) :: Constraint type Transformer f g m = ( Monad m , Monad (f m) , Monad (g m) , Monad (f (g m)) , MonadTrans f , MFunctor f ) -- | Distribute one monad transformer over another. -- distributeT :: Transformer f g m => g (f m) a -> f (g m) a instance MonadTransDistributive IdentityT where distributeT m = lift . IdentityT . pure =<< hoist lift (runIdentityT m) instance MonadTransDistributive MaybeT where distributeT m = lift . MaybeT . pure =<< hoist lift (runMaybeT m) instance MonadTransDistributive (ExceptT x) where distributeT m = lift . ExceptT . pure =<< hoist lift (runExceptT m) instance MonadTransDistributive (ReaderT r) where distributeT m = join . lift . ReaderT $ \r -> pure . hoist lift $ runReaderT m r instance Monoid w => MonadTransDistributive (Lazy.WriterT w) where distributeT m = lift . Lazy.WriterT . pure =<< hoist lift (Lazy.runWriterT m) instance Monoid w => MonadTransDistributive (Strict.WriterT w) where distributeT m = do lift . Strict.WriterT . pure =<< hoist lift (Strict.runWriterT m) instance MonadTransDistributive (Lazy.StateT s) where distributeT m = do s <- lift Lazy.get (a, s') <- hoist lift (Lazy.runStateT m s) lift (Lazy.put s') return a instance MonadTransDistributive (Strict.StateT s) where distributeT m = do s <- lift Strict.get (a, s') <- hoist lift (Strict.runStateT m s) lift (Strict.put s') return a instance Monoid w => MonadTransDistributive (Lazy.RWST r w s) where distributeT m = do -- ask and get combined (r, s0) <- lift . Lazy.RWST $ \r s -> return ((r, s), s, mempty) (a, s1, w) <- hoist lift (Lazy.runRWST m r s0) -- tell and put combined lift $ Lazy.RWST $ \_ _ -> return (a, s1, w) instance Monoid w => MonadTransDistributive (Strict.RWST r w s) where distributeT m = do -- ask and get combined (r, s0) <- lift . Strict.RWST $ \r s -> return ((r, s), s, mempty) (a, s1, w) <- hoist lift (Strict.runRWST m r s0) -- tell and put combined lift $ Strict.RWST $ \_ _ -> return (a, s1, w) hedgehog-1.0.3/src/Hedgehog/Internal/Exception.hs0000644060175106010010000000124713675330725021101 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} module Hedgehog.Internal.Exception ( tryAll , tryEvaluate ) where import Control.Exception (Exception(..), AsyncException, SomeException(..), evaluate) import Control.Monad.Catch (MonadCatch(..), throwM) import System.IO.Unsafe (unsafePerformIO) tryAll :: MonadCatch m => m a -> m (Either SomeException a) tryAll m = catch (fmap Right m) $ \exception -> case fromException exception :: Maybe AsyncException of Nothing -> pure $ Left exception Just async -> throwM async tryEvaluate :: a -> Either SomeException a tryEvaluate x = unsafePerformIO (tryAll (evaluate x)) hedgehog-1.0.3/src/Hedgehog/Internal/Gen.hs0000644060175106010010000012742413675330725017662 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- MonadBase #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE DerivingVia #-} #endif module Hedgehog.Internal.Gen ( -- * Transformer Gen , GenT(..) , MonadGen(..) -- * Combinators , generalize -- ** Shrinking , shrink , prune -- ** Size , small , scale , resize , sized -- ** Integral , integral , integral_ , int , int8 , int16 , int32 , int64 , word , word8 , word16 , word32 , word64 -- ** Floating-point , realFloat , realFrac_ , float , double -- ** Enumeration , enum , enumBounded , bool , bool_ -- ** Characters , binit , octit , digit , hexit , lower , upper , alpha , alphaNum , ascii , latin1 , unicode , unicodeAll -- ** Strings , string , text , utf8 , bytes -- ** Choice , constant , element , choice , frequency , recursive -- ** Conditional , discard , ensure , filter , mapMaybe , filterT , mapMaybeT , just , justT -- ** Collections , maybe , either , either_ , list , seq , nonEmpty , set , map -- ** Subterms , freeze , subterm , subtermM , subterm2 , subtermM2 , subterm3 , subtermM3 -- ** Combinations & Permutations , subsequence , shuffle , shuffleSeq -- * Sampling Generators , sample , print , printTree , printWith , printTreeWith , renderTree -- * Internal -- $internal -- ** Transfomer , runGenT , evalGen , evalGenT , mapGenT , generate , toTree , toTreeMaybeT , fromTree , fromTreeT , fromTreeMaybeT , runDiscardEffect , runDiscardEffectT -- ** Size , golden -- ** Shrinking , atLeast -- ** Characters , isSurrogate , isNoncharacter -- ** Subterms , Vec(..) , Nat(..) , subtermMVec ) where import Control.Applicative (Alternative(..),liftA2) import Control.Monad (MonadPlus(..), filterM, guard, replicateM, join) import Control.Monad.Base (MonadBase(..)) 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(..)) import qualified Control.Monad.Morph as Morph import Control.Monad.Primitive (PrimMonad(..)) import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except (ExceptT(..)) import Control.Monad.Trans.Identity (IdentityT(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.Resource (MonadResource(..)) import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Strict as Strict import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Zip (MonadZip(..)) import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.Char as Char import Data.Foldable (for_, toList) import Data.Functor.Identity (Identity(..)) import Data.Int (Int8, Int16, Int32, Int64) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Semigroup as Semigroup import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Set (Set) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Word (Word8, Word16, Word32, Word64) import Hedgehog.Internal.Distributive (MonadTransDistributive(..)) import Hedgehog.Internal.Prelude hiding (either, maybe, seq) import Hedgehog.Internal.Seed (Seed) import qualified Hedgehog.Internal.Seed as Seed import qualified Hedgehog.Internal.Shrink as Shrink import Hedgehog.Internal.Tree (Tree, TreeT(..), NodeT(..)) import qualified Hedgehog.Internal.Tree as Tree import Hedgehog.Range (Size, Range) import qualified Hedgehog.Range as Range #if __GLASGOW_HASKELL__ < 808 import qualified Control.Monad.Fail as Fail #endif #if __GLASGOW_HASKELL__ < 806 import Data.Coerce (coerce) #endif ------------------------------------------------------------------------ -- Generator transformer -- | Generator for random values of @a@. -- type Gen = GenT Identity -- | Monad transformer which can generate random values of @a@. -- newtype GenT m a = GenT { unGenT :: Size -> Seed -> TreeT (MaybeT m) a } -- | Runs a generator, producing its shrink tree. -- runGenT :: Size -> Seed -> GenT m a -> TreeT (MaybeT m) a runGenT size seed (GenT m) = m size seed -- | Run a generator, producing its shrink tree. -- -- 'Nothing' means discarded, 'Just' means we have a value. -- evalGen :: Size -> Seed -> Gen a -> Maybe (Tree a) evalGen size seed = Tree.mapMaybe id . evalGenT size seed -- | Runs a generator, producing its shrink tree. -- evalGenT :: Monad m => Size -> Seed -> GenT m a -> TreeT m (Maybe a) evalGenT size seed = runDiscardEffectT . runGenT size seed -- | Map over a generator's shrink tree. -- mapGenT :: (TreeT (MaybeT m) a -> TreeT (MaybeT n) b) -> GenT m a -> GenT n b mapGenT f gen = GenT $ \size seed -> f (runGenT size seed gen) -- | Lift a predefined shrink tree in to a generator, ignoring the seed and the -- size. -- fromTree :: MonadGen m => Tree a -> m a fromTree = fromTreeT . hoist (Morph.generalize) -- | Lift a predefined shrink tree in to a generator, ignoring the seed and the -- size. -- fromTreeT :: MonadGen m => TreeT (GenBase m) a -> m a fromTreeT x = fromTreeMaybeT $ hoist (MaybeT . fmap Just) x -- | Lift a predefined shrink tree in to a generator, ignoring the seed and the -- size. -- fromTreeMaybeT :: MonadGen m => TreeT (MaybeT (GenBase m)) a -> m a fromTreeMaybeT x = fromGenT . GenT $ \_ _ -> x -- | Observe a generator's shrink tree. -- toTree :: forall m a. (MonadGen m, GenBase m ~ Identity) => m a -> m (Tree a) toTree = withGenT $ mapGenT (Maybe.maybe empty pure . runDiscardEffect) -- | Lift a predefined shrink tree in to a generator, ignoring the seed and the -- size. -- toTreeMaybeT :: MonadGen m => m a -> m (TreeT (MaybeT (GenBase m)) a) toTreeMaybeT = withGenT $ mapGenT pure -- | Lazily run the discard effects through the tree and reify it a -- @Maybe (Tree a)@. -- -- 'Nothing' means discarded, 'Just' means we have a value. -- -- Discards in the child nodes of the tree are simply removed. -- runDiscardEffect :: TreeT (MaybeT Identity) a -> Maybe (Tree a) runDiscardEffect = Tree.mapMaybe id . runDiscardEffectT -- | Run the discard effects through the tree and reify them as 'Maybe' values -- at the nodes. -- -- 'Nothing' means discarded, 'Just' means we have a value. -- runDiscardEffectT :: Monad m => TreeT (MaybeT m) a -> TreeT m (Maybe a) runDiscardEffectT = runMaybeT . distributeT -- | Lift a @Gen / GenT Identity@ in to a @Monad m => GenT m@ -- generalize :: Monad m => Gen a -> GenT m a generalize = hoist Morph.generalize ------------------------------------------------------------------------ -- MonadGen -- | Class of monads which can generate input data for tests. -- class (Monad m, Monad (GenBase m)) => MonadGen m where type GenBase m :: (* -> *) -- | Extract a 'GenT' from a 'MonadGen'. -- toGenT :: m a -> GenT (GenBase m) a -- | Lift a 'GenT' in to a 'MonadGen'. -- fromGenT :: GenT (GenBase m) a -> m a -- | Transform a 'MonadGen' as a 'GenT'. -- withGenT :: (MonadGen m, MonadGen n) => (GenT (GenBase m) a -> GenT (GenBase n) b) -> m a -> n b withGenT f = fromGenT . f . toGenT instance Monad m => MonadGen (GenT m) where -- | The type of the transformer stack's base 'Monad'. -- type GenBase (GenT m) = m -- | Convert a 'MonadGen' to a 'GenT'. -- toGenT = id -- | Convert a 'GenT' to a 'MonadGen'. -- fromGenT = id instance MonadGen m => MonadGen (IdentityT m) where type GenBase (IdentityT m) = IdentityT (GenBase m) toGenT = distributeT . hoist toGenT fromGenT = hoist fromGenT . distributeT instance MonadGen m => MonadGen (MaybeT m) where type GenBase (MaybeT m) = MaybeT (GenBase m) toGenT = distributeT . hoist toGenT fromGenT = hoist fromGenT . distributeT instance MonadGen m => MonadGen (ExceptT x m) where type GenBase (ExceptT x m) = ExceptT x (GenBase m) toGenT = distributeT . hoist toGenT fromGenT = hoist fromGenT . distributeT instance MonadGen m => MonadGen (ReaderT r m) where type GenBase (ReaderT r m) = ReaderT r (GenBase m) toGenT = distributeT . hoist toGenT fromGenT = hoist fromGenT . distributeT instance MonadGen m => MonadGen (Lazy.StateT r m) where type GenBase (Lazy.StateT r m) = Lazy.StateT r (GenBase m) toGenT = distributeT . hoist toGenT fromGenT = hoist fromGenT . distributeT instance MonadGen m => MonadGen (Strict.StateT r m) where type GenBase (Strict.StateT r m) = Strict.StateT r (GenBase m) toGenT = distributeT . hoist toGenT fromGenT = hoist fromGenT . distributeT instance (MonadGen m, Monoid w) => MonadGen (Lazy.WriterT w m) where type GenBase (Lazy.WriterT w m) = Lazy.WriterT w (GenBase m) toGenT = distributeT . hoist toGenT fromGenT = hoist fromGenT . distributeT instance (MonadGen m, Monoid w) => MonadGen (Strict.WriterT w m) where type GenBase (Strict.WriterT w m) = Strict.WriterT w (GenBase m) toGenT = distributeT . hoist toGenT fromGenT = hoist fromGenT . distributeT ------------------------------------------------------------------------ -- GenT instances instance (Monad m, Semigroup a) => Semigroup (GenT m a) where (<>) = liftA2 (Semigroup.<>) instance (Monad m, Monoid a) => Monoid (GenT m a) where mappend = liftA2 mappend mempty = return mempty instance Functor m => Functor (GenT m) where fmap f gen = GenT $ \seed size -> fmap f (runGenT seed size gen) -- -- implementation: parallel shrinking -- instance Monad m => Applicative (GenT m) where pure = fromTreeMaybeT . pure (<*>) f m = GenT $ \ size seed -> case Seed.split seed of (sf, sm) -> uncurry ($) <$> runGenT size sf f `mzip` runGenT size sm m -- -- implementation: satisfies law (ap = <*>) -- --instance Monad m => Applicative (GenT m) where -- pure = -- fromTreeMaybeT . pure -- (<*>) f m = -- GenT $ \ size seed -> -- case Seed.split seed of -- (sf, sm) -> -- runGenT size sf f <*> -- runGenT size sm m instance Monad m => Monad (GenT m) where return = pure (>>=) m k = GenT $ \size seed -> case Seed.split seed of (sk, sm) -> runGenT size sk . k =<< runGenT size sm m #if __GLASGOW_HASKELL__ < 808 fail = Fail.fail #endif instance Monad m => MonadFail (GenT m) where fail = error instance Monad m => Alternative (GenT m) where empty = mzero (<|>) = mplus instance Monad m => MonadPlus (GenT m) where mzero = fromTreeMaybeT mzero mplus x y = GenT $ \size seed -> case Seed.split seed of (sx, sy) -> runGenT size sx x `mplus` runGenT size sy y instance MonadTrans GenT where lift = fromTreeMaybeT . lift . lift instance MFunctor GenT where hoist f = mapGenT (hoist (hoist f)) embedMaybeT :: MonadTrans t => Monad n => Monad (t (MaybeT n)) => (forall a. m a -> t (MaybeT n) a) -> MaybeT m b -> t (MaybeT n) b embedMaybeT f m = lift . MaybeT . pure =<< f (runMaybeT m) embedTreeMaybeT :: Monad n => (forall a. m a -> TreeT (MaybeT n) a) -> TreeT (MaybeT m) b -> TreeT (MaybeT n) b embedTreeMaybeT f tree_ = embed (embedMaybeT f) tree_ embedGenT :: Monad n => (forall a. m a -> GenT n a) -> GenT m b -> GenT n b embedGenT f gen = GenT $ \size seed -> case Seed.split seed of (sf, sg) -> (runGenT size sf . f) `embedTreeMaybeT` (runGenT size sg gen) instance MMonad GenT where embed = embedGenT distributeGenT :: Transformer t GenT m => GenT (t m) a -> t (GenT m) a distributeGenT x = join . lift . GenT $ \size seed -> pure . hoist fromTreeMaybeT . distributeT . hoist distributeT $ runGenT size seed x instance MonadTransDistributive GenT where type Transformer t GenT m = ( Monad (t (GenT m)) , Transformer t MaybeT m , Transformer t TreeT (MaybeT m) ) distributeT = distributeGenT instance PrimMonad m => PrimMonad (GenT m) where type PrimState (GenT m) = PrimState m primitive = lift . primitive instance MonadIO m => MonadIO (GenT m) where liftIO = lift . liftIO instance MonadBase b m => MonadBase b (GenT m) where liftBase = lift . liftBase #if __GLASGOW_HASKELL__ >= 806 deriving via (ReaderT Size (ReaderT Seed (TreeT (MaybeT m)))) instance MonadBaseControl b m => MonadBaseControl b (GenT m) #else instance MonadBaseControl b m => MonadBaseControl b (GenT m) where type StM (GenT m) a = StM (GloopT m) a liftBaseWith g = gloopToGen $ liftBaseWith $ \q -> g (\gen -> q (genToGloop gen)) restoreM = gloopToGen . restoreM type GloopT m = ReaderT Size (ReaderT Seed (TreeT (MaybeT m))) gloopToGen :: GloopT m a -> GenT m a gloopToGen = coerce genToGloop :: GenT m a -> GloopT m a genToGloop = coerce #endif instance MonadThrow m => MonadThrow (GenT m) where throwM = lift . throwM instance MonadCatch m => MonadCatch (GenT m) where catch m onErr = GenT $ \size seed -> case Seed.split seed of (sm, se) -> (runGenT size sm m) `catch` (runGenT size se . onErr) instance MonadReader r m => MonadReader r (GenT m) where ask = lift ask local f m = mapGenT (local f) m instance MonadState s m => MonadState s (GenT m) where get = lift get put = lift . put state = lift . state instance MonadWriter w m => MonadWriter w (GenT m) where writer = lift . writer tell = lift . tell listen m = GenT $ \size seed -> listen $ runGenT size seed m pass m = GenT $ \size seed -> pass $ runGenT size seed m instance MonadError e m => MonadError e (GenT m) where throwError = lift . throwError catchError m onErr = GenT $ \size seed -> case Seed.split seed of (sm, se) -> (runGenT size sm m) `catchError` (runGenT size se . onErr) instance MonadResource m => MonadResource (GenT m) where liftResourceT = lift . liftResourceT ------------------------------------------------------------------------ -- Combinators -- | Generate a value with no shrinks from a 'Size' and a 'Seed'. -- generate :: MonadGen m => (Size -> Seed -> a) -> m a generate f = fromGenT . GenT $ \size seed -> pure (f size seed) ------------------------------------------------------------------------ -- Combinators - Shrinking -- | Apply a shrinking function to a generator. -- -- This will give the generator additional shrinking options, while keeping -- the existing shrinks intact. -- shrink :: MonadGen m => (a -> [a]) -> m a -> m a shrink f = withGenT $ mapGenT (Tree.expand f) -- | Throw away a generator's shrink tree. -- prune :: MonadGen m => m a -> m a prune = withGenT $ mapGenT (Tree.prune 0) ------------------------------------------------------------------------ -- Combinators - Size -- | Construct a generator that depends on the size parameter. -- sized :: MonadGen m => (Size -> m a) -> m a sized f = do f =<< generate (\size _ -> size) -- | Override the size parameter. Returns a generator which uses the given size -- instead of the runtime-size parameter. -- resize :: MonadGen m => Size -> m a -> m a resize size gen = scale (const size) gen -- | Adjust the size parameter by transforming it with the given function. -- scale :: 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 -- | Make a generator smaller by scaling its size parameter. -- small :: MonadGen m => m a -> m a small = scale golden -- | Scale a size using the golden ratio. -- -- > golden x = x / φ -- > golden x = x / 1.61803.. -- golden :: Size -> Size golden x = round (fromIntegral x * 0.61803398875 :: Double) ------------------------------------------------------------------------ -- Combinators - Integral -- | Generates a random integral number in the given @[inclusive,inclusive]@ range. -- -- When the generator tries to shrink, it will shrink towards the -- 'Range.origin' of the specified 'Range'. -- -- For example, the following generator will produce a number between @1970@ -- and @2100@, but will shrink towards @2000@: -- -- @ -- integral (Range.'Range.constantFrom' 2000 1970 2100) :: 'Gen' 'Int' -- @ -- -- Some sample outputs from this generator might look like: -- -- > === Outcome === -- > 1973 -- > === Shrinks === -- > 2000 -- > 1987 -- > 1980 -- > 1976 -- > 1974 -- -- > === Outcome === -- > 2061 -- > === Shrinks === -- > 2000 -- > 2031 -- > 2046 -- > 2054 -- > 2058 -- > 2060 -- integral :: (MonadGen m, Integral a) => Range a -> m a integral range = shrink (Shrink.towards $ Range.origin range) (integral_ range) -- | Generates a random integral number in the [inclusive,inclusive] range. -- -- /This generator does not shrink./ -- integral_ :: (MonadGen m, Integral a) => Range a -> m a integral_ range = generate $ \size seed -> let (x, y) = Range.bounds size range in fromInteger . fst $ Seed.nextInteger (toInteger x) (toInteger y) seed -- | Generates a random machine integer in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- int :: MonadGen m => Range Int -> m Int int = integral -- | Generates a random 8-bit integer in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- int8 :: MonadGen m => Range Int8 -> m Int8 int8 = integral -- | Generates a random 16-bit integer in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- int16 :: MonadGen m => Range Int16 -> m Int16 int16 = integral -- | Generates a random 32-bit integer in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- int32 :: MonadGen m => Range Int32 -> m Int32 int32 = integral -- | Generates a random 64-bit integer in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- int64 :: MonadGen m => Range Int64 -> m Int64 int64 = integral -- | Generates a random machine word in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- word :: MonadGen m => Range Word -> m Word word = integral -- | Generates a random byte in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- word8 :: MonadGen m => Range Word8 -> m Word8 word8 = integral -- | Generates a random 16-bit word in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- word16 :: MonadGen m => Range Word16 -> m Word16 word16 = integral -- | Generates a random 32-bit word in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- word32 :: MonadGen m => Range Word32 -> m Word32 word32 = integral -- | Generates a random 64-bit word in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- word64 :: MonadGen m => Range Word64 -> m Word64 word64 = integral ------------------------------------------------------------------------ -- Combinators - Fractional / Floating-Point -- | Generates a random floating-point number in the @[inclusive,exclusive)@ range. -- -- /This generator works the same as 'integral', but for floating point numbers./ -- realFloat :: (MonadGen m, RealFloat a) => Range a -> m a realFloat range = shrink (Shrink.towardsFloat $ Range.origin range) (realFrac_ range) -- | Generates a random fractional number in the [inclusive,exclusive) range. -- -- /This generator does not shrink./ -- realFrac_ :: (MonadGen m, RealFrac a) => Range a -> m a realFrac_ range = generate $ \size seed -> let (x, y) = Range.bounds size range in realToFrac . fst $ Seed.nextDouble (realToFrac x) (realToFrac y) seed -- | Generates a random floating-point number in the @[inclusive,exclusive)@ range. -- -- /This is a specialization of 'realFloat', offered for convenience./ -- float :: MonadGen m => Range Float -> m Float float = realFloat -- | Generates a random floating-point number in the @[inclusive,exclusive)@ range. -- -- /This is a specialization of 'realFloat', offered for convenience./ -- double :: MonadGen m => Range Double -> m Double double = realFloat ------------------------------------------------------------------------ -- Combinators - Enumeration -- | Generates an element from an enumeration. -- -- This generator shrinks towards the first argument. -- -- For example: -- -- @ -- enum \'a' \'z' :: 'Gen' 'Char' -- @ -- enum :: (MonadGen m, Enum a) => a -> a -> m a enum lo hi = fmap toEnum . integral $ Range.constant (fromEnum lo) (fromEnum hi) -- | Generates a random value from a bounded enumeration. -- -- This generator shrinks towards 'minBound'. -- -- For example: -- -- @ -- enumBounded :: 'Gen' 'Bool' -- @ -- -- /This is implemented in terms of the 'Enum' class, and thus may be/ -- /partial for integral types larger than 'Int', e.g. 'Word64'./ enumBounded :: (MonadGen m, Enum a, Bounded a) => m a enumBounded = enum minBound maxBound -- | Generates a random boolean. -- -- This generator shrinks to 'False'. -- -- /This is a specialization of 'enumBounded', offered for convenience./ -- bool :: MonadGen m => m Bool bool = enumBounded -- | Generates a random boolean. -- -- /This generator does not shrink./ -- bool_ :: MonadGen m => m Bool bool_ = generate $ \_ seed -> (/= 0) . fst $ Seed.nextInteger 0 1 seed ------------------------------------------------------------------------ -- Combinators - Characters -- | Generates an ASCII binit: @'0'..'1'@ -- binit :: MonadGen m => m Char binit = enum '0' '1' -- | Generates an ASCII octit: @'0'..'7'@ -- octit :: MonadGen m => m Char octit = enum '0' '7' -- | Generates an ASCII digit: @'0'..'9'@ -- digit :: MonadGen m => m Char digit = enum '0' '9' -- | Generates an ASCII hexit: @'0'..'9', \'a\'..\'f\', \'A\'..\'F\'@ -- hexit :: MonadGen m => m Char hexit = -- FIXME optimize lookup, use a SmallArray or something. element "0123456789aAbBcCdDeEfF" -- | Generates an ASCII lowercase letter: @\'a\'..\'z\'@ -- lower :: MonadGen m => m Char lower = enum 'a' 'z' -- | Generates an ASCII uppercase letter: @\'A\'..\'Z\'@ -- upper :: MonadGen m => m Char upper = enum 'A' 'Z' -- | Generates an ASCII letter: @\'a\'..\'z\', \'A\'..\'Z\'@ -- alpha :: MonadGen m => m Char alpha = -- FIXME optimize lookup, use a SmallArray or something. element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" -- | Generates an ASCII letter or digit: @\'a\'..\'z\', \'A\'..\'Z\', \'0\'..\'9\'@ -- alphaNum :: MonadGen m => m Char alphaNum = -- FIXME optimize lookup, use a SmallArray or something. element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" -- | Generates an ASCII character: @'\0'..'\127'@ -- ascii :: MonadGen m => m Char ascii = enum '\0' '\127' -- | Generates a Latin-1 character: @'\0'..'\255'@ -- latin1 :: MonadGen m => m Char latin1 = enum '\0' '\255' -- | Generates a Unicode character, excluding noncharacters and invalid standalone surrogates: -- @'\0'..'\1114111' (excluding '\55296'..'\57343', '\65534', '\65535')@ -- unicode :: (MonadGen m) => m Char unicode = let s1 = (55296, enum '\0' '\55295') s2 = (8190, enum '\57344' '\65533') s3 = (1048576, enum '\65536' '\1114111') in frequency [s1, s2, s3] -- | Generates a Unicode character, including noncharacters and invalid standalone surrogates: -- @'\0'..'\1114111'@ -- unicodeAll :: MonadGen m => m Char unicodeAll = enumBounded -- | Check if a character is in the surrogate category. -- isSurrogate :: Char -> Bool isSurrogate x = x >= '\55296' && x <= '\57343' -- | Check if a character is one of the noncharacters '\65534', '\65535'. -- isNoncharacter :: Char -> Bool isNoncharacter x = x == '\65534' || x == '\65535' ------------------------------------------------------------------------ -- Combinators - Strings -- | Generates a string using 'Range' to determine the length. -- -- /This is a specialization of 'list', offered for convenience./ -- string :: MonadGen m => Range Int -> m Char -> m String string = list -- | Generates a string using 'Range' to determine the length. -- text :: MonadGen m => Range Int -> m Char -> m Text text range = fmap Text.pack . string range -- | Generates a UTF-8 encoded string, using 'Range' to determine the length. -- utf8 :: MonadGen m => Range Int -> m Char -> m ByteString utf8 range = fmap Text.encodeUtf8 . text range -- | Generates a random 'ByteString', using 'Range' to determine the -- length. -- bytes :: MonadGen m => Range Int -> m ByteString bytes range = fmap ByteString.pack $ choice [ list range . word8 $ Range.constant (fromIntegral $ Char.ord 'a') (fromIntegral $ Char.ord 'z') , list range . word8 $ Range.constant minBound maxBound ] ------------------------------------------------------------------------ -- Combinators - Choice -- | Trivial generator that always produces the same element. -- -- /This is another name for 'pure' \/ 'return'./ constant :: MonadGen m => a -> m a constant = pure -- | Randomly selects one of the elements in the list. -- -- This generator shrinks towards the first element in the list. -- -- /The input list must be non-empty./ -- element :: MonadGen m => [a] -> m a element = \case [] -> error "Hedgehog.Gen.element: used with empty list" xs -> do n <- integral $ Range.constant 0 (length xs - 1) pure $ xs !! n -- | Randomly selects one of the generators in the list. -- -- This generator shrinks towards the first generator in the list. -- -- /The input list must be non-empty./ -- choice :: MonadGen m => [m a] -> m a choice = \case [] -> error "Hedgehog.Gen.choice: used with empty list" xs -> do n <- integral $ Range.constant 0 (length xs - 1) xs !! n -- | Uses a weighted distribution to randomly select one of the generators in -- the list. -- -- This generator shrinks towards the first generator in the list. -- -- /The input list must be non-empty./ -- frequency :: MonadGen m => [(Int, m a)] -> m a frequency = \case [] -> error "Hedgehog.Gen.frequency: used with empty list" xs0 -> do let pick n = \case [] -> error "Hedgehog.Gen.frequency/pick: used with empty list" (k, x) : xs -> if n <= k then x else pick (n - k) xs total = sum (fmap fst xs0) n <- integral $ Range.constant 1 total pick n xs0 -- | Modifies combinators which choose from a list of generators, like 'choice' -- or 'frequency', so that they can be used in recursive scenarios. -- -- This combinator modifies its target to select one of the generators in -- either the non-recursive or the recursive list. When a selection is made -- from the recursive list, the 'Size' is halved. When the 'Size' gets to one -- or less, selections are no longer made from the recursive list, this -- ensures termination. -- -- A good example of where this might be useful is abstract syntax trees: -- -- @ -- data Expr = -- Var String -- | Lam String Expr -- | App Expr Expr -- -- -- Assuming we have a name generator -- genName :: 'MonadGen' m => m String -- -- -- We can write a generator for expressions -- genExpr :: 'MonadGen' m => m Expr -- genExpr = -- Gen.'recursive' Gen.'choice' [ -- -- non-recursive generators -- Var '<$>' genName -- ] [ -- -- recursive generators -- Gen.'subtermM' genExpr (\x -> Lam '<$>' genName '<*>' pure x) -- , Gen.'subterm2' genExpr genExpr App -- ] -- @ -- -- If we wrote the above example using only 'choice', it is likely that it -- would fail to terminate. This is because for every call to @genExpr@, -- there is a 2 in 3 chance that we will recurse again. -- recursive :: MonadGen m => ([m a] -> m a) -> [m a] -> [m a] -> m a recursive f nonrec rec = sized $ \n -> if n <= 1 then f nonrec else f $ nonrec ++ fmap small rec ------------------------------------------------------------------------ -- Combinators - Conditional -- | Discards the whole generator. -- discard :: MonadGen m => m a discard = fromGenT empty -- | Discards the generator if the generated value does not satisfy the -- predicate. -- ensure :: MonadGen m => (a -> Bool) -> m a -> m a ensure p gen = do x <- gen if p x then pure x else discard fromPred :: (a -> Bool) -> a -> Maybe a fromPred p a = a <$ guard (p a) -- | Generates a value that satisfies a predicate. -- -- This is essentially: -- -- @ -- filter p gen = 'mfilter' p gen '<|>' filter p gen -- @ -- -- 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. -- filter :: (MonadGen m, GenBase m ~ Identity) => (a -> Bool) -> m a -> m a filter p = mapMaybe (fromPred p) mapMaybe :: (MonadGen m, GenBase m ~ Identity) => (a -> Maybe b) -> m a -> m b mapMaybe p gen0 = let try k = if k > 100 then discard else do (x, gen) <- freeze $ scale (2 * k +) gen0 case p x of Just _ -> withGenT (mapGenT (Tree.mapMaybeMaybeT p)) gen Nothing -> try (k + 1) in try 0 filterT :: MonadGen m => (a -> Bool) -> m a -> m a filterT p = mapMaybeT (fromPred p) mapMaybeT :: MonadGen m => (a -> Maybe b) -> m a -> m b mapMaybeT p gen0 = let try k = if k > 100 then discard else do (x, gen) <- freeze $ scale (2 * k +) gen0 case p x of Just _ -> withGenT (mapGenT (Tree.mapMaybeT p)) gen Nothing -> try (k + 1) in try 0 -- | Runs a 'Maybe' generator until it produces a 'Just'. -- -- /This is implemented using 'filter' and has the same caveats./ -- just :: (MonadGen m, GenBase m ~ Identity) => m (Maybe a) -> m a just g = do mx <- filter Maybe.isJust g case mx of Just x -> pure x Nothing -> error "Hedgehog.Gen.just: internal error, unexpected Nothing" -- | Runs a 'Maybe' generator until it produces a 'Just'. -- -- /This is implemented using 'filter' and has the same caveats./ -- justT :: MonadGen m => m (Maybe a) -> m a justT g = do mx <- filterT Maybe.isJust g case mx of Just x -> pure x Nothing -> error "Hedgehog.Gen.just: internal error, unexpected Nothing" ------------------------------------------------------------------------ -- Combinators - Collections -- | Generates a 'Nothing' some of the time. -- maybe :: MonadGen m => m a -> m (Maybe a) maybe gen = sized $ \n -> frequency [ (2, pure Nothing) , (1 + fromIntegral n, Just <$> gen) ] -- | Generates either an 'a' or a 'b'. -- -- As the size grows, this generator generates @Right@s more often than @Left@s. -- either :: MonadGen m => m a -> m b -> m (Either a b) either genA genB = sized $ \n -> frequency [ (2, Left <$> genA) , (1 + fromIntegral n, Right <$> genB) ] -- | Generates either an 'a' or a 'b', without bias. -- -- This generator generates as many @Right@s as it does @Left@s. -- either_ :: MonadGen m => m a -> m b -> m (Either a b) either_ genA genB = choice [ Left <$> genA , Right <$> genB ] -- | Generates a list using a 'Range' to determine the length. -- list :: MonadGen m => Range Int -> m a -> m [a] list range gen = let interleave = (interleaveTreeT . nodeValue =<<) in sized $ \size -> ensure (atLeast $ Range.lowerBound size range) . withGenT (mapGenT (TreeT . interleave . runTreeT)) $ do n <- integral_ range replicateM n (toTreeMaybeT gen) interleaveTreeT :: Monad m => [TreeT m a] -> m (NodeT m [a]) interleaveTreeT = fmap Tree.interleave . traverse runTreeT -- | Generates a seq using a 'Range' to determine the length. -- seq :: MonadGen m => Range Int -> m a -> m (Seq a) seq range gen = Seq.fromList <$> list range gen -- | Generates a non-empty list using a 'Range' to determine the length. -- nonEmpty :: MonadGen m => Range Int -> m a -> m (NonEmpty a) nonEmpty range gen = do xs <- list (fmap (max 1) range) gen case xs of [] -> error "Hedgehog.Gen.nonEmpty: internal error, generated empty list" _ -> pure $ NonEmpty.fromList xs -- | Generates a set using a 'Range' to determine the length. -- -- /This may fail to generate anything if the element generator/ -- /cannot produce a large enough number of unique items to satify/ -- /the required set size./ -- set :: (MonadGen m, Ord a) => Range Int -> m a -> m (Set a) set range gen = fmap Map.keysSet . map range $ fmap (, ()) gen -- | Generates a map using a 'Range' to determine the length. -- -- /This may fail to generate anything if the keys produced by the/ -- /generator do not account for a large enough number of unique/ -- /items to satify the required map size./ -- map :: (MonadGen m, Ord k) => Range Int -> m (k, v) -> m (Map k v) map range gen = sized $ \size -> ensure ((>= Range.lowerBound size range) . Map.size) . fmap Map.fromList . (sequence =<<) . shrink Shrink.list $ do k <- integral_ range uniqueByKey k gen -- | Generate exactly 'n' unique generators. -- uniqueByKey :: (MonadGen m, Ord k) => Int -> m (k, v) -> m [m (k, v)] uniqueByKey n gen = let try k xs0 = if k > 100 then discard else replicateM n (freeze gen) >>= \kvs -> case uniqueInsert n xs0 (fmap (first fst) kvs) of Left xs -> pure $ Map.elems xs Right xs -> try (k + 1) xs in try (0 :: Int) Map.empty uniqueInsert :: Ord k => Int -> Map k v -> [(k, v)] -> Either (Map k v) (Map k v) uniqueInsert n xs kvs0 = if Map.size xs >= n then Left xs else case kvs0 of [] -> Right xs (k, v) : kvs -> uniqueInsert n (Map.insertWith (\x _ -> x) k v xs) kvs -- | Check that list contains at least a certain number of elements. -- atLeast :: Int -> [a] -> Bool atLeast n = if n == 0 then const True else not . null . drop (n - 1) ------------------------------------------------------------------------ -- Combinators - Subterms data Subterms n a = One a | All (Vec n a) deriving (Functor, Foldable, Traversable) data Nat = Z | S Nat data Vec n a where Nil :: Vec 'Z a (:.) :: a -> Vec n a -> Vec ('S n) a infixr 5 :. deriving instance Functor (Vec n) deriving instance Foldable (Vec n) deriving instance Traversable (Vec n) -- | Freeze the size and seed used by a generator, so we can inspect the value -- which it will produce. -- -- This is used for implementing `list` and `subtermMVec`. It allows us to -- shrink the list itself before trying to shrink the values inside the list. -- freeze :: MonadGen m => m a -> m (a, m a) freeze = withGenT $ \gen -> GenT $ \size seed -> do mx <- lift . lift . runMaybeT . runTreeT $ runGenT size seed gen case mx of Nothing -> empty Just (NodeT x xs) -> pure (x, fromGenT . fromTreeMaybeT . Tree.fromNodeT $ NodeT x xs) shrinkSubterms :: Subterms n a -> [Subterms n a] shrinkSubterms = \case One _ -> [] All xs -> fmap One $ toList xs genSubterms :: MonadGen m => Vec n (m a) -> m (Subterms n a) genSubterms = (sequence =<<) . shrink shrinkSubterms . fmap All . mapM (fmap snd . freeze) fromSubterms :: Applicative m => (Vec n a -> m a) -> Subterms n a -> m a fromSubterms f = \case One x -> pure x All xs -> f xs -- | Constructs a generator from a number of sub-term generators. -- -- /Shrinks to one of the sub-terms if possible./ -- subtermMVec :: MonadGen m => Vec n (m a) -> (Vec n a -> m a) -> m a subtermMVec gs f = fromSubterms f =<< genSubterms gs -- | Constructs a generator from a sub-term generator. -- -- /Shrinks to the sub-term if possible./ -- subtermM :: MonadGen m => m a -> (a -> m a) -> m a subtermM gx f = subtermMVec (gx :. Nil) $ \(x :. Nil) -> f x -- | Constructs a generator from a sub-term generator. -- -- /Shrinks to the sub-term if possible./ -- subterm :: MonadGen m => m a -> (a -> a) -> m a subterm gx f = subtermM gx $ \x -> pure (f x) -- | Constructs a generator from two sub-term generators. -- -- /Shrinks to one of the sub-terms if possible./ -- subtermM2 :: MonadGen m => m a -> m a -> (a -> a -> m a) -> m a subtermM2 gx gy f = subtermMVec (gx :. gy :. Nil) $ \(x :. y :. Nil) -> f x y -- | Constructs a generator from two sub-term generators. -- -- /Shrinks to one of the sub-terms if possible./ -- subterm2 :: MonadGen m => m a -> m a -> (a -> a -> a) -> m a subterm2 gx gy f = subtermM2 gx gy $ \x y -> pure (f x y) -- | Constructs a generator from three sub-term generators. -- -- /Shrinks to one of the sub-terms if possible./ -- subtermM3 :: MonadGen m => m a -> m a -> m a -> (a -> a -> a -> m a) -> m a subtermM3 gx gy gz f = subtermMVec (gx :. gy :. gz :. Nil) $ \(x :. y :. z :. Nil) -> f x y z -- | Constructs a generator from three sub-term generators. -- -- /Shrinks to one of the sub-terms if possible./ -- subterm3 :: MonadGen m => m a -> m a -> m a -> (a -> a -> a -> a) -> m a subterm3 gx gy gz f = subtermM3 gx gy gz $ \x y z -> pure (f x y z) ------------------------------------------------------------------------ -- Combinators - Combinations & Permutations -- | Generates a random subsequence of a list. -- subsequence :: MonadGen m => [a] -> m [a] subsequence xs = shrink Shrink.list $ filterM (const bool_) xs -- | Generates a random permutation of a list. -- -- /This shrinks towards the order of the list being identical to the input/ -- /list./ -- shuffle :: MonadGen m => [a] -> m [a] -- We shuffle sequences instead of lists to make extracting an arbitrary -- element logarithmic instead of linear, and to make length calculation -- constant-time instead of linear. We could probably do better, but -- this is at least reasonably quick. shuffle = fmap toList . shuffleSeq . Seq.fromList -- | Generates a random permutation of a sequence. -- -- /This shrinks towards the order of the sequence being identical to the input/ -- /sequence./ -- shuffleSeq :: MonadGen m => Seq a -> m (Seq a) shuffleSeq xs = if null xs then pure Seq.empty else do n <- integral $ Range.constant 0 (length xs - 1) #if MIN_VERSION_containers(0,5,8) -- Data.Sequence should offer a version of deleteAt that returns the -- deleted element, but it does not currently do so. Lookup followed -- by deletion seems likely faster than splitting and then appending, -- but I haven't actually tested that. It's certainly easier to see -- what's going on. case Seq.lookup n xs of Just y -> (y Seq.<|) <$> shuffleSeq (Seq.deleteAt n xs) Nothing -> error "Hedgehog.Gen.shuffleSeq: internal error, lookup in empty sequence" #else case Seq.splitAt n xs of (beginning, end) -> case Seq.viewl end of y Seq.:< end' -> (y Seq.<|) <$> shuffleSeq (beginning Seq.>< end') Seq.EmptyL -> error "Hedgehog.Gen.shuffleSeq: internal error, lookup in empty sequence" #endif ------------------------------------------------------------------------ -- Sampling -- | Generate a sample from a generator. -- sample :: 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) -- | Run a generator with a random seed and print the outcome, and the first -- level of shrinks. -- -- @ -- Gen.print (Gen.'enum' \'a\' \'f\') -- @ -- -- > === Outcome === -- > 'd' -- > === Shrinks === -- > 'a' -- > 'b' -- > 'c' -- print :: (MonadIO m, Show a) => Gen a -> m () print gen = do seed <- liftIO Seed.random printWith 30 seed gen -- | Print the value produced by a generator, and the first level of shrinks, -- for the given size and seed. -- -- Use 'print' to generate a value from a random seed. -- printWith :: (MonadIO m, Show a) => Size -> Seed -> Gen a -> m () printWith size seed gen = liftIO $ do case evalGen size seed gen of Nothing -> do putStrLn "=== Outcome ===" putStrLn "" Just tree_ -> do let NodeT x ss = runIdentity (runTreeT tree_) putStrLn "=== Outcome ===" putStrLn (show x) putStrLn "=== Shrinks ===" for_ ss $ \s -> let NodeT y _ = runIdentity $ runTreeT s in putStrLn (show y) -- | Run a generator with a random seed and print the resulting shrink tree. -- -- @ -- Gen.printTree (Gen.'enum' \'a\' \'f\') -- @ -- -- > 'd' -- > ├╼'a' -- > ├╼'b' -- > │ └╼'a' -- > └╼'c' -- > ├╼'a' -- > └╼'b' -- > └╼'a' -- -- /This may not terminate when the tree is very large./ -- printTree :: (MonadIO m, Show a) => Gen a -> m () printTree gen = do seed <- liftIO Seed.random printTreeWith 30 seed gen -- | Print the shrink tree produced by a generator, for the given size and -- seed. -- -- Use 'printTree' to generate a value from a random seed. -- printTreeWith :: (MonadIO m, Show a) => Size -> Seed -> Gen a -> m () printTreeWith size seed gen = do liftIO . putStr $ renderTree size seed gen -- | Render the shrink tree produced by a generator, for the given size and -- seed. -- renderTree :: Show a => Size -> Seed -> Gen a -> String renderTree size seed gen = case evalGen size seed gen of Nothing -> "" Just x -> Tree.render (fmap show x) ------------------------------------------------------------------------ -- Internal -- $internal -- -- These functions are exported in case you need them in a pinch, but are not -- part of the public API and may change at any time, even as part of a minor -- update. hedgehog-1.0.3/src/Hedgehog/Internal/HTraversable.hs0000644060175106010010000000056313675330725021525 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE RankNTypes #-} module Hedgehog.Internal.HTraversable ( HTraversable(..) ) where -- | Higher-order traversable functors. -- -- This is used internally to make symbolic variables concrete given an 'Environment'. -- class HTraversable t where htraverse :: Applicative f => (forall a. g a -> f (h a)) -> t g -> f (t h) hedgehog-1.0.3/src/Hedgehog/Internal/Opaque.hs0000644060175106010010000000106013675330725020366 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} module Hedgehog.Internal.Opaque ( Opaque(..) ) where -- | Opaque values. -- -- Useful if you want to put something without a 'Show' instance inside -- something which you'd like to be able to display. -- -- For example: -- -- @ -- data State v = -- State { -- stateRefs :: [Var (Opaque (IORef Int)) v] -- } deriving (Eq, Show) -- @ -- newtype Opaque a = Opaque { unOpaque :: a } deriving (Eq, Ord) instance Show (Opaque a) where showsPrec _ (Opaque _) = showString "Opaque" hedgehog-1.0.3/src/Hedgehog/Internal/Prelude.hs0000644060175106010010000000070113675330725020535 0ustar00Nikos00000000000000{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# LANGUAGE NoImplicitPrelude #-} -- | Mostly for compatibility across different base Prelude changes. -- module Hedgehog.Internal.Prelude ( Semigroup(..) , MonadFail , module Prelude ) where import Control.Monad.Fail (MonadFail) import Data.Semigroup (Semigroup(..)) import Prelude hiding (filter, print, map) hedgehog-1.0.3/src/Hedgehog/Internal/Property.hs0000644060175106010010000010541413675330725020770 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Distributive module Hedgehog.Internal.Property ( -- * Property Property(..) , PropertyT(..) , PropertyName(..) , PropertyConfig(..) , TestLimit(..) , TestCount(..) , DiscardLimit(..) , DiscardCount(..) , ShrinkLimit(..) , ShrinkCount(..) , ShrinkRetries(..) , withTests , withDiscards , withShrinks , withRetries , property , test , forAll , forAllT , forAllWith , forAllWithT , defaultMinTests , discard -- * Group , Group(..) , GroupName(..) , PropertyCount(..) -- * TestT , MonadTest(..) , Test , TestT(..) , Log(..) , Journal(..) , Failure(..) , Diff(..) , annotate , annotateShow , footnote , footnoteShow , failure , success , assert , diff , (===) , (/==) , eval , evalNF , evalM , evalIO , evalEither , evalExceptT -- * Coverage , Coverage(..) , Label(..) , LabelName(..) , cover , classify , label , collect , coverPercentage , labelCovered , coverageSuccess , coverageFailures , journalCoverage , Cover(..) , CoverCount(..) , CoverPercentage(..) , toCoverCount -- * Confidence , Confidence(..) , TerminationCriteria(..) , confidenceSuccess , confidenceFailure , withConfidence , verifiedTermination , defaultConfidence -- * Internal -- $internal , defaultConfig , mapConfig , failDiff , failException , failWith , writeLog , mkTest , mkTestT , runTest , runTestT , wilsonBounds ) where import Control.Applicative (Alternative(..)) import Control.DeepSeq (NFData, rnf) 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(..)) import Control.Monad.Morph (MFunctor(..)) import Control.Monad.Primitive (PrimMonad(..)) import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Cont (ContT) import Control.Monad.Trans.Control (ComposeSt, defaultLiftBaseWith, defaultRestoreM) import Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..)) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.Identity (IdentityT) import Control.Monad.Trans.Maybe (MaybeT) import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.Resource (MonadResource(..)) import Control.Monad.Trans.Resource (ResourceT) import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Strict as Strict import qualified Data.Char as Char import Data.Functor (($>)) import Data.Functor.Identity (Identity(..)) import Data.Int (Int64) import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Number.Erf (invnormcdf) import qualified Data.List as List import Data.String (IsString) import Data.Ratio ((%)) import Data.Typeable (typeOf) import Hedgehog.Internal.Distributive import Hedgehog.Internal.Exception import Hedgehog.Internal.Gen (Gen, GenT) import qualified Hedgehog.Internal.Gen as Gen import Hedgehog.Internal.Prelude import Hedgehog.Internal.Show import Hedgehog.Internal.Source import Language.Haskell.TH.Syntax (Lift) ------------------------------------------------------------------------ -- | A property test, along with some configurable limits like how many times -- to run the test. -- data Property = Property { propertyConfig :: !PropertyConfig , propertyTest :: PropertyT IO () } -- | The property monad transformer allows both the generation of test inputs -- and the assertion of expectations. -- newtype PropertyT m a = PropertyT { unPropertyT :: TestT (GenT m) a } deriving ( Functor , Applicative , Monad , MonadIO , MonadBase b , MonadThrow , MonadCatch , MonadReader r , MonadState s , MonadError e ) -- NOTE: Move this to the deriving list above when we drop 7.10 deriving instance MonadResource m => MonadResource (PropertyT m) -- NOTE: Move this to the deriving list above when we drop 8.0 #if __GLASGOW_HASKELL__ >= 802 deriving instance MonadBaseControl b m => MonadBaseControl b (PropertyT m) #else instance MonadBaseControl b m => MonadBaseControl b (PropertyT m) where type StM (PropertyT m) a = StM (TestT (GenT m)) a liftBaseWith f = PropertyT $ liftBaseWith $ \rib -> f (rib . unPropertyT) restoreM = PropertyT . restoreM #endif -- | A test monad allows the assertion of expectations. -- type Test = TestT Identity -- | A test monad transformer allows the assertion of expectations. -- newtype TestT m a = TestT { unTest :: ExceptT Failure (Lazy.WriterT Journal m) a } deriving ( Functor , Applicative , MonadIO , MonadBase b , MonadThrow , MonadCatch , MonadReader r , MonadState s ) -- | The name of a property. -- -- Should be constructed using `OverloadedStrings`: -- -- @ -- "apples" :: PropertyName -- @ -- newtype PropertyName = PropertyName { unPropertyName :: String } deriving (Eq, Ord, Show, IsString, Semigroup, Lift) -- | The acceptable occurrence of false positives -- -- Example, @Confidence 10^9@ would mean that you'd accept a false positive -- for 1 in 10^9 tests. newtype Confidence = Confidence { unConfidence :: Int64 } deriving (Eq, Ord, Show, Num, Lift) -- | Configuration for a property test. -- data PropertyConfig = PropertyConfig { propertyDiscardLimit :: !DiscardLimit , propertyShrinkLimit :: !ShrinkLimit , propertyShrinkRetries :: !ShrinkRetries , propertyTerminationCriteria :: !TerminationCriteria } deriving (Eq, Ord, Show, Lift) -- | The number of successful tests that need to be run before a property test -- is considered successful. -- -- Can be constructed using numeric literals: -- -- @ -- 200 :: TestLimit -- @ -- newtype TestLimit = TestLimit Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift) -- | The number of tests a property ran successfully. -- newtype TestCount = TestCount Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral) -- | The number of tests a property had to discard. -- newtype DiscardCount = DiscardCount Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral) -- | The number of discards to allow before giving up. -- -- Can be constructed using numeric literals: -- -- @ -- 10000 :: DiscardLimit -- @ -- -- newtype DiscardLimit = DiscardLimit Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift) -- | The number of shrinks to try before giving up on shrinking. -- -- Can be constructed using numeric literals: -- -- @ -- 1000 :: ShrinkLimit -- @ -- newtype ShrinkLimit = ShrinkLimit Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift) -- | The numbers of times a property was able to shrink after a failing test. -- newtype ShrinkCount = ShrinkCount Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral) -- | 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. -- -- If you are doing parallel state machine testing, you should probably set -- shrink retries to something like @10@. This will mean that during -- shrinking, a parallel test case requires 10 successful runs before it is -- passes and we try a different shrink. -- -- Can be constructed using numeric literals: -- -- @ -- 0 :: ShrinkRetries -- @ -- newtype ShrinkRetries = ShrinkRetries Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift) -- | A named collection of property tests. -- data Group = Group { groupName :: !GroupName , groupProperties :: ![(PropertyName, Property)] } -- | The name of a group of properties. -- -- Should be constructed using `OverloadedStrings`: -- -- @ -- "fruit" :: GroupName -- @ -- newtype GroupName = GroupName { unGroupName :: String } deriving (Eq, Ord, Show, IsString, Semigroup, Lift) -- | The number of properties in a group. -- newtype PropertyCount = PropertyCount Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral) data TerminationCriteria = EarlyTermination Confidence TestLimit | NoEarlyTermination Confidence TestLimit | NoConfidenceTermination TestLimit deriving (Eq, Ord, Show, Lift) -- -- FIXME This whole Log/Failure thing could be a lot more structured to allow -- FIXME for richer user controlled error messages, think Doc. Ideally we'd -- FIXME allow user's to crete their own diffs anywhere. -- -- | Log messages which are recorded during a test run. -- data Log = Annotation (Maybe Span) String | Footnote String | Label (Label Cover) deriving (Eq, Show) -- | A record containing the details of a test run. newtype Journal = Journal { journalLogs :: [Log] } deriving (Eq, Show, Semigroup, Monoid) -- | Details on where and why a test failed. -- data Failure = Failure (Maybe Span) String (Maybe Diff) deriving (Eq, Show) -- | The difference between some expected and actual value. -- data Diff = Diff { diffPrefix :: String , diffRemoved :: String , diffInfix :: String , diffAdded :: String , diffSuffix :: String , diffValue :: ValueDiff } deriving (Eq, Show) -- | Whether a test is covered by a classifier, and therefore belongs to a -- 'Class'. -- data Cover = NoCover | Cover deriving (Eq, Ord, Show) -- | The total number of tests which are covered by a classifier. -- -- Can be constructed using numeric literals: -- -- @ -- 30 :: CoverCount -- @ -- newtype CoverCount = CoverCount { unCoverCount :: Int } deriving (Eq, Ord, Show, Num) -- | The relative number of tests which are covered by a classifier. -- -- Can be constructed using numeric literals: -- -- @ -- 30 :: CoverPercentage -- @ -- newtype CoverPercentage = CoverPercentage { unCoverPercentage :: Double } deriving (Eq, Ord, Show, Num, Fractional) -- | The name of a classifier. -- -- Should be constructed using `OverloadedStrings`: -- -- @ -- "apples" :: LabelName -- @ -- newtype LabelName = LabelName { unLabelName :: String } deriving (Eq, Monoid, Ord, Semigroup, Show, IsString) -- | The extent to which a test is covered by a classifier. -- -- /When a classifier's coverage does not exceed the required minimum, the/ -- /test will be failed./ -- data Label a = MkLabel { labelName :: !LabelName , labelLocation :: !(Maybe Span) , labelMinimum :: !CoverPercentage , labelAnnotation :: !a } deriving (Eq, Show, Functor, Foldable, Traversable) -- | The extent to which all classifiers cover a test. -- -- /When a given classification's coverage does not exceed the required/ -- /minimum, the test will be failed./ -- newtype Coverage a = Coverage { coverageLabels :: Map LabelName (Label a) } deriving (Eq, Show, Functor, Foldable, Traversable) ------------------------------------------------------------------------ -- TestT instance Monad m => Monad (TestT m) where return = pure (>>=) m k = TestT $ unTest m >>= unTest . k instance Monad m => MonadFail (TestT m) where fail err = TestT . ExceptT . pure . Left $ Failure Nothing err Nothing instance MonadTrans TestT where lift = TestT . lift . lift instance MFunctor TestT where hoist f = TestT . hoist (hoist f) . unTest instance MonadTransDistributive TestT where type Transformer t TestT m = ( Transformer t (Lazy.WriterT Journal) m , Transformer t (ExceptT Failure) (Lazy.WriterT Journal m) ) distributeT = hoist TestT . distributeT . hoist distributeT . unTest instance PrimMonad m => PrimMonad (TestT m) where type PrimState (TestT m) = PrimState m primitive = lift . primitive -- FIXME instance MonadWriter w m => MonadWriter w (TestT m) instance MonadError e m => MonadError e (TestT m) where throwError = lift . throwError catchError m onErr = TestT . ExceptT $ (runExceptT $ unTest m) `catchError` (runExceptT . unTest . onErr) instance MonadResource m => MonadResource (TestT m) where liftResourceT = lift . liftResourceT instance MonadTransControl TestT where type StT TestT a = (Either Failure a, Journal) liftWith f = mkTestT . fmap (, mempty) . fmap Right $ f $ runTestT restoreT = mkTestT instance MonadBaseControl b m => MonadBaseControl b (TestT m) where type StM (TestT m) a = ComposeSt TestT m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM class Monad m => MonadTest m where liftTest :: Test a -> m a instance Monad m => MonadTest (TestT m) where liftTest = hoist (pure . runIdentity) instance MonadTest m => MonadTest (IdentityT m) where liftTest = lift . liftTest instance MonadTest m => MonadTest (MaybeT m) where liftTest = lift . liftTest instance MonadTest m => MonadTest (ExceptT x m) where liftTest = lift . liftTest instance MonadTest m => MonadTest (ReaderT r m) where liftTest = lift . liftTest instance MonadTest m => MonadTest (Lazy.StateT s m) where liftTest = lift . liftTest instance MonadTest m => MonadTest (Strict.StateT s m) where liftTest = lift . liftTest instance (MonadTest m, Monoid w) => MonadTest (Lazy.WriterT w m) where liftTest = lift . liftTest instance (MonadTest m, Monoid w) => MonadTest (Strict.WriterT w m) where liftTest = lift . liftTest instance (MonadTest m, Monoid w) => MonadTest (Lazy.RWST r w s m) where liftTest = lift . liftTest instance (MonadTest m, Monoid w) => MonadTest (Strict.RWST r w s m) where liftTest = lift . liftTest instance MonadTest m => MonadTest (ContT r m) where liftTest = lift . liftTest instance MonadTest m => MonadTest (ResourceT m) where liftTest = lift . liftTest mkTestT :: m (Either Failure a, Journal) -> TestT m a mkTestT = TestT . ExceptT . Lazy.WriterT mkTest :: (Either Failure a, Journal) -> Test a mkTest = mkTestT . Identity runTestT :: TestT m a -> m (Either Failure a, Journal) runTestT = Lazy.runWriterT . runExceptT . unTest runTest :: Test a -> (Either Failure a, Journal) runTest = runIdentity . runTestT -- | Log some information which might be relevant to a potential test failure. -- writeLog :: MonadTest m => Log -> m () writeLog x = liftTest $ mkTest (pure (), (Journal [x])) -- | Fail the test with an error message, useful for building other failure -- combinators. -- failWith :: (MonadTest m, HasCallStack) => Maybe Diff -> String -> m a failWith mdiff msg = liftTest $ mkTest (Left $ Failure (getCaller callStack) msg mdiff, mempty) -- | Annotates the source code with a message that might be useful for -- debugging a test failure. -- annotate :: (MonadTest m, HasCallStack) => String -> m () annotate x = do writeLog $ Annotation (getCaller callStack) x -- | Annotates the source code with a value that might be useful for -- debugging a test failure. -- annotateShow :: (MonadTest m, Show a, HasCallStack) => a -> m () annotateShow x = do withFrozenCallStack $ annotate (showPretty x) -- | Logs a message to be displayed as additional information in the footer of -- the failure report. -- footnote :: MonadTest m => String -> m () footnote = writeLog . Footnote -- | Logs a value to be displayed as additional information in the footer of -- the failure report. -- footnoteShow :: (MonadTest m, Show a) => a -> m () footnoteShow = writeLog . Footnote . showPretty -- | Fails with an error that shows the difference between two values. failDiff :: (MonadTest m, Show a, Show b, HasCallStack) => a -> b -> m () failDiff x y = case valueDiff <$> mkValue x <*> mkValue y of Nothing -> withFrozenCallStack $ failWith Nothing $ unlines $ [ "Failed" , "━━ lhs ━━" , showPretty x , "━━ rhs ━━" , showPretty y ] Just vdiff@(ValueSame _) -> withFrozenCallStack $ failWith (Just $ Diff "━━━ Failed (" "" "no differences" "" ") ━━━" vdiff) "" Just vdiff -> withFrozenCallStack $ failWith (Just $ Diff "━━━ Failed (" "- lhs" ") (" "+ rhs" ") ━━━" vdiff) "" -- | Fails with an error which renders the type of an exception and its error -- message. -- failException :: (MonadTest m, HasCallStack) => SomeException -> m a failException x = withFrozenCallStack $ failExceptionWith [] x -- | Fails with an error which renders the given messages, the type of an exception, -- and its error message. -- failExceptionWith :: (MonadTest m, HasCallStack) => [String] -> SomeException -> m a failExceptionWith messages (SomeException x) = withFrozenCallStack failWith Nothing $ unlines $ messages <> [ "━━━ Exception (" ++ show (typeOf x) ++ ") ━━━" , List.dropWhileEnd Char.isSpace (displayException x) ] -- | Causes a test to fail. -- failure :: (MonadTest m, HasCallStack) => m a failure = withFrozenCallStack $ failWith Nothing "" -- | Another name for @pure ()@. -- success :: MonadTest m => m () success = pure () -- | Fails the test if the condition provided is 'False'. -- assert :: (MonadTest m, HasCallStack) => Bool -> m () assert b = do ok <- withFrozenCallStack $ eval b if ok then success else withFrozenCallStack failure -- | Fails the test and shows a git-like diff if the comparison operation -- evaluates to 'False' when applied to its arguments. -- -- The comparison function is the second argument, which may be -- counter-intuitive to Haskell programmers. However, it allows operators to -- be written infix for easy reading: -- -- @ -- diff y (<) 87 -- diff x (<=) 'r' -- @ -- -- /This function behaves like the unix `diff` tool, which gives a `0` exit/ -- /code if the compared files are identical, or a `1` exit code code/ -- /otherwise. Like unix `diff`, if the arguments fail the comparison, a diff/ -- /is shown./ -- diff :: (MonadTest m, Show a, Show b, HasCallStack) => a -> (a -> b -> Bool) -> b -> m () diff x op y = do ok <- withFrozenCallStack $ eval (x `op` y) if ok then success else withFrozenCallStack $ failDiff x y infix 4 === -- | Fails the test if the two arguments provided are not equal. -- (===) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m () (===) x y = withFrozenCallStack $ diff x (==) y infix 4 /== -- | Fails the test if the two arguments provided are equal. -- (/==) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m () (/==) x y = withFrozenCallStack $ diff x (/=) y -- | Fails the test if the value throws an exception when evaluated to weak -- head normal form (WHNF). -- eval :: (MonadTest m, HasCallStack) => a -> m a eval x = either (withFrozenCallStack failException) pure (tryEvaluate x) -- | Fails the test if the value throws an exception when evaluated to -- normal form (NF). -- evalNF :: (MonadTest m, NFData a, HasCallStack) => a -> m a evalNF x = let messages = ["━━━ Value could not be evaluated to normal form ━━━"] in either (withFrozenCallStack (failExceptionWith messages)) pure (tryEvaluate (rnf x)) $> x -- | Fails the test if the action throws an exception. -- -- /The benefit of using this over simply letting the exception bubble up is/ -- /that the location of the closest 'evalM' will be shown in the output./ -- evalM :: (MonadTest m, MonadCatch m, HasCallStack) => m a -> m a evalM m = either (withFrozenCallStack failException) pure =<< tryAll m -- | Fails the test if the 'IO' action throws an exception. -- -- /The benefit of using this over 'liftIO' is that the location of the/ -- /exception will be shown in the output./ -- evalIO :: (MonadTest m, MonadIO m, HasCallStack) => IO a -> m a evalIO m = either (withFrozenCallStack failException) pure =<< liftIO (tryAll m) -- | Fails the test if the 'Either' is 'Left', otherwise returns the value in -- the 'Right'. -- evalEither :: (MonadTest m, Show x, HasCallStack) => Either x a -> m a evalEither = \case Left x -> withFrozenCallStack $ failWith Nothing $ showPretty x Right x -> pure x -- | Fails the test if the 'ExceptT' is 'Left', otherwise returns the value in -- the 'Right'. -- evalExceptT :: (MonadTest m, Show x, HasCallStack) => ExceptT x m a -> m a evalExceptT m = withFrozenCallStack evalEither =<< runExceptT m ------------------------------------------------------------------------ -- PropertyT instance MonadTrans PropertyT where lift = PropertyT . lift . lift instance Monad m => MonadFail (PropertyT m) where fail err = PropertyT (Fail.fail err) instance MFunctor PropertyT where hoist f = PropertyT . hoist (hoist f) . unPropertyT instance MonadTransDistributive PropertyT where type Transformer t PropertyT m = ( Transformer t GenT m , Transformer t TestT (GenT m) ) distributeT = hoist PropertyT . distributeT . hoist distributeT . unPropertyT instance PrimMonad m => PrimMonad (PropertyT m) where type PrimState (PropertyT m) = PrimState m primitive = lift . primitive ---- FIXME instance MonadWriter w m => MonadWriter w (PropertyT m) instance Monad m => MonadTest (PropertyT m) where liftTest = PropertyT . hoist (pure . runIdentity) instance MonadPlus m => MonadPlus (PropertyT m) where mzero = discard mplus (PropertyT x) (PropertyT y) = PropertyT . mkTestT $ mplus (runTestT x) (runTestT y) instance MonadPlus m => Alternative (PropertyT m) where empty = mzero (<|>) = mplus -- | Generates a random input for the test by running the provided generator. -- -- /This is a the same as 'forAllT' but allows the user to provide a custom/ -- /rendering function. This is useful for values which don't have a/ -- /'Show' instance./ -- forAllWithT :: (Monad m, HasCallStack) => (a -> String) -> GenT m a -> PropertyT m a forAllWithT render gen = do x <- PropertyT $ lift gen withFrozenCallStack $ annotate (render x) return x -- | Generates a random input for the test by running the provided generator. -- -- /This is a the same as 'forAll' but allows the user to provide a custom/ -- /rendering function. This is useful for values which don't have a/ -- /'Show' instance./ -- forAllWith :: (Monad m, HasCallStack) => (a -> String) -> Gen a -> PropertyT m a forAllWith render gen = withFrozenCallStack $ forAllWithT render $ Gen.generalize gen -- | Generates a random input for the test by running the provided generator. -- -- forAllT :: (Monad m, Show a, HasCallStack) => GenT m a -> PropertyT m a forAllT gen = withFrozenCallStack $ forAllWithT showPretty gen -- | Generates a random input for the test by running the provided generator. -- forAll :: (Monad m, Show a, HasCallStack) => Gen a -> PropertyT m a forAll gen = withFrozenCallStack $ forAllWith showPretty gen -- | Discards the current test entirely. -- discard :: Monad m => PropertyT m a discard = PropertyT $ lift (Gen.generalize Gen.discard) -- | Lift a test in to a property. -- -- Because both 'TestT' and 'PropertyT' have 'MonadTest' instances, this -- function is not often required. It can however be useful for writing -- functions directly in 'TestT' and thus gaining a 'MonadTransControl' -- instance at the expense of not being able to generate additional inputs -- using 'forAll'. -- -- An example where this is useful is parallel state machine testing, as -- 'Hedgehog.Internal.State.executeParallel' requires 'MonadBaseControl' 'IO' -- in order to be able to spawn threads in 'MonadTest'. -- test :: Monad m => TestT m a -> PropertyT m a test = PropertyT . hoist lift ------------------------------------------------------------------------ -- Property -- | The default configuration for a property test. -- defaultConfig :: PropertyConfig defaultConfig = PropertyConfig { propertyDiscardLimit = 100 , propertyShrinkLimit = 1000 , propertyShrinkRetries = 0 , propertyTerminationCriteria = NoConfidenceTermination defaultMinTests } -- | The minimum amount of tests to run for a 'Property' -- defaultMinTests :: TestLimit defaultMinTests = 100 -- | The default confidence allows one false positive in 10^9 tests -- defaultConfidence :: Confidence defaultConfidence = 10 ^ (9 :: Int) -- | Map a config modification function over a property. -- mapConfig :: (PropertyConfig -> PropertyConfig) -> Property -> Property mapConfig f (Property cfg t) = Property (f cfg) t -- | Make sure that the result is statistically significant in accordance to -- the passed 'Confidence' -- withConfidence :: Confidence -> Property -> Property withConfidence c = let setConfidence = \case NoEarlyTermination _ tests -> NoEarlyTermination c tests NoConfidenceTermination tests -> NoEarlyTermination c tests EarlyTermination _ tests -> EarlyTermination c tests in mapConfig $ \config@PropertyConfig{..} -> config { propertyTerminationCriteria = setConfidence propertyTerminationCriteria } verifiedTermination :: Property -> Property verifiedTermination = mapConfig $ \config@PropertyConfig{..} -> let newTerminationCriteria = case propertyTerminationCriteria of NoEarlyTermination c tests -> EarlyTermination c tests NoConfidenceTermination tests -> EarlyTermination defaultConfidence tests EarlyTermination c tests -> EarlyTermination c tests in config { propertyTerminationCriteria = newTerminationCriteria } -- | Set the number of times a property should be executed before it is considered -- successful. -- -- If you have a test that does not involve any generators and thus does not -- need to run repeatedly, you can use @withTests 1@ to define a property that -- will only be checked once. -- withTests :: TestLimit -> Property -> Property withTests n = let setTestLimit tests = \case NoEarlyTermination c _ -> NoEarlyTermination c tests NoConfidenceTermination _ -> NoConfidenceTermination tests EarlyTermination c _ -> EarlyTermination c tests in mapConfig $ \config@PropertyConfig{..} -> config { propertyTerminationCriteria = setTestLimit n propertyTerminationCriteria } -- | Set the number of times a property is allowed to discard before the test -- runner gives up. -- withDiscards :: DiscardLimit -> Property -> Property withDiscards n = mapConfig $ \config -> config { propertyDiscardLimit = n } -- | Set the number of times a property is allowed to shrink before the test -- runner gives up and prints the counterexample. -- withShrinks :: ShrinkLimit -> Property -> Property withShrinks n = mapConfig $ \config -> config { propertyShrinkLimit = n } -- | Set the number of times a property will be executed for each shrink before -- the test runner gives up and tries a different shrink. See 'ShrinkRetries' -- for more information. -- withRetries :: ShrinkRetries -> Property -> Property withRetries n = mapConfig $ \config -> config { propertyShrinkRetries = n } -- | Creates a property with the default configuration. -- property :: HasCallStack => PropertyT IO () -> Property property m = Property defaultConfig $ withFrozenCallStack (evalM m) ------------------------------------------------------------------------ -- Coverage instance Semigroup Cover where (<>) NoCover NoCover = NoCover (<>) _ _ = Cover instance Monoid Cover where mempty = NoCover mappend = (<>) instance Semigroup CoverCount where (<>) (CoverCount n0) (CoverCount n1) = CoverCount (n0 + n1) instance Monoid CoverCount where mempty = CoverCount 0 mappend = (<>) toCoverCount :: Cover -> CoverCount toCoverCount = \case NoCover -> CoverCount 0 Cover -> CoverCount 1 -- | This semigroup is right biased. The name, location and percentage from the -- rightmost `Label` will be kept. This shouldn't be a problem since the -- library doesn't allow setting multiple classes with the same 'ClassifierName'. instance Semigroup a => Semigroup (Label a) where (<>) (MkLabel _ _ _ m0) (MkLabel name location percentage m1) = MkLabel name location percentage (m0 <> m1) instance Semigroup a => Semigroup (Coverage a) where (<>) (Coverage c0) (Coverage c1) = Coverage $ Map.foldrWithKey (Map.insertWith (<>)) c0 c1 instance (Semigroup a, Monoid a) => Monoid (Coverage a) where mempty = Coverage mempty mappend = (<>) coverPercentage :: TestCount -> CoverCount -> CoverPercentage coverPercentage (TestCount tests) (CoverCount count) = let percentage :: Double percentage = fromIntegral count / fromIntegral tests * 100 thousandths :: Int thousandths = round $ percentage * 10 in CoverPercentage (fromIntegral thousandths / 10) labelCovered :: TestCount -> Label CoverCount -> Bool labelCovered tests (MkLabel _ _ minimum_ population) = coverPercentage tests population >= minimum_ -- | All labels are covered coverageSuccess :: TestCount -> Coverage CoverCount -> Bool coverageSuccess tests = null . coverageFailures tests coverageFailures :: TestCount -> Coverage CoverCount -> [Label CoverCount] coverageFailures tests (Coverage kvs) = List.filter (not . labelCovered tests) (Map.elems kvs) -- | Is true when the test coverage satisfies the specified 'Confidence' -- contstraint for all 'Coverage CoverCount's confidenceSuccess :: TestCount -> Confidence -> Coverage CoverCount -> Bool confidenceSuccess tests confidence = let assertLow :: Label CoverCount -> Bool assertLow coverCount@MkLabel{..} = fst (boundsForLabel tests confidence coverCount) >= unCoverPercentage labelMinimum / 100.0 in and . fmap assertLow . Map.elems . coverageLabels -- | Is true when there exists a label that is sure to have failed according to -- the 'Confidence' constraint confidenceFailure :: TestCount -> Confidence -> Coverage CoverCount -> Bool confidenceFailure tests confidence = let assertHigh :: Label CoverCount -> Bool assertHigh coverCount@MkLabel{..} = snd (boundsForLabel tests confidence coverCount) < (unCoverPercentage labelMinimum / 100.0) in or . fmap assertHigh . Map.elems . coverageLabels boundsForLabel :: TestCount -> Confidence -> Label CoverCount -> (Double, Double) boundsForLabel tests confidence MkLabel{..} = wilsonBounds (fromIntegral $ unCoverCount labelAnnotation) (fromIntegral tests) (1 / fromIntegral (unConfidence confidence)) -- In order to get an accurate measurement with small sample sizes, we're -- using the Wilson score interval -- () instead of a normal approximation interval. wilsonBounds :: Integer -> Integer -> Double -> (Double, Double) wilsonBounds positives count acceptance = let p = fromRational $ positives % count n = fromIntegral count z = invnormcdf $ 1 - acceptance / 2 midpoint = p + z * z / (2 * n) offset = z / (1 + z ** 2 / n) * sqrt (p * (1 - p) / n + z ** 2 / (4 * n ** 2)) denominator = 1 + z * z / n low = (midpoint - offset) / denominator high = (midpoint + offset) / denominator in (low, high) fromLabel :: Label a -> Coverage a fromLabel x = Coverage $ Map.singleton (labelName x) x unionsCoverage :: Semigroup a => [Coverage a] -> Coverage a unionsCoverage = Coverage . Map.unionsWith (<>) . fmap coverageLabels journalCoverage :: Journal -> Coverage CoverCount journalCoverage (Journal logs) = fmap toCoverCount . unionsCoverage $ do Label x <- logs pure (fromLabel x) -- | Require a certain percentage of the tests to be covered by the -- classifier. -- -- @ -- prop_with_coverage :: Property -- prop_with_coverage = -- property $ do -- match <- forAll Gen.bool -- cover 30 "True" $ match -- cover 30 "False" $ not match -- @ -- -- The example above requires a minimum of 30% coverage for both -- classifiers. If these requirements are not met, it will fail the test. -- cover :: (MonadTest m, HasCallStack) => CoverPercentage -> LabelName -> Bool -> m () cover minimum_ name covered = let cover_ = if covered then Cover else NoCover in writeLog . Label $ MkLabel name (getCaller callStack) minimum_ cover_ -- | Records the proportion of tests which satisfy a given condition. -- -- @ -- prop_with_classifier :: Property -- prop_with_classifier = -- property $ do -- xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha -- for_ xs $ \\x -> do -- classify "newborns" $ x == 0 -- classify "children" $ x > 0 && x < 13 -- classify "teens" $ x > 12 && x < 20 -- @ classify :: (MonadTest m, HasCallStack) => LabelName -> Bool -> m () classify name covered = withFrozenCallStack $ cover 0 name covered -- | Add a label for each test run. It produces a table showing the percentage -- of test runs that produced each label. -- label :: (MonadTest m, HasCallStack) => LabelName -> m () label name = withFrozenCallStack $ cover 0 name True -- | Like 'label', but uses 'Show' to render its argument for display. -- collect :: (MonadTest m, Show a, HasCallStack) => a -> m () collect x = withFrozenCallStack $ cover 0 (LabelName (show x)) True ------------------------------------------------------------------------ -- Internal -- $internal -- -- These functions are exported in case you need them in a pinch, but are not -- part of the public API and may change at any time, even as part of a minor -- update. hedgehog-1.0.3/src/Hedgehog/Internal/Queue.hs0000644060175106010010000000566513675330725020237 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} module Hedgehog.Internal.Queue ( TaskIndex(..) , TasksRemaining(..) , runTasks , finalizeTask , runActiveFinalizers , dequeueMVar , updateNumCapabilities ) where import Control.Concurrent (rtsSupportsBoundThreads) import Control.Concurrent.Async (forConcurrently) import Control.Concurrent.MVar (MVar) import qualified Control.Concurrent.MVar as MVar import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified GHC.Conc as Conc import Hedgehog.Internal.Config newtype TaskIndex = TaskIndex Int deriving (Eq, Ord, Enum, Num) newtype TasksRemaining = TasksRemaining Int dequeueMVar :: MVar [(TaskIndex, a)] -> (TasksRemaining -> TaskIndex -> a -> IO b) -> IO (Maybe (TaskIndex, b)) dequeueMVar mvar start = MVar.modifyMVar mvar $ \case [] -> pure ([], Nothing) (ix, x) : xs -> do y <- start (TasksRemaining $ length xs) ix x pure (xs, Just (ix, y)) runTasks :: WorkerCount -> [a] -> (TasksRemaining -> TaskIndex -> a -> IO b) -> (b -> IO ()) -> (b -> IO ()) -> (b -> IO c) -> IO [c] runTasks n tasks start finish finalize runTask = do qvar <- MVar.newMVar (zip [0..] tasks) fvar <- MVar.newMVar (-1, Map.empty) let worker rs = do mx <- dequeueMVar qvar start case mx of Nothing -> pure rs Just (ix, x) -> do r <- runTask x finish x finalizeTask fvar ix (finalize x) worker (r : rs) -- FIXME ensure all workers have finished running fmap concat . forConcurrently [1..max 1 n] $ \_ix -> worker [] runActiveFinalizers :: MonadIO m => MVar (TaskIndex, Map TaskIndex (IO ())) -> m () runActiveFinalizers mvar = liftIO $ do again <- MVar.modifyMVar mvar $ \original@(minIx, finalizers0) -> case Map.minViewWithKey finalizers0 of Nothing -> pure (original, False) Just ((ix, finalize), finalizers) -> if ix == minIx + 1 then do finalize pure ((ix, finalizers), True) else pure (original, False) when again $ runActiveFinalizers mvar finalizeTask :: MonadIO m => MVar (TaskIndex, Map TaskIndex (IO ())) -> TaskIndex -> IO () -> m () finalizeTask mvar ix finalize = do liftIO . MVar.modifyMVar_ mvar $ \(minIx, finalizers) -> pure (minIx, Map.insert ix finalize finalizers) runActiveFinalizers mvar -- | Update the number of capabilities but never set it lower than it already -- is. -- updateNumCapabilities :: WorkerCount -> IO () updateNumCapabilities (WorkerCount n) = when rtsSupportsBoundThreads $ do ncaps <- Conc.getNumCapabilities Conc.setNumCapabilities (max n ncaps) hedgehog-1.0.3/src/Hedgehog/Internal/Range.hs0000644060175106010010000002610513675330725020177 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hedgehog.Internal.Range ( -- * Size Size(..) -- * Range , Range(..) , origin , bounds , lowerBound , upperBound -- * Constant , singleton , constant , constantFrom , constantBounded -- * Linear , linear , linearFrom , linearFrac , linearFracFrom , linearBounded -- * Exponential , exponential , exponentialFrom , exponentialBounded , exponentialFloat , exponentialFloatFrom -- * Internal -- $internal , clamp , scaleLinear , scaleLinearFrac , scaleExponential , scaleExponentialFloat ) where import Data.Bifunctor (bimap) import Prelude hiding (minimum, maximum) -- $setup -- >>> import Data.Int (Int8) -- >>> let x = 3 -- | Tests are parameterized by the size of the randomly-generated data. The -- meaning of a 'Size' value depends on the particular generator used, but -- it must always be a number between 0 and 99 inclusive. -- newtype Size = Size { unSize :: Int } deriving (Eq, Ord, Num, Real, Enum, Integral) instance Show Size where showsPrec p (Size x) = showParen (p > 10) $ showString "Size " . showsPrec 11 x instance Read Size where readsPrec p = readParen (p > 10) $ \r0 -> do ("Size", r1) <- lex r0 (s, r2) <- readsPrec 11 r1 pure (Size s, r2) -- | A range describes the bounds of a number to generate, which may or may not -- be dependent on a 'Size'. -- -- The constructor takes an origin between the lower and upper bound, and a -- function from 'Size' to bounds. As the size goes towards @0@, the values -- go towards the origin. -- data Range a = Range !a (Size -> (a, a)) instance Functor Range where fmap f (Range z g) = Range (f z) $ \sz -> bimap f f (g sz) -- | Get the origin of a range. This might be the mid-point or the lower bound, -- depending on what the range represents. -- -- The 'bounds' of a range are scaled around this value when using the -- 'linear' family of combinators. -- -- When using a 'Range' to generate numbers, the shrinking function will -- shrink towards the origin. -- origin :: Range a -> a origin (Range z _) = z -- | Get the extents of a range, for a given size. -- bounds :: Size -> Range a -> (a, a) bounds sz (Range _ f) = f sz -- | Get the lower bound of a range for the given size. -- lowerBound :: Ord a => Size -> Range a -> a lowerBound sz range = let (x, y) = bounds sz range in min x y -- | Get the upper bound of a range for the given size. -- upperBound :: Ord a => Size -> Range a -> a upperBound sz range = let (x, y) = bounds sz range in max x y -- | Construct a range which represents a constant single value. -- -- >>> bounds x $ singleton 5 -- (5,5) -- -- >>> origin $ singleton 5 -- 5 -- singleton :: a -> Range a singleton x = Range x $ \_ -> (x, x) -- | Construct a range which is unaffected by the size parameter. -- -- A range from @0@ to @10@, with the origin at @0@: -- -- >>> bounds x $ constant 0 10 -- (0,10) -- -- >>> origin $ constant 0 10 -- 0 -- constant :: a -> a -> Range a constant x y = constantFrom x x y -- | Construct a range which is unaffected by the size parameter with a origin -- point which may differ from the bounds. -- -- A range from @-10@ to @10@, with the origin at @0@: -- -- >>> bounds x $ constantFrom 0 (-10) 10 -- (-10,10) -- -- >>> origin $ constantFrom 0 (-10) 10 -- 0 -- -- A range from @1970@ to @2100@, with the origin at @2000@: -- -- >>> bounds x $ constantFrom 2000 1970 2100 -- (1970,2100) -- -- >>> origin $ constantFrom 2000 1970 2100 -- 2000 -- constantFrom :: a -- ^ Origin (the value produced when the size parameter is 0). -> a -- ^ Lower bound (the bottom of the range when the size parameter is 99). -> a -- ^ Upper bound (the top of the range when the size parameter is 99). -> Range a constantFrom z x y = Range z $ \_ -> (x, y) -- | Construct a range which is unaffected by the size parameter using the full -- range of a data type. -- -- A range from @-128@ to @127@, with the origin at @0@: -- -- >>> bounds x (constantBounded :: Range Int8) -- (-128,127) -- -- >>> origin (constantBounded :: Range Int8) -- 0 -- constantBounded :: (Bounded a, Num a) => Range a constantBounded = constantFrom 0 minBound maxBound -- | Construct a range which scales the second bound relative to the size -- parameter. -- -- >>> bounds 0 $ linear 0 10 -- (0,0) -- -- >>> bounds 50 $ linear 0 10 -- (0,5) -- -- >>> bounds 99 $ linear 0 10 -- (0,10) -- linear :: Integral a => a -> a -> Range a linear x y = linearFrom x x y -- | Construct a range which scales the bounds relative to the size parameter. -- -- >>> bounds 0 $ linearFrom 0 (-10) 10 -- (0,0) -- -- >>> bounds 50 $ linearFrom 0 (-10) 20 -- (-5,10) -- -- >>> bounds 99 $ linearFrom 0 (-10) 20 -- (-10,20) -- linearFrom :: Integral a => a -- ^ Origin (the value produced when the size parameter is 0). -> a -- ^ Lower bound (the bottom of the range when the size parameter is 99). -> a -- ^ Upper bound (the top of the range when the size parameter is 99). -> Range a linearFrom z x y = Range z $ \sz -> let x_sized = clamp x y $ scaleLinear sz z x y_sized = clamp x y $ scaleLinear sz z y in (x_sized, y_sized) -- | Construct a range which is scaled relative to the size parameter and uses -- the full range of a data type. -- -- >>> bounds 0 (linearBounded :: Range Int8) -- (0,0) -- -- >>> bounds 50 (linearBounded :: Range Int8) -- (-64,64) -- -- >>> bounds 99 (linearBounded :: Range Int8) -- (-128,127) -- linearBounded :: (Bounded a, Integral a) => Range a linearBounded = linearFrom 0 minBound maxBound -- | Construct a range which scales the second bound relative to the size -- parameter. -- -- /This works the same as 'linear', but for fractional values./ -- linearFrac :: (Fractional a, Ord a) => a -> a -> Range a linearFrac x y = linearFracFrom x x y -- | Construct a range which scales the bounds relative to the size parameter. -- -- /This works the same as 'linearFrom', but for fractional values./ -- linearFracFrom :: (Fractional a, Ord a) => a -> a -> a -> Range a linearFracFrom z x y = Range z $ \sz -> let x_sized = clamp x y $ scaleLinearFrac sz z x y_sized = clamp x y $ scaleLinearFrac sz z y in (x_sized, y_sized) -- | Truncate a value so it stays within some range. -- -- >>> clamp 5 10 15 -- 10 -- -- >>> clamp 5 10 0 -- 5 -- clamp :: Ord a => a -> a -> a -> a clamp x y n = if x > y then min x (max y n) else min y (max x n) -- | Scale an integral linearly with the size parameter. -- scaleLinear :: Integral a => Size -> a -> a -> a scaleLinear sz0 z0 n0 = let sz = max 0 (min 99 sz0) z = toInteger z0 n = toInteger n0 diff = ((n - z) * fromIntegral sz) `quot` 99 in fromInteger $ z + diff -- | Scale a fractional number linearly with the size parameter. -- scaleLinearFrac :: Fractional a => Size -> a -> a -> a scaleLinearFrac sz0 z n = let sz = max 0 (min 99 sz0) diff = (n - z) * (fromIntegral sz / 99) in z + diff -- | Construct a range which scales the second bound exponentially relative to -- the size parameter. -- -- >>> bounds 0 $ exponential 1 512 -- (1,1) -- -- >>> bounds 11 $ exponential 1 512 -- (1,2) -- -- >>> bounds 22 $ exponential 1 512 -- (1,4) -- -- >>> bounds 77 $ exponential 1 512 -- (1,128) -- -- >>> bounds 88 $ exponential 1 512 -- (1,256) -- -- >>> bounds 99 $ exponential 1 512 -- (1,512) -- exponential :: Integral a => a -> a -> Range a exponential x y = exponentialFrom x x y -- | Construct a range which scales the bounds exponentially relative to the -- size parameter. -- -- >>> bounds 0 $ exponentialFrom 0 (-128) 512 -- (0,0) -- -- >>> bounds 25 $ exponentialFrom 0 (-128) 512 -- (-2,4) -- -- >>> bounds 50 $ exponentialFrom 0 (-128) 512 -- (-11,22) -- -- >>> bounds 75 $ exponentialFrom 0 (-128) 512 -- (-39,112) -- -- >>> bounds 99 $ exponentialFrom x (-128) 512 -- (-128,512) -- exponentialFrom :: Integral a => a -- ^ Origin (the value produced when the size parameter is 0). -> a -- ^ Lower bound (the bottom of the range when the size parameter is 99). -> a -- ^ Upper bound (the top of the range when the size parameter is 99). -> Range a exponentialFrom z x y = Range z $ \sz -> let sized_x = clamp x y $ scaleExponential sz z x sized_y = clamp x y $ scaleExponential sz z y in (sized_x, sized_y) -- | Construct a range which is scaled exponentially relative to the size -- parameter and uses the full range of a data type. -- -- >>> bounds 0 (exponentialBounded :: Range Int8) -- (0,0) -- -- >>> bounds 50 (exponentialBounded :: Range Int8) -- (-11,11) -- -- >>> bounds 99 (exponentialBounded :: Range Int8) -- (-128,127) -- exponentialBounded :: (Bounded a, Integral a) => Range a exponentialBounded = exponentialFrom 0 minBound maxBound -- | Construct a range which scales the second bound exponentially relative to -- the size parameter. -- -- /This works the same as 'exponential', but for floating-point values./ -- -- >>> bounds 0 $ exponentialFloat 0 10 -- (0.0,0.0) -- -- >>> bounds 50 $ exponentialFloat 0 10 -- (0.0,2.357035250656098) -- -- >>> bounds 99 $ exponentialFloat 0 10 -- (0.0,10.0) -- exponentialFloat :: (Floating a, Ord a) => a -> a -> Range a exponentialFloat x y = exponentialFloatFrom x x y -- | Construct a range which scales the bounds exponentially relative to the -- size parameter. -- -- /This works the same as 'exponentialFrom', but for floating-point values./ -- -- >>> bounds 0 $ exponentialFloatFrom 0 (-10) 20 -- (0.0,0.0) -- -- >>> bounds 50 $ exponentialFloatFrom 0 (-10) 20 -- (-2.357035250656098,3.6535836249197002) -- -- >>> bounds 99 $ exponentialFloatFrom x (-10) 20 -- (-10.0,20.0) -- exponentialFloatFrom :: (Floating a, Ord a) => a -> a -> a -> Range a exponentialFloatFrom z x y = Range z $ \sz -> let sized_x = clamp x y $ scaleExponentialFloat sz z x sized_y = clamp x y $ scaleExponentialFloat sz z y in (sized_x, sized_y) -- | Scale an integral exponentially with the size parameter. -- scaleExponential :: Integral a => Size -> a -> a -> a scaleExponential sz z0 n0 = let z = fromIntegral z0 n = fromIntegral n0 in round (scaleExponentialFloat sz z n :: Double) -- | Scale a floating-point number exponentially with the size parameter. -- scaleExponentialFloat :: Floating a => Size -> a -> a -> a scaleExponentialFloat sz0 z n = let sz = clamp 0 99 sz0 diff = (((abs (n - z) + 1) ** (realToFrac sz / 99)) - 1) * signum (n - z) in z + diff ------------------------------------------------------------------------ -- Internal -- $internal -- -- These functions are exported in case you need them in a pinch, but are not -- part of the public API and may change at any time, even as part of a minor -- update. hedgehog-1.0.3/src/Hedgehog/Internal/Region.hs0000644060175106010010000000562113675330725020366 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} module Hedgehog.Internal.Region ( Region(..) , newEmptyRegion , newOpenRegion , openRegion , setRegion , displayRegions , displayRegion , moveToBottom , finishRegion ) where 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.Monad.IO.Class (MonadIO(..)) import System.Console.Regions (ConsoleRegion, RegionLayout(..), LiftRegion(..)) import qualified System.Console.Regions as Console data Body = Empty | Open ConsoleRegion | Closed newtype Region = Region { unRegion :: TVar Body } newEmptyRegion :: LiftRegion m => m Region newEmptyRegion = liftRegion $ do ref <- TVar.newTVar Empty pure $ Region ref newOpenRegion :: LiftRegion m => m Region newOpenRegion = liftRegion $ do region <- Console.openConsoleRegion Linear ref <- TVar.newTVar $ Open region pure $ Region ref openRegion :: LiftRegion m => Region -> String -> m () openRegion (Region var) content = liftRegion $ do body <- TVar.readTVar var case body of Empty -> do region <- Console.openConsoleRegion Linear TVar.writeTVar var $ Open region Console.setConsoleRegion region content Open region -> Console.setConsoleRegion region content Closed -> pure () setRegion :: LiftRegion m => Region -> String -> m () setRegion (Region var) content = liftRegion $ do body <- TVar.readTVar var case body of Empty -> pure () Open region -> Console.setConsoleRegion region content Closed -> pure () displayRegions :: (MonadIO m, MonadMask m) => m a -> m a displayRegions io = Console.displayConsoleRegions io displayRegion :: MonadIO m => MonadMask m => LiftRegion m => (Region -> m a) -> m a displayRegion = displayRegions . bracket newOpenRegion finishRegion moveToBottom :: Region -> STM () moveToBottom (Region var) = liftRegion $ do body <- TVar.readTVar var case body of Empty -> pure () Open region -> do mxs <- TMVar.tryTakeTMVar Console.regionList case mxs of Nothing -> pure () Just xs0 -> let xs1 = filter (/= region) xs0 in TMVar.putTMVar Console.regionList (region : xs1) Closed -> pure () finishRegion :: LiftRegion m => Region -> m () finishRegion (Region var) = liftRegion $ do body <- TVar.readTVar var case body of Empty -> do TVar.writeTVar var Closed Open region -> do content <- Console.getConsoleRegion region Console.finishConsoleRegion region content TVar.writeTVar var Closed Closed -> pure () hedgehog-1.0.3/src/Hedgehog/Internal/Report.hs0000644060175106010010000007454213675330725020426 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} module Hedgehog.Internal.Report ( -- * Report Summary(..) , Report(..) , Progress(..) , Result(..) , FailureReport(..) , FailedAnnotation(..) , Style(..) , Markup(..) , renderProgress , renderResult , renderSummary , renderDoc , ppProgress , ppResult , ppSummary , fromResult , mkFailure ) where import Control.Monad (zipWithM) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) import Data.Bifunctor (bimap, first, second) import qualified Data.Char as Char import Data.Either (partitionEithers) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (mapMaybe, catMaybes) import Data.Traversable (for) import Hedgehog.Internal.Config import Hedgehog.Internal.Discovery (Pos(..), Position(..)) import qualified Hedgehog.Internal.Discovery as Discovery import Hedgehog.Internal.Prelude import Hedgehog.Internal.Property (CoverCount(..), CoverPercentage(..)) import Hedgehog.Internal.Property (Coverage(..), Label(..), LabelName(..)) import Hedgehog.Internal.Property (PropertyName(..), Log(..), Diff(..)) import Hedgehog.Internal.Property (ShrinkCount(..), PropertyCount(..)) import Hedgehog.Internal.Property (TestCount(..), DiscardCount(..)) import Hedgehog.Internal.Property (coverPercentage, coverageFailures) import Hedgehog.Internal.Property (labelCovered) import Hedgehog.Internal.Seed (Seed) import Hedgehog.Internal.Show import Hedgehog.Internal.Source import Hedgehog.Range (Size) import System.Console.ANSI (ColorIntensity(..), Color(..)) import System.Console.ANSI (ConsoleLayer(..), ConsoleIntensity(..)) import System.Console.ANSI (SGR(..), setSGRCode) import System.Directory (makeRelativeToCurrentDirectory) #if mingw32_HOST_OS import System.IO (hSetEncoding, stdout, stderr, utf8) #endif import Text.PrettyPrint.Annotated.WL (Doc, (<#>), (<+>)) import qualified Text.PrettyPrint.Annotated.WL as WL import Text.Printf (printf) ------------------------------------------------------------------------ -- Data data FailedAnnotation = FailedAnnotation { failedSpan :: !(Maybe Span) , failedValue :: !String } deriving (Eq, Show) data FailureReport = FailureReport { failureSize :: !Size , failureSeed :: !Seed , failureShrinks :: !ShrinkCount , failureCoverage :: !(Maybe (Coverage CoverCount)) , failureAnnotations :: ![FailedAnnotation] , failureLocation :: !(Maybe Span) , failureMessage :: !String , failureDiff :: !(Maybe Diff) , failureFootnotes :: ![String] } deriving (Eq, Show) -- | The status of a running property test. -- data Progress = Running | Shrinking !FailureReport deriving (Eq, Show) -- | The status of a completed property test. -- -- In the case of a failure it provides the seed used for the test, the -- number of shrinks, and the execution log. -- data Result = Failed !FailureReport | GaveUp | OK deriving (Eq, Show) -- | A report on a running or completed property test. -- data Report a = Report { reportTests :: !TestCount , reportDiscards :: !DiscardCount , reportCoverage :: !(Coverage CoverCount) , reportStatus :: !a } deriving (Show, Functor, Foldable, Traversable) -- | A summary of all the properties executed. -- data Summary = Summary { summaryWaiting :: !PropertyCount , summaryRunning :: !PropertyCount , summaryFailed :: !PropertyCount , summaryGaveUp :: !PropertyCount , summaryOK :: !PropertyCount } deriving (Show) instance Monoid Summary where mempty = Summary 0 0 0 0 0 mappend (Summary x1 x2 x3 x4 x5) (Summary y1 y2 y3 y4 y5) = Summary (x1 + y1) (x2 + y2) (x3 + y3) (x4 + y4) (x5 + y5) instance Semigroup Summary where (<>) = mappend -- | Construct a summary from a single result. -- fromResult :: Result -> Summary fromResult = \case Failed _ -> mempty { summaryFailed = 1 } GaveUp -> mempty { summaryGaveUp = 1 } OK -> mempty { summaryOK = 1 } summaryCompleted :: Summary -> PropertyCount summaryCompleted (Summary _ _ x3 x4 x5) = x3 + x4 + x5 summaryTotal :: Summary -> PropertyCount summaryTotal (Summary x1 x2 x3 x4 x5) = x1 + x2 + x3 + x4 + x5 ------------------------------------------------------------------------ -- Pretty Printing Helpers data Line a = Line { _lineAnnotation :: !a , lineNumber :: !LineNo , _lineSource :: !String } deriving (Eq, Ord, Show, Functor) data Declaration a = Declaration { declarationFile :: !FilePath , declarationLine :: !LineNo , _declarationName :: !String , declarationSource :: !(Map LineNo (Line a)) } deriving (Eq, Ord, Show, Functor) data Style = StyleDefault | StyleAnnotation | StyleFailure deriving (Eq, Ord, Show) data Markup = WaitingIcon | WaitingHeader | RunningIcon | RunningHeader | ShrinkingIcon | ShrinkingHeader | FailedIcon | FailedText | GaveUpIcon | GaveUpText | SuccessIcon | SuccessText | CoverageIcon | CoverageText | CoverageFill | DeclarationLocation | StyledLineNo !Style | StyledBorder !Style | StyledSource !Style | AnnotationGutter | AnnotationValue | FailureArrows | FailureGutter | FailureMessage | DiffPrefix | DiffInfix | DiffSuffix | DiffSame | DiffRemoved | DiffAdded | ReproduceHeader | ReproduceGutter | ReproduceSource deriving (Eq, Ord, Show) instance Semigroup Style where (<>) x y = case (x, y) of (StyleFailure, _) -> StyleFailure (_, StyleFailure) -> StyleFailure (StyleAnnotation, _) -> StyleAnnotation (_, StyleAnnotation) -> StyleAnnotation (StyleDefault, _) -> StyleDefault ------------------------------------------------------------------------ takeAnnotation :: Log -> Maybe FailedAnnotation takeAnnotation = \case Annotation loc val -> Just $ FailedAnnotation loc val _ -> Nothing takeFootnote :: Log -> Maybe String takeFootnote = \case Footnote x -> Just x _ -> Nothing mkFailure :: Size -> Seed -> ShrinkCount -> Maybe (Coverage CoverCount) -> Maybe Span -> String -> Maybe Diff -> [Log] -> FailureReport mkFailure size seed shrinks mcoverage location message diff logs = let inputs = mapMaybe takeAnnotation logs footnotes = mapMaybe takeFootnote logs in FailureReport size seed shrinks mcoverage inputs location message diff footnotes ------------------------------------------------------------------------ -- Pretty Printing ppShow :: Show x => x -> Doc a ppShow = -- unfortunate naming clash WL.text . show markup :: Markup -> Doc Markup -> Doc Markup markup = WL.annotate gutter :: Markup -> Doc Markup -> Doc Markup gutter m x = markup m ">" <+> x icon :: Markup -> Char -> Doc Markup -> Doc Markup icon m i x = markup m (WL.char i) <+> x ppTestCount :: TestCount -> Doc a ppTestCount = \case TestCount 1 -> "1 test" TestCount n -> ppShow n <+> "tests" ppDiscardCount :: DiscardCount -> Doc a ppDiscardCount = \case DiscardCount 1 -> "1 discard" DiscardCount n -> ppShow n <+> "discards" ppShrinkCount :: ShrinkCount -> Doc a ppShrinkCount = \case ShrinkCount 1 -> "1 shrink" ShrinkCount n -> ppShow n <+> "shrinks" ppRawPropertyCount :: PropertyCount -> Doc a ppRawPropertyCount (PropertyCount n) = ppShow n ppWithDiscardCount :: DiscardCount -> Doc Markup ppWithDiscardCount = \case DiscardCount 0 -> mempty n -> " with" <+> ppDiscardCount n ppShrinkDiscard :: ShrinkCount -> DiscardCount -> Doc Markup ppShrinkDiscard s d = case (s, d) of (0, 0) -> "" (0, _) -> " and" <+> ppDiscardCount d (_, 0) -> " and" <+> ppShrinkCount s (_, _) -> "," <+> ppShrinkCount s <+> "and" <+> ppDiscardCount d mapSource :: (Map LineNo (Line a) -> Map LineNo (Line a)) -> Declaration a -> Declaration a mapSource f decl = decl { declarationSource = f (declarationSource decl) } -- | The span of non-whitespace characters for the line. -- -- The result is @[inclusive, exclusive)@. -- lineSpan :: Line a -> (ColumnNo, ColumnNo) lineSpan (Line _ _ x0) = let (pre, x1) = span Char.isSpace x0 (_, x2) = span Char.isSpace (reverse x1) start = length pre end = start + length x2 in (fromIntegral start, fromIntegral end) takeLines :: Span -> Declaration a -> Map LineNo (Line a) takeLines sloc = fst . Map.split (spanEndLine sloc + 1) . snd . Map.split (spanStartLine sloc - 1) . declarationSource readDeclaration :: MonadIO m => Span -> m (Maybe (Declaration ())) readDeclaration sloc = runMaybeT $ do path <- liftIO . makeRelativeToCurrentDirectory $ spanFile sloc (name, Pos (Position _ line0 _) src) <- MaybeT $ Discovery.readDeclaration path (spanEndLine sloc) let line = fromIntegral line0 pure . Declaration path line name . Map.fromList . zip [line..] . zipWith (Line ()) [line..] $ lines src defaultStyle :: Declaration a -> Declaration (Style, [(Style, Doc Markup)]) defaultStyle = fmap $ const (StyleDefault, []) lastLineSpan :: Monad m => Span -> Declaration a -> MaybeT m (ColumnNo, ColumnNo) lastLineSpan sloc decl = case reverse . Map.elems $ takeLines sloc decl of [] -> MaybeT $ pure Nothing x : _ -> pure $ lineSpan x ppFailedInputTypedArgument :: Int -> FailedAnnotation -> Doc Markup ppFailedInputTypedArgument ix (FailedAnnotation _ val) = WL.vsep [ WL.text "forAll" <> ppShow ix <+> "=" , WL.indent 2 . WL.vsep . fmap (markup AnnotationValue . WL.text) $ lines val ] ppFailedInputDeclaration :: MonadIO m => FailedAnnotation -> m (Maybe (Declaration (Style, [(Style, Doc Markup)]))) ppFailedInputDeclaration (FailedAnnotation msloc val) = runMaybeT $ do sloc <- MaybeT $ pure msloc decl <- fmap defaultStyle . MaybeT $ readDeclaration sloc startCol <- fromIntegral . fst <$> lastLineSpan sloc decl let ppValLine = WL.indent startCol . (markup AnnotationGutter (WL.text "│ ") <>) . markup AnnotationValue . WL.text valDocs = fmap ((StyleAnnotation, ) . ppValLine) $ List.lines val startLine = fromIntegral $ spanStartLine sloc endLine = fromIntegral $ spanEndLine sloc styleInput kvs = foldr (Map.adjust . fmap . first $ const StyleAnnotation) kvs [startLine..endLine] insertDoc = Map.adjust (fmap . second $ const valDocs) endLine pure $ mapSource (styleInput . insertDoc) decl ppFailedInput :: MonadIO m => Int -> FailedAnnotation -> m (Either (Doc Markup) (Declaration (Style, [(Style, Doc Markup)]))) ppFailedInput ix input = do mdecl <- ppFailedInputDeclaration input case mdecl of Nothing -> pure . Left $ ppFailedInputTypedArgument ix input Just decl -> pure $ Right decl ppLineDiff :: LineDiff -> Doc Markup ppLineDiff = \case LineSame x -> markup DiffSame $ " " <> WL.text x LineRemoved x -> markup DiffRemoved $ "- " <> WL.text x LineAdded x -> markup DiffAdded $ "+ " <> WL.text x ppDiff :: Diff -> [Doc Markup] ppDiff (Diff prefix removed infix_ added suffix diff) = [ markup DiffPrefix (WL.text prefix) <> markup DiffRemoved (WL.text removed) <> markup DiffInfix (WL.text infix_) <> markup DiffAdded (WL.text added) <> markup DiffSuffix (WL.text suffix) ] ++ fmap ppLineDiff (toLineDiff diff) ppFailureLocation :: MonadIO m => [Doc Markup] -> Maybe Diff -> Span -> m (Maybe (Declaration (Style, [(Style, Doc Markup)]))) ppFailureLocation msgs mdiff sloc = runMaybeT $ do decl <- fmap defaultStyle . MaybeT $ readDeclaration sloc (startCol, endCol) <- bimap fromIntegral fromIntegral <$> lastLineSpan sloc decl let arrowDoc = WL.indent startCol $ markup FailureArrows (WL.text (replicate (endCol - startCol) '^')) ppFailure x = WL.indent startCol $ markup FailureGutter (WL.text "│ ") <> x msgDocs = fmap ((StyleFailure, ) . ppFailure . markup FailureMessage) msgs diffDocs = case mdiff of Nothing -> [] Just diff -> fmap ((StyleFailure, ) . ppFailure) (ppDiff diff) docs = [(StyleFailure, arrowDoc)] ++ msgDocs ++ diffDocs startLine = spanStartLine sloc endLine = spanEndLine sloc styleFailure kvs = foldr (Map.adjust . fmap . first $ const StyleFailure) kvs [startLine..endLine] insertDoc = Map.adjust (fmap . second $ const docs) endLine pure $ mapSource (styleFailure . insertDoc) decl ppDeclaration :: Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup ppDeclaration decl = case Map.maxView $ declarationSource decl of Nothing -> mempty Just (lastLine, _) -> let ppLocation = WL.indent (digits + 1) $ markup (StyledBorder StyleDefault) "┏━━" <+> markup DeclarationLocation (WL.text (declarationFile decl)) <+> markup (StyledBorder StyleDefault) "━━━" digits = length . show . unLineNo $ lineNumber lastLine ppLineNo = WL.text . printf ("%" <> show digits <> "d") . unLineNo ppEmptyNo = WL.text $ replicate digits ' ' ppSource style n src = markup (StyledLineNo style) (ppLineNo n) <+> markup (StyledBorder style) "┃" <+> markup (StyledSource style) (WL.text src) ppAnnot (style, doc) = markup (StyledLineNo style) ppEmptyNo <+> markup (StyledBorder style) "┃" <+> doc ppLines = do Line (style, xs) n src <- Map.elems $ declarationSource decl ppSource style n src : fmap ppAnnot xs in WL.vsep (ppLocation : ppLines) ppReproduce :: Maybe PropertyName -> Size -> Seed -> Doc Markup ppReproduce name size seed = WL.vsep [ markup ReproduceHeader "This failure can be reproduced by running:" , gutter ReproduceGutter . markup ReproduceSource $ "recheck" <+> WL.text (showsPrec 11 size "") <+> WL.text (showsPrec 11 seed "") <+> maybe "" (WL.text . unPropertyName) name ] mergeLine :: Semigroup a => Line a -> Line a -> Line a mergeLine (Line x no src) (Line y _ _) = Line (x <> y) no src mergeDeclaration :: Semigroup a => Declaration a -> Declaration a -> Declaration a mergeDeclaration (Declaration file line name src0) (Declaration _ _ _ src1) = Declaration file line name $ Map.unionWith mergeLine src0 src1 mergeDeclarations :: Semigroup a => [Declaration a] -> [Declaration a] mergeDeclarations = Map.elems . Map.fromListWith mergeDeclaration . fmap (\d -> ((declarationFile d, declarationLine d), d)) ppTextLines :: String -> [Doc Markup] 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 let basic = -- Move the failure message to the end section if we have -- no source location or can't find the source file. let msgs1 = msgs0 ++ (if null msg then [] else [msg]) docs = concatMap ppTextLines msgs1 ++ maybe [] ppDiff mdiff in (docs, Nothing) (msgs1, mlocation) <- case mlocation0 of Nothing -> return basic Just location0 -> do mAdvanced <- ppFailureLocation (fmap WL.text $ List.lines msg) mdiff location0 case mAdvanced of Just advanced -> return (concatMap ppTextLines msgs0, Just advanced) Nothing -> return basic coverageLocations <- case mcoverage of Nothing -> pure [] Just coverage -> for (coverageFailures tests coverage) $ \(MkLabel _ mclocation _ count) -> case mclocation of Nothing -> pure Nothing Just clocation -> let coverageMsg = WL.cat [ "Failed (" , WL.annotate CoverageText $ ppCoverPercentage (coverPercentage tests count) <> " coverage" , ")" ] in ppFailureLocation [coverageMsg] Nothing clocation (args, idecls) <- fmap partitionEithers $ zipWithM ppFailedInput [0..] inputs0 let decls = mergeDeclarations . catMaybes $ mlocation : coverageLocations <> fmap pure idecls with xs f = if null xs then [] else [f xs] whenSome f xs = if null xs then xs else f xs bottom = maybe [ppReproduce name size seed] (const []) mcoverage pure . whenSome (mempty :) . whenSome (++ [mempty]) . WL.punctuate WL.line . fmap (WL.vsep . fmap (WL.indent 2)) . 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 , with msgs1 $ id , with bottom $ id ] ppName :: Maybe PropertyName -> Doc a ppName = \case Nothing -> "" Just (PropertyName name) -> WL.text name 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 <+> "passed" <+> ppTestCount tests <> ppWithDiscardCount discards <+> "(running)" ] ++ ppCoverage tests coverage Shrinking failure -> pure . icon ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $ ppName name <+> "failed" <+> ppFailedAtLocation (failureLocation failure) <#> "after" <+> ppTestCount tests <> ppShrinkDiscard (failureShrinks failure) discards <+> "(shrinking)" ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup) ppResult name (Report tests discards coverage result) = do case result of Failed failure -> do pfailure <- ppFailureReport name tests failure pure . WL.vsep $ [ icon FailedIcon '✗' . WL.align . WL.annotate FailedText $ ppName name <+> "failed" <+> ppFailedAtLocation (failureLocation failure) <#> "after" <+> ppTestCount tests <> ppShrinkDiscard (failureShrinks failure) discards <> "." ] ++ ppCoverage tests coverage ++ pfailure GaveUp -> pure . WL.vsep $ [ icon GaveUpIcon '⚐' . WL.annotate GaveUpText $ ppName name <+> "gave up after" <+> ppDiscardCount discards <> ", passed" <+> ppTestCount tests <> "." ] ++ ppCoverage tests coverage OK -> pure . WL.vsep $ [ icon SuccessIcon '✓' . WL.annotate SuccessText $ ppName name <+> "passed" <+> ppTestCount tests <> "." ] ++ ppCoverage tests coverage ppFailedAtLocation :: Maybe Span -> Doc Markup ppFailedAtLocation = \case Just x -> "at" <+> WL.text (spanFile x) <> ":" <> WL.pretty (unLineNo (spanStartLine x)) <> ":" <> WL.pretty (unColumnNo (spanStartColumn x)) Nothing -> mempty ppCoverage :: TestCount -> Coverage CoverCount -> [Doc Markup] ppCoverage tests x = if Map.null (coverageLabels x) then mempty else fmap (ppLabel tests (coverageWidth tests x)) . List.sortOn labelLocation $ Map.elems (coverageLabels x) data ColumnWidth = ColumnWidth { widthPercentage :: !Int , widthMinimum :: !Int , widthName :: !Int , _widthNameFail :: !Int } instance Semigroup ColumnWidth where (<>) (ColumnWidth p0 m0 n0 f0) (ColumnWidth p1 m1 n1 f1) = ColumnWidth (max p0 p1) (max m0 m1) (max n0 n1) (max f0 f1) instance Monoid ColumnWidth where mempty = ColumnWidth 0 0 0 0 mappend = (<>) coverageWidth :: TestCount -> Coverage CoverCount -> ColumnWidth coverageWidth tests (Coverage labels) = foldMap (labelWidth tests) labels labelWidth :: TestCount -> Label CoverCount -> ColumnWidth labelWidth tests x = let percentage = length . renderCoverPercentage . coverPercentage tests $ labelAnnotation x minimum_ = if labelMinimum x == 0 then 0 else length . renderCoverPercentage $ labelMinimum x name = length . unLabelName $ labelName x nameFail = if labelCovered tests x then 0 else name in ColumnWidth percentage minimum_ name nameFail ppLeftPad :: Int -> Doc a -> Doc a ppLeftPad n doc = let ndoc = length (show doc) pad = WL.text $ List.replicate (n - ndoc) ' ' in pad <> doc ppLabel :: TestCount -> ColumnWidth -> Label CoverCount -> Doc Markup ppLabel tests w x@(MkLabel name _ minimum_ count) = let covered = labelCovered tests x ltext = if not covered then WL.annotate CoverageText else id lborder = WL.annotate (StyledBorder StyleDefault) licon = if not covered then WL.annotate CoverageText "⚠ " else " " lname = WL.fill (widthName w) (ppLabelName name) wminimum = ppLeftPad (widthMinimum w) $ ppCoverPercentage minimum_ wcover i = ppLeftPad (widthPercentage w + length i) $ WL.text i <> ppCoverPercentage (coverPercentage tests count) lminimum = if widthMinimum w == 0 then mempty else if not covered then " ✗ " <> wminimum else if minimum_ == 0 then " " <> ppLeftPad (widthMinimum w) "" else " ✓ " <> wminimum lcover = if widthMinimum w == 0 then wcover "" else if not covered then wcover "" else if minimum_ == 0 then wcover "" else wcover "" in WL.hcat [ licon , ltext lname , lborder " " , ltext lcover , lborder " " , ltext $ ppCoverBar (coverPercentage tests count) minimum_ , lborder "" -- "│" , ltext lminimum ] ppLabelName :: LabelName -> Doc a ppLabelName (LabelName name) = WL.text name ppCoverPercentage :: CoverPercentage -> Doc Markup ppCoverPercentage = WL.text . renderCoverPercentage ppCoverBar :: CoverPercentage -> CoverPercentage -> Doc Markup ppCoverBar (CoverPercentage percentage) (CoverPercentage minimum_) = let barWidth :: Int barWidth = 20 coverageRatio :: Double coverageRatio = percentage / 100.0 coverageWidth_ :: Int coverageWidth_ = floor $ coverageRatio * fromIntegral barWidth minimumRatio :: Double minimumRatio = minimum_ / 100.0 minimumWidth :: Int minimumWidth = floor $ minimumRatio * fromIntegral barWidth index :: [a] -> Int index xs = floor $ ((coverageRatio * fromIntegral barWidth) - fromIntegral coverageWidth_) * fromIntegral (length xs) part xs = xs !! index xs fillWidth = barWidth - coverageWidth_ - 1 fillErrorWidth = max 0 (minimumWidth - coverageWidth_ - 1) fillSurplusWidth = fillWidth - fillErrorWidth bar :: (Char, [Char]) -> Doc Markup bar (full, parts) = WL.hcat [ WL.text $ replicate coverageWidth_ full , if fillWidth >= 0 then if index parts == 0 then if fillErrorWidth > 0 then WL.annotate FailedText $ WL.text [part parts] else WL.annotate CoverageFill $ WL.text [part parts] else WL.text [part parts] else "" , WL.annotate FailedText . WL.text $ replicate fillErrorWidth (head parts) , WL.annotate CoverageFill . WL.text $ replicate fillSurplusWidth (head parts) -- -- Uncomment when debugging: -- -- , WL.annotate CoverageFill . WL.text $ -- " " ++ show barWidth -- ++ " " ++ show coverageWidth_ -- ++ " " ++ show minimumWidth -- ++ " " ++ "/" -- ++ " " ++ show fillErrorWidth -- ++ " " ++ "+" -- ++ " " ++ show fillSurplusWidth -- ++ " " ++ "=" -- ++ " " ++ show fillWidth ] in bar ('█', ['·', '▏', '▎', '▍', '▌', '▋', '▊', '▉']) -- FIXME Maybe this should be configurable? -- Alternative histogram bars: --bar ('⣿', ['·', '⡀', '⡄', '⡆', '⡇', '⣇', '⣧', '⣷']) --bar ('⣿', ['⢕', '⡀', '⣀', '⣄', '⣤', '⣦', '⣶', '⣷']) --bar ('⣿', ['⢕', '⡵', '⢗', '⣗', '⣟']) --bar ('⣿', [' ', '⡵', '⢗', '⣗', '⣟']) --bar ('█', ['░','▓']) --bar ('█', ['░']) renderCoverPercentage :: CoverPercentage -> String renderCoverPercentage (CoverPercentage percentage) = printf "%.0f" percentage <> "%" ppWhenNonZero :: Doc a -> PropertyCount -> Maybe (Doc a) ppWhenNonZero suffix n = if n <= 0 then Nothing else Just $ ppRawPropertyCount n <+> suffix annotateSummary :: Summary -> Doc Markup -> Doc Markup annotateSummary summary = if summaryFailed summary > 0 then icon FailedIcon '✗' . WL.annotate FailedText else if summaryGaveUp summary > 0 then icon GaveUpIcon '⚐' . WL.annotate GaveUpText else if summaryWaiting summary > 0 || summaryRunning summary > 0 then icon WaitingIcon '○' . WL.annotate WaitingHeader else icon SuccessIcon '✓' . WL.annotate SuccessText ppSummary :: MonadIO m => Summary -> m (Doc Markup) ppSummary summary = let complete = summaryCompleted summary == summaryTotal summary prefix end = if complete then mempty else ppRawPropertyCount (summaryCompleted summary) <> "/" <> ppRawPropertyCount (summaryTotal summary) <+> "complete" <> end addPrefix xs = if null xs then prefix mempty : [] else prefix ": " : xs suffix = if complete then "." else " (running)" in pure . annotateSummary summary . (<> suffix) . WL.hcat . addPrefix . WL.punctuate ", " $ catMaybes [ ppWhenNonZero "failed" (summaryFailed summary) , ppWhenNonZero "gave up" (summaryGaveUp summary) , if complete then ppWhenNonZero "succeeded" (summaryOK summary) else Nothing ] renderDoc :: MonadIO m => UseColor -> Doc Markup -> m String renderDoc color doc = do let dull = SetColor Foreground Dull vivid = SetColor Foreground Vivid bold = SetConsoleIntensity BoldIntensity start = \case WaitingIcon -> setSGRCode [] WaitingHeader -> setSGRCode [] RunningIcon -> setSGRCode [] RunningHeader -> setSGRCode [] ShrinkingIcon -> setSGRCode [vivid Red] ShrinkingHeader -> setSGRCode [vivid Red] FailedIcon -> setSGRCode [vivid Red] FailedText -> setSGRCode [vivid Red] GaveUpIcon -> setSGRCode [dull Yellow] GaveUpText -> setSGRCode [dull Yellow] SuccessIcon -> setSGRCode [dull Green] SuccessText -> setSGRCode [dull Green] CoverageIcon -> setSGRCode [dull Yellow] CoverageText -> setSGRCode [dull Yellow] CoverageFill -> setSGRCode [vivid Black] DeclarationLocation -> setSGRCode [] StyledLineNo StyleDefault -> setSGRCode [] StyledSource StyleDefault -> setSGRCode [] StyledBorder StyleDefault -> setSGRCode [] StyledLineNo StyleAnnotation -> setSGRCode [dull Magenta] StyledSource StyleAnnotation -> setSGRCode [] StyledBorder StyleAnnotation -> setSGRCode [] AnnotationGutter -> setSGRCode [dull Magenta] AnnotationValue -> setSGRCode [dull Magenta] StyledLineNo StyleFailure -> setSGRCode [vivid Red] StyledSource StyleFailure -> setSGRCode [vivid Red, bold] StyledBorder StyleFailure -> setSGRCode [] FailureArrows -> setSGRCode [vivid Red] FailureMessage -> setSGRCode [] FailureGutter -> setSGRCode [] DiffPrefix -> setSGRCode [] DiffInfix -> setSGRCode [] DiffSuffix -> setSGRCode [] DiffSame -> setSGRCode [] DiffRemoved -> setSGRCode [dull Red] DiffAdded -> setSGRCode [dull Green] ReproduceHeader -> setSGRCode [] ReproduceGutter -> setSGRCode [] ReproduceSource -> setSGRCode [] end _ = setSGRCode [Reset] let display = case color of EnableColor -> WL.displayDecorated start end id DisableColor -> WL.display #if mingw32_HOST_OS liftIO $ do hSetEncoding stdout utf8 hSetEncoding stderr utf8 #endif pure . display . WL.renderSmart 100 $ WL.indent 2 doc renderProgress :: MonadIO m => UseColor -> Maybe PropertyName -> Report Progress -> m String renderProgress color name x = renderDoc color =<< ppProgress name x renderResult :: MonadIO m => UseColor -> Maybe PropertyName -> Report Result -> m String renderResult color name x = renderDoc color =<< ppResult name x renderSummary :: MonadIO m => UseColor -> Summary -> m String renderSummary color x = renderDoc color =<< ppSummary x hedgehog-1.0.3/src/Hedgehog/Internal/Runner.hs0000644060175106010010000003467013675330725020422 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Hedgehog.Internal.Runner ( -- * Running Individual Properties check , recheck -- * Running Groups of Properties , RunnerConfig(..) , checkParallel , checkSequential , checkGroup -- * Internal , checkReport , checkRegion , checkNamed ) where import Control.Concurrent.STM (TVar, atomically) import qualified Control.Concurrent.STM.TVar as TVar import Control.Monad.Catch (MonadCatch(..), catchAll) import Control.Monad.IO.Class (MonadIO(..)) import Hedgehog.Internal.Config import Hedgehog.Internal.Gen (evalGenT) import Hedgehog.Internal.Prelude import Hedgehog.Internal.Property (DiscardCount(..), ShrinkCount(..)) import Hedgehog.Internal.Property (Group(..), GroupName(..)) 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 (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.Queue import Hedgehog.Internal.Region import Hedgehog.Internal.Report import Hedgehog.Internal.Seed (Seed) import qualified Hedgehog.Internal.Seed as Seed import Hedgehog.Internal.Tree (TreeT(..), NodeT(..)) import Hedgehog.Range (Size) import Language.Haskell.TH.Syntax (Lift) #if mingw32_HOST_OS import System.IO (hSetEncoding, stdout, stderr, utf8) #endif -- | Configuration for a property test run. -- data RunnerConfig = RunnerConfig { -- | The number of property tests to run concurrently. 'Nothing' means -- use one worker per processor. runnerWorkers :: !(Maybe WorkerCount) -- | Whether to use colored output or not. 'Nothing' means detect from -- the environment. , runnerColor :: !(Maybe UseColor) -- | How verbose to be in the runner output. 'Nothing' means detect from -- the environment. , runnerVerbosity :: !(Maybe Verbosity) } deriving (Eq, Ord, Show, Lift) findM :: Monad m => [a] -> b -> (a -> m (Maybe b)) -> m b findM xs0 def p = case xs0 of [] -> return def x0 : xs -> p x0 >>= \m -> case m of Nothing -> findM xs def p Just x -> return x isFailure :: NodeT m (Maybe (Either x a, b)) -> Bool isFailure = \case NodeT (Just (Left _, _)) _ -> True _ -> False isSuccess :: NodeT m (Maybe (Either x a, b)) -> Bool isSuccess = not . isFailure runTreeN :: Monad m => ShrinkRetries -> TreeT m (Maybe (Either x a, b)) -> m (NodeT m (Maybe (Either x a, b))) runTreeN n m = do o <- runTreeT m if n > 0 && isSuccess o then runTreeN (n - 1) m else pure o takeSmallest :: MonadIO m => Size -> Seed -> ShrinkCount -> ShrinkLimit -> ShrinkRetries -> (Progress -> m ()) -> NodeT m (Maybe (Either Failure (), Journal)) -> m Result takeSmallest size seed shrinks slimit retries updateUI = \case NodeT Nothing _ -> pure GaveUp NodeT (Just (x, (Journal logs))) xs -> case x of Left (Failure loc err mdiff) -> do let failure = mkFailure size seed shrinks Nothing loc err mdiff (reverse logs) updateUI $ Shrinking failure if shrinks >= fromIntegral slimit then -- if we've hit the shrink limit, don't shrink any further pure $ Failed failure else findM xs (Failed failure) $ \m -> do o <- runTreeN retries m if isFailure o then Just <$> takeSmallest size seed (shrinks + 1) slimit retries updateUI o else return Nothing Right () -> return OK checkReport :: forall m. MonadIO m => MonadCatch m => PropertyConfig -> Size -> Seed -> PropertyT m () -> (Report Progress -> m ()) -> m (Report Result) checkReport cfg size0 seed0 test0 updateUI = let test = catchAll test0 (fail . show) terminationCriteria = propertyTerminationCriteria cfg (confidence, minTests) = case terminationCriteria of EarlyTermination c t -> (Just c, t) NoEarlyTermination c t -> (Just c, t) NoConfidenceTermination t -> (Nothing, t) successVerified count coverage = count `mod` 100 == 0 && -- If the user wants a statistically significant result, this function -- will run a confidence check. Otherwise, it will default to checking -- the percentage of encountered labels maybe False (\c -> confidenceSuccess count c coverage) confidence failureVerified count coverage = -- Will be true if we can statistically verify that our coverage was -- inadequate. -- Testing only on 100s to minimise repeated measurement statistical -- errors. count `mod` 100 == 0 && maybe False (\c -> confidenceFailure count c coverage) confidence loop :: TestCount -> DiscardCount -> Size -> Seed -> Coverage CoverCount -> m (Report Result) loop !tests !discards !size !seed !coverage0 = do updateUI $ Report tests discards coverage0 Running let coverageReached = successVerified tests coverage0 coverageUnreachable = failureVerified tests coverage0 enoughTestsRun = case terminationCriteria of EarlyTermination _ _ -> tests >= fromIntegral defaultMinTests && (coverageReached || coverageUnreachable) NoEarlyTermination _ _ -> tests >= fromIntegral minTests NoConfidenceTermination _ -> tests >= fromIntegral minTests labelsCovered = coverageSuccess tests coverage0 successReport = Report tests discards coverage0 OK failureReport message = Report tests discards coverage0 . Failed $ mkFailure size seed 0 (Just coverage0) Nothing message Nothing [] confidenceReport = if coverageReached && labelsCovered then successReport else failureReport $ "Test coverage cannot be reached after " <> show tests <> " tests" if size > 99 then -- size has reached limit, reset to 0 loop tests discards 0 seed coverage0 else if enoughTestsRun then -- 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" else if discards >= fromIntegral (propertyDiscardLimit cfg) then -- we've hit the discard limit, give up pure $ Report tests discards coverage0 GaveUp else case Seed.split seed of (s0, s1) -> do node@(NodeT x _) <- runTreeT . evalGenT size s0 . runTestT $ unPropertyT test case x of Nothing -> loop tests (discards + 1) (size + 1) s1 coverage0 Just (Left _, _) -> let mkReport = Report (tests + 1) discards coverage0 in fmap mkReport $ takeSmallest size seed 0 (propertyShrinkLimit cfg) (propertyShrinkRetries cfg) (updateUI . mkReport) node Just (Right (), journal) -> let coverage = journalCoverage journal <> coverage0 in loop (tests + 1) discards (size + 1) s1 coverage in loop 0 0 size0 seed0 mempty checkRegion :: MonadIO m => Region -> UseColor -> Maybe PropertyName -> Size -> Seed -> Property -> m (Report Result) checkRegion region color name size seed prop = liftIO $ do result <- checkReport (propertyConfig prop) size seed (propertyTest prop) $ \progress -> do ppprogress <- renderProgress color name progress case reportStatus progress of Running -> setRegion region ppprogress Shrinking _ -> openRegion region ppprogress ppresult <- renderResult color name result case reportStatus result of Failed _ -> openRegion region ppresult GaveUp -> openRegion region ppresult OK -> setRegion region ppresult pure result checkNamed :: MonadIO m => Region -> UseColor -> Maybe PropertyName -> Property -> m (Report Result) checkNamed region color name prop = do seed <- liftIO Seed.random checkRegion region color name 0 seed prop -- | Check a property. -- check :: MonadIO m => Property -> m Bool check prop = do color <- detectColor liftIO . displayRegion $ \region -> (== OK) . reportStatus <$> checkNamed region color Nothing prop -- | Check a property using a specific size and seed. -- recheck :: MonadIO m => Size -> Seed -> Property -> m () recheck size seed prop0 = do color <- detectColor let prop = withTests 1 prop0 _ <- liftIO . displayRegion $ \region -> checkRegion region color Nothing size seed prop pure () -- | Check a group of properties using the specified runner config. -- checkGroup :: MonadIO m => RunnerConfig -> Group -> m Bool checkGroup config (Group group props) = liftIO $ do n <- resolveWorkers (runnerWorkers config) -- ensure few spare capabilities for concurrent-output, it's likely that -- our tests will saturate all the capabilities they're given. updateNumCapabilities (n + 2) #if mingw32_HOST_OS hSetEncoding stdout utf8 hSetEncoding stderr utf8 #endif putStrLn $ "━━━ " ++ unGroupName group ++ " ━━━" verbosity <- resolveVerbosity (runnerVerbosity config) color <- resolveColor (runnerColor config) summary <- checkGroupWith n verbosity color props pure $ summaryFailed summary == 0 && summaryGaveUp summary == 0 updateSummary :: Region -> TVar Summary -> UseColor -> (Summary -> Summary) -> IO () updateSummary sregion svar color f = do summary <- atomically (TVar.modifyTVar' svar f >> TVar.readTVar svar) setRegion sregion =<< renderSummary color summary checkGroupWith :: WorkerCount -> Verbosity -> UseColor -> [(PropertyName, Property)] -> IO Summary checkGroupWith n verbosity color props = displayRegion $ \sregion -> do svar <- atomically . TVar.newTVar $ mempty { summaryWaiting = PropertyCount (length props) } let start (TasksRemaining tasks) _ix (name, prop) = liftIO $ do updateSummary sregion svar color $ \x -> x { summaryWaiting = PropertyCount tasks , summaryRunning = summaryRunning x + 1 } atomically $ do region <- case verbosity of Quiet -> newEmptyRegion Normal -> newOpenRegion moveToBottom sregion pure (name, prop, region) finish (_name, _prop, _region) = updateSummary sregion svar color $ \x -> x { summaryRunning = summaryRunning x - 1 } finalize (_name, _prop, region) = finishRegion region summary <- fmap (mconcat . fmap (fromResult . reportStatus)) $ runTasks n props start finish finalize $ \(name, prop, region) -> do result <- checkNamed region color (Just name) prop updateSummary sregion svar color (<> fromResult (reportStatus result)) pure result updateSummary sregion svar color (const summary) pure summary -- | Check a group of properties sequentially. -- -- Using Template Haskell for property discovery: -- -- > tests :: IO Bool -- > tests = -- > checkSequential $$(discover) -- -- With manually specified properties: -- -- > tests :: IO Bool -- > tests = -- > checkSequential $ Group "Test.Example" [ -- > ("prop_reverse", prop_reverse) -- > ] -- -- checkSequential :: MonadIO m => Group -> m Bool checkSequential = checkGroup RunnerConfig { runnerWorkers = Just 1 , runnerColor = Nothing , runnerVerbosity = Nothing } -- | Check a group of properties in parallel. -- -- /Warning: although this check function runs tests faster than/ -- /'checkSequential', it should be noted that it may cause problems with/ -- /properties that are not self-contained. For example, if you have a group/ -- /of tests which all use the same database table, you may find that they/ -- /interfere with each other when being run in parallel./ -- -- Using Template Haskell for property discovery: -- -- > tests :: IO Bool -- > tests = -- > checkParallel $$(discover) -- -- With manually specified properties: -- -- > tests :: IO Bool -- > tests = -- > checkParallel $ Group "Test.Example" [ -- > ("prop_reverse", prop_reverse) -- > ] -- checkParallel :: MonadIO m => Group -> m Bool checkParallel = checkGroup RunnerConfig { runnerWorkers = Nothing , runnerColor = Nothing , runnerVerbosity = Nothing } hedgehog-1.0.3/src/Hedgehog/Internal/Seed.hs0000644060175106010010000001320413675330725020017 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP #-} -- | -- This is a port of "Fast Splittable Pseudorandom Number Generators" by Steele -- et. al. [1]. -- -- The paper's algorithm provides decent randomness for most purposes but -- sacrifices cryptographic-quality randomness in favor of speed. The original -- implementation is tested with DieHarder and BigCrush; see the paper for -- details. -- -- This implementation, originally from [2], is a port from the paper. -- -- It also takes in to account the SplittableRandom.java source code in OpenJDK -- v8u40-b25 as well as splittable_random.ml in Jane Street's standard library -- overlay (kernel) v113.33.03, and Random.fs in FsCheck v3. -- -- Other than the choice of initial seed for 'from' this port should be -- faithful. -- -- 1. Guy L. Steele, Jr., Doug Lea, Christine H. Flood -- Fast splittable pseudorandom number generators -- Comm ACM, 49(10), Oct 2014, pp453-472. -- -- 2. Nikos Baxevanis -- https://github.com/moodmosaic/SplitMix/blob/master/SplitMix.hs -- #include "MachDeps.h" module Hedgehog.Internal.Seed ( Seed(..) , random , from , split , nextInteger , nextDouble -- * Internal -- $internal , goldenGamma , nextWord64 , nextWord32 , mix64 , mix64variant13 , mix32 , mixGamma ) where import Control.Monad.IO.Class (MonadIO(..)) import Data.Bifunctor (first) import Data.Bits ((.|.), xor, shiftR, popCount) #if (SIZEOF_HSINT == 8) import Data.Int (Int64) #else import Data.Int (Int32) #endif import Data.Time.Clock.POSIX (getPOSIXTime) import Data.IORef (IORef) import qualified Data.IORef as IORef import Data.Word (Word32, Word64) import System.IO.Unsafe (unsafePerformIO) import System.Random (RandomGen) import qualified System.Random as Random -- | A splittable random number generator. -- data Seed = Seed { seedValue :: !Word64 , seedGamma :: !Word64 -- ^ must be an odd number } deriving (Eq, Ord) instance Show Seed where showsPrec p (Seed v g) = showParen (p > 10) $ showString "Seed " . showsPrec 11 v . showChar ' ' . showsPrec 11 g instance Read Seed where readsPrec p = readParen (p > 10) $ \r0 -> do ("Seed", r1) <- lex r0 (v, r2) <- readsPrec 11 r1 (g, r3) <- readsPrec 11 r2 pure (Seed v g, r3) global :: IORef Seed global = unsafePerformIO $ do -- FIXME use /dev/urandom on posix seconds <- getPOSIXTime IORef.newIORef $ from (round (seconds * 1000)) {-# NOINLINE global #-} -- | Create a random 'Seed' using an effectful source of randomness. -- random :: MonadIO m => m Seed random = liftIO $ IORef.atomicModifyIORef' global split -- | Create a 'Seed' using a 'Word64'. -- from :: Word64 -> Seed from x = Seed (mix64 x) (mixGamma (x + goldenGamma)) -- | A predefined gamma value's needed for initializing the "root" instances of -- 'Seed'. That is, instances not produced by splitting an already existing -- instance. -- -- We choose: the odd integer closest to @2^64/φ@, where @φ = (1 + √5)/2@ is -- the golden ratio. -- goldenGamma :: Word64 goldenGamma = 0x9e3779b97f4a7c15 -- | Get the next value in the SplitMix sequence. -- next :: Seed -> (Word64, Seed) next (Seed v0 g) = let v = v0 + g in (v, Seed v g) -- | Splits a random number generator in to two. -- split :: Seed -> (Seed, Seed) split s0 = let (v0, s1) = next s0 (g0, s2) = next s1 in (s2, Seed (mix64 v0) (mixGamma g0)) -- | Generate a random 'Word64'. -- nextWord64 :: Seed -> (Word64, Seed) nextWord64 s0 = let (v0, s1) = next s0 in (mix64 v0, s1) -- | Generate a random 'Word32'. -- nextWord32 :: Seed -> (Word32, Seed) nextWord32 s0 = let (v0, s1) = next s0 in (mix32 v0, s1) -- | Generate a random 'Integer' in the [inclusive,inclusive] range. -- nextInteger :: Integer -> Integer -> Seed -> (Integer, Seed) nextInteger lo hi = Random.randomR (lo, hi) -- | Generate a random 'Double' in the [inclusive,exclusive) range. -- nextDouble :: Double -> Double -> Seed -> (Double, Seed) nextDouble lo hi = Random.randomR (lo, hi) mix64 :: Word64 -> Word64 mix64 x = let y = (x `xor` (x `shiftR` 33)) * 0xff51afd7ed558ccd z = (y `xor` (y `shiftR` 33)) * 0xc4ceb9fe1a85ec53 in z `xor` (z `shiftR` 33) mix32 :: Word64 -> Word32 mix32 x = let y = (x `xor` (x `shiftR` 33)) * 0xff51afd7ed558ccd z = (y `xor` (y `shiftR` 33)) * 0xc4ceb9fe1a85ec53 in fromIntegral (z `shiftR` 32) mix64variant13 :: Word64 -> Word64 mix64variant13 x = let y = (x `xor` (x `shiftR` 30)) * 0xbf58476d1ce4e5b9 z = (y `xor` (y `shiftR` 27)) * 0x94d049bb133111eb in z `xor` (z `shiftR` 31) mixGamma :: Word64 -> Word64 mixGamma x = let y = mix64variant13 x .|. 1 n = popCount $ y `xor` (y `shiftR` 1) in if n < 24 then y `xor` 0xaaaaaaaaaaaaaaaa else y ------------------------------------------------------------------------ -- RandomGen instances #if (SIZEOF_HSINT == 8) instance RandomGen Seed where next = first fromIntegral . nextWord64 genRange _ = (fromIntegral (minBound :: Int64), fromIntegral (maxBound :: Int64)) split = split #else instance RandomGen Seed where next = first fromIntegral . nextWord32 genRange _ = (fromIntegral (minBound :: Int32), fromIntegral (maxBound :: Int32)) split = split #endif ------------------------------------------------------------------------ -- Internal -- $internal -- -- These functions are exported in case you need them in a pinch, but are not -- part of the public API and may change at any time, even as part of a minor -- update. hedgehog-1.0.3/src/Hedgehog/Internal/Show.hs0000644060175106010010000001401113675330725020054 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-} module Hedgehog.Internal.Show ( Name , Value(..) , ValueDiff(..) , LineDiff(..) , mkValue , showPretty , valueDiff , lineDiff , toLineDiff , renderValue , renderValueDiff , renderLineDiff , takeLeft , takeRight ) where import Data.Bifunctor (second) import Text.Show.Pretty (Value(..), Name, reify, valToStr, ppShow) data ValueDiff = ValueCon Name [ValueDiff] | ValueRec Name [(Name, ValueDiff)] | ValueTuple [ValueDiff] | ValueList [ValueDiff] | ValueSame Value | ValueDiff Value Value deriving (Eq, Show) data LineDiff = LineSame String | LineRemoved String | LineAdded String deriving (Eq, Show) data DocDiff = DocSame Int String | DocRemoved Int String | DocAdded Int String | DocOpen Int String | DocItem Int String [DocDiff] | DocClose Int String deriving (Eq, Show) renderValue :: Value -> String renderValue = valToStr renderValueDiff :: ValueDiff -> String renderValueDiff = unlines . fmap renderLineDiff . toLineDiff renderLineDiff :: LineDiff -> String renderLineDiff = \case LineSame x -> " " ++ x LineRemoved x -> "- " ++ x LineAdded x -> "+ " ++ x mkValue :: Show a => a -> Maybe Value mkValue = reify showPretty :: Show a => a -> String showPretty = ppShow lineDiff :: Value -> Value -> [LineDiff] lineDiff x y = toLineDiff $ valueDiff x y toLineDiff :: ValueDiff -> [LineDiff] toLineDiff = concatMap (mkLineDiff 0 "") . collapseOpen . dropLeadingSep . mkDocDiff 0 valueDiff :: Value -> Value -> ValueDiff valueDiff x y = if x == y then ValueSame x else case (x, y) of (Con nx xs, Con ny ys) | nx == ny , length xs == length ys -> ValueCon nx (zipWith valueDiff xs ys) (Rec nx nxs, Rec ny nys) | nx == ny , fmap fst nxs == fmap fst nys , ns <- fmap fst nxs , xs <- fmap snd nxs , ys <- fmap snd nys -> ValueRec nx (zip ns (zipWith valueDiff xs ys)) (Tuple xs, Tuple ys) | length xs == length ys -> ValueTuple (zipWith valueDiff xs ys) (List xs, List ys) | length xs == length ys -> ValueList (zipWith valueDiff xs ys) _ -> ValueDiff x y takeLeft :: ValueDiff -> Value takeLeft = \case ValueCon n xs -> Con n (fmap takeLeft xs) ValueRec n nxs -> Rec n (fmap (second takeLeft) nxs) ValueTuple xs -> Tuple (fmap takeLeft xs) ValueList xs -> List (fmap takeLeft xs) ValueSame x -> x ValueDiff x _ -> x takeRight :: ValueDiff -> Value takeRight = \case ValueCon n xs -> Con n (fmap takeRight xs) ValueRec n nxs -> Rec n (fmap (second takeRight) nxs) ValueTuple xs -> Tuple (fmap takeRight xs) ValueList xs -> List (fmap takeRight xs) ValueSame x -> x ValueDiff _ x -> x mkLineDiff :: Int -> String -> DocDiff -> [LineDiff] mkLineDiff indent0 prefix0 diff = let mkLinePrefix indent = spaces indent0 ++ prefix0 ++ spaces indent mkLineIndent indent = indent0 + length prefix0 + indent in case diff of DocSame indent x -> [LineSame $ mkLinePrefix indent ++ x] DocRemoved indent x -> [LineRemoved $ mkLinePrefix indent ++ x] DocAdded indent x -> [LineAdded $ mkLinePrefix indent ++ x] DocOpen indent x -> [LineSame $ mkLinePrefix indent ++ x] DocItem _ _ [] -> [] DocItem indent prefix (x@DocRemoved{} : y@DocAdded{} : xs) -> mkLineDiff (mkLineIndent indent) prefix x ++ mkLineDiff (mkLineIndent indent) prefix y ++ concatMap (mkLineDiff (mkLineIndent (indent + length prefix)) "") xs DocItem indent prefix (x : xs) -> mkLineDiff (mkLineIndent indent) prefix x ++ concatMap (mkLineDiff (mkLineIndent (indent + length prefix)) "") xs DocClose indent x -> [LineSame $ spaces (mkLineIndent indent) ++ x] spaces :: Int -> String spaces indent = replicate indent ' ' collapseOpen :: [DocDiff] -> [DocDiff] collapseOpen = \case DocSame indent line : DocOpen _ bra : xs -> DocSame indent (line ++ " " ++ bra) : collapseOpen xs DocItem indent prefix xs : ys -> DocItem indent prefix (collapseOpen xs) : collapseOpen ys x : xs -> x : collapseOpen xs [] -> [] dropLeadingSep :: [DocDiff] -> [DocDiff] dropLeadingSep = \case DocOpen oindent bra : DocItem indent prefix xs : ys -> DocOpen oindent bra : DocItem (indent + length prefix) "" (dropLeadingSep xs) : dropLeadingSep ys DocItem indent prefix xs : ys -> DocItem indent prefix (dropLeadingSep xs) : dropLeadingSep ys x : xs -> x : dropLeadingSep xs [] -> [] mkDocDiff :: Int -> ValueDiff -> [DocDiff] mkDocDiff indent = \case ValueSame x -> same indent (renderValue x) diff | x <- takeLeft diff , y <- takeRight diff , oneLiner x , oneLiner y -> removed indent (renderValue x) ++ added indent (renderValue y) ValueCon n xs -> same indent n ++ concatMap (mkDocDiff (indent + 2)) xs ValueRec n nxs -> same indent n ++ [DocOpen indent "{"] ++ fmap (\(name, x) -> DocItem (indent + 2) ", " (same 0 (name ++ " =") ++ mkDocDiff 2 x)) nxs ++ [DocClose (indent + 2) "}"] ValueTuple xs -> [DocOpen indent "("] ++ fmap (DocItem indent ", " . mkDocDiff 0) xs ++ [DocClose indent ")"] ValueList xs -> [DocOpen indent "["] ++ fmap (DocItem indent ", " . mkDocDiff 0) xs ++ [DocClose indent "]"] ValueDiff x y -> removed indent (renderValue x) ++ added indent (renderValue y) oneLiner :: Value -> Bool oneLiner x = case lines (renderValue x) of _ : _ : _ -> False _ -> True same :: Int -> String -> [DocDiff] same indent = fmap (DocSame indent) . lines removed :: Int -> String -> [DocDiff] removed indent = fmap (DocRemoved indent) . lines added :: Int -> String -> [DocDiff] added indent = fmap (DocAdded indent) . lines hedgehog-1.0.3/src/Hedgehog/Internal/Shrink.hs0000644060175106010010000000543613675330725020405 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} module Hedgehog.Internal.Shrink ( towards , towardsFloat , list , halves , removes , consNub ) where -- | Shrink an integral number by edging towards a destination. -- -- >>> towards 0 100 -- [0,50,75,88,94,97,99] -- -- >>> towards 500 1000 -- [500,750,875,938,969,985,993,997,999] -- -- >>> towards (-50) (-26) -- [-50,-38,-32,-29,-27] -- -- /Note we always try the destination first, as that is the optimal shrink./ -- towards :: Integral a => a -> a -> [a] towards destination x = if destination == x then [] else let -- Halve the operands before subtracting them so they don't overflow. -- Consider 'minBound' and 'maxBound' for a fixed sized type like 'Int64'. diff = (x `quot` 2) - (destination `quot` 2) in destination `consNub` fmap (x -) (halves diff) -- | Shrink a floating-point number by edging towards a destination. -- -- >>> take 7 (towardsFloat 0.0 100) -- [0.0,50.0,75.0,87.5,93.75,96.875,98.4375] -- -- >>> take 7 (towardsFloat 1.0 0.5) -- [1.0,0.75,0.625,0.5625,0.53125,0.515625,0.5078125] -- -- /Note we always try the destination first, as that is the optimal shrink./ -- towardsFloat :: RealFloat a => a -> a -> [a] towardsFloat destination x = if destination == x then [] else let diff = x - destination ok y = y /= x && not (isNaN y) && not (isInfinite y) in takeWhile ok . fmap (x -) $ iterate (/ 2) diff -- | Shrink a list by edging towards the empty list. -- -- >>> list [1,2,3] -- [[],[2,3],[1,3],[1,2]] -- -- >>> list "abcd" -- ["","cd","ab","bcd","acd","abd","abc"] -- -- /Note we always try the empty list first, as that is the optimal shrink./ -- list :: [a] -> [[a]] list xs = concatMap (\k -> removes k xs) (halves $ length xs) -- | Produce all permutations of removing 'k' elements from a list. -- -- >>> removes 2 "abcdef" -- ["cdef","abef","abcd"] -- removes :: Int -> [a] -> [[a]] removes k0 xs0 = let loop k n xs = let (hd, tl) = splitAt k xs in if k > n then [] else if null tl then [[]] else tl : fmap (hd ++) (loop k (n - k) tl) in loop k0 (length xs0) xs0 -- | Produce a list containing the progressive halving of an integral. -- -- >>> halves 15 -- [15,7,3,1] -- -- >>> halves 100 -- [100,50,25,12,6,3,1] -- -- >>> halves (-26) -- [-26,-13,-6,-3,-1] -- halves :: Integral a => a -> [a] halves = takeWhile (/= 0) . iterate (`quot` 2) -- | Cons an element on to the front of a list unless it is already there. -- consNub :: Eq a => a -> [a] -> [a] consNub x ys0 = case ys0 of [] -> x : [] y : ys -> if x == y then y : ys else x : y : ys hedgehog-1.0.3/src/Hedgehog/Internal/Source.hs0000644060175106010010000000364613675330725020410 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} module Hedgehog.Internal.Source ( LineNo(..) , ColumnNo(..) , Span(..) , getCaller -- * Re-exports from "GHC.Stack" , CallStack , HasCallStack , callStack , withFrozenCallStack ) where import GHC.Stack (CallStack, HasCallStack, SrcLoc(..)) import GHC.Stack (callStack, getCallStack, withFrozenCallStack) newtype LineNo = LineNo { unLineNo :: Int } deriving (Eq, Ord, Num, Enum, Real, Integral) newtype ColumnNo = ColumnNo { unColumnNo :: Int } deriving (Eq, Ord, Num, Enum, Real, Integral) data Span = Span { spanFile :: !FilePath , spanStartLine :: !LineNo , spanStartColumn :: !ColumnNo , spanEndLine :: !LineNo , spanEndColumn :: !ColumnNo } deriving (Eq, Ord) getCaller :: CallStack -> Maybe Span getCaller stack = case getCallStack stack of [] -> Nothing (_, x) : _ -> Just $ Span (srcLocFile x) (fromIntegral $ srcLocStartLine x) (fromIntegral $ srcLocStartCol x) (fromIntegral $ srcLocEndLine x) (fromIntegral $ srcLocEndCol x) ------------------------------------------------------------------------ -- Show instances instance Show Span where showsPrec p (Span file sl sc el ec) = showParen (p > 10) $ showString "Span " . showsPrec 11 file . showChar ' ' . showsPrec 11 sl . showChar ' ' . showsPrec 11 sc . showChar ' ' . showsPrec 11 el . showChar ' ' . showsPrec 11 ec instance Show LineNo where showsPrec p (LineNo x) = showParen (p > 10) $ showString "LineNo " . showsPrec 11 x instance Show ColumnNo where showsPrec p (ColumnNo x) = showParen (p > 10) $ showString "ColumnNo " . showsPrec 11 x hedgehog-1.0.3/src/Hedgehog/Internal/State.hs0000644060175106010010000005617113675330725020231 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} module Hedgehog.Internal.State ( -- * Variables Var(..) , concrete , opaque , Concrete(..) , Symbolic(..) , Name(..) -- * Environment , Environment(..) , EnvironmentError(..) , emptyEnvironment , insertConcrete , reifyDynamic , reifyEnvironment , reify -- * Commands , Command(..) , Callback(..) , commandGenOK -- * Actions , Action(..) , Sequential(..) , Parallel(..) , takeVariables , variablesOK , dropInvalid , action , sequential , parallel , executeSequential , executeParallel ) where import qualified Control.Concurrent.Async.Lifted as Async 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) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.State (State, runState, execState) import Control.Monad.Trans.State (StateT(..), evalStateT, runStateT) import Data.Dynamic (Dynamic, toDyn, fromDynamic, dynTypeRep) import Data.Foldable (traverse_) import Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..)) import Data.Functor.Classes (eq1, compare1, showsPrec1) import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Maybe as Maybe import Data.Typeable (Typeable, TypeRep, Proxy(..), typeRep) import Hedgehog.Internal.Distributive (distributeT) import Hedgehog.Internal.Gen (MonadGen, GenT, GenBase) import qualified Hedgehog.Internal.Gen as Gen import Hedgehog.Internal.HTraversable (HTraversable(..)) import Hedgehog.Internal.Opaque (Opaque(..)) import Hedgehog.Internal.Property (MonadTest(..), Test, evalEither, evalM, success, runTest, failWith, annotate) import Hedgehog.Internal.Range (Range) import Hedgehog.Internal.Show (showPretty) import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack) -- | Symbolic variable names. -- newtype Name = Name Int deriving (Eq, Ord, Num) instance Show Name where showsPrec p (Name x) = showsPrec p x -- | Symbolic values: Because hedgehog generates actions in a separate phase -- before execution, you will sometimes need to refer to the result of a -- previous action in a generator without knowing the value of the result -- (e.g., to get the ID of a previously-created user). -- -- Symbolic variables provide a token to stand in for the actual variables at -- generation time (and in 'Require'/'Update' callbacks). At execution time, -- real values are available, so your execute actions work on 'Concrete' -- variables. -- -- See also: 'Command', 'Var' -- data Symbolic a where Symbolic :: Typeable a => Name -> Symbolic a deriving instance Eq (Symbolic a) deriving instance Ord (Symbolic a) instance Show (Symbolic a) where showsPrec p (Symbolic x) = showsPrec p x instance Show1 Symbolic where liftShowsPrec _ _ p (Symbolic x) = showsPrec p x instance Eq1 Symbolic where liftEq _ (Symbolic x) (Symbolic y) = x == y instance Ord1 Symbolic where liftCompare _ (Symbolic x) (Symbolic y) = compare x y -- | Concrete values: At test-execution time, 'Symbolic' values from generation -- are replaced with 'Concrete' values from performing actions. This type -- gives us something of the same kind as 'Symbolic' to pass as a type -- argument to 'Var'. -- newtype Concrete a where Concrete :: a -> Concrete a deriving (Eq, Ord, Functor, Foldable, Traversable) instance Show a => Show (Concrete a) where showsPrec = showsPrec1 instance Show1 Concrete where liftShowsPrec sp _ p (Concrete x) = sp p x instance Eq1 Concrete where liftEq eq (Concrete x) (Concrete y) = eq x y instance Ord1 Concrete where liftCompare comp (Concrete x) (Concrete y) = comp x y ------------------------------------------------------------------------ -- | Variables are the potential or actual result of executing an action. They -- are parameterised by either `Symbolic` or `Concrete` depending on the -- phase of the test. -- -- `Symbolic` variables are the potential results of actions. These are used -- when generating the sequence of actions to execute. They allow actions -- which occur later in the sequence to make use of the result of an action -- which came earlier in the sequence. -- -- `Concrete` variables are the actual results of actions. These are used -- during test execution. They provide access to the actual runtime value of -- a variable. -- -- The state update `Callback` for a command needs to be polymorphic in the -- 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. -- newtype Var a v = Var (v a) -- | Take the value from a concrete variable. -- concrete :: Var a Concrete -> a concrete (Var (Concrete x)) = x -- | Take the value from an opaque concrete variable. -- opaque :: Var (Opaque a) Concrete -> a opaque (Var (Concrete (Opaque x))) = x instance (Eq a, Eq1 v) => Eq (Var a v) where (==) (Var x) (Var y) = eq1 x y instance (Ord a, Ord1 v) => Ord (Var a v) where compare (Var x) (Var y) = compare1 x y instance (Show a, Show1 v) => Show (Var a v) where showsPrec p (Var x) = showParen (p >= 11) $ showString "Var " . showsPrec1 11 x instance HTraversable (Var a) where htraverse f (Var v) = fmap Var (f v) ------------------------------------------------------------------------ -- Symbolic Environment -- | A mapping of symbolic values to concrete values. -- newtype Environment = Environment { unEnvironment :: Map Name Dynamic } deriving (Show) -- | Environment errors. -- data EnvironmentError = EnvironmentValueNotFound !Name | EnvironmentTypeError !TypeRep !TypeRep deriving (Eq, Ord, Show) -- | Create an empty environment. -- emptyEnvironment :: Environment emptyEnvironment = Environment Map.empty unionsEnvironment :: [Environment] -> Environment unionsEnvironment = Environment . Map.unions . fmap unEnvironment -- | Insert a symbolic / concrete pairing in to the environment. -- insertConcrete :: Symbolic a -> Concrete a -> Environment -> Environment insertConcrete (Symbolic k) (Concrete v) = Environment . Map.insert k (toDyn v) . unEnvironment -- | Cast a 'Dynamic' in to a concrete value. -- reifyDynamic :: forall a. Typeable a => Dynamic -> Either EnvironmentError (Concrete a) reifyDynamic dyn = case fromDynamic dyn of Nothing -> Left $ EnvironmentTypeError (typeRep (Proxy :: Proxy a)) (dynTypeRep dyn) Just x -> Right $ Concrete x -- | Turns an environment in to a function for looking up a concrete value from -- a symbolic one. -- reifyEnvironment :: Environment -> (forall a. Symbolic a -> Either EnvironmentError (Concrete a)) reifyEnvironment (Environment vars) (Symbolic n) = case Map.lookup n vars of Nothing -> Left $ EnvironmentValueNotFound n Just dyn -> reifyDynamic dyn -- | Convert a symbolic structure to a concrete one, using the provided environment. -- reify :: HTraversable t => Environment -> t Symbolic -> Either EnvironmentError (t Concrete) reify vars = htraverse (reifyEnvironment vars) ------------------------------------------------------------------------ -- Callbacks -- | Optional command configuration. -- data Callback input output state = -- | A pre-condition for a command that must be verified before the command -- can be executed. This is mainly used during shrinking to ensure that it -- is still OK to run a command despite the fact that some previously -- executed commands may have been removed from the sequence. -- Require (state Symbolic -> input Symbolic -> Bool) -- | Updates the model state, given the input and output of the command. Note -- that this function is polymorphic in the type of values. This is because -- it must work over 'Symbolic' values when we are generating actions, and -- 'Concrete' values when we are executing them. -- | Update (forall v. Ord1 v => state v -> input v -> Var output v -> state v) -- | A post-condition for a command that must be verified for the command to -- be considered a success. -- -- This callback receives the state prior to execution as the first -- argument, and the state after execution as the second argument. -- | Ensure (state Concrete -> state Concrete -> input Concrete -> output -> Test ()) callbackRequire1 :: state Symbolic -> input Symbolic -> Callback input output state -> Bool callbackRequire1 s i = \case Require f -> f s i Update _ -> True Ensure _ -> True callbackUpdate1 :: Ord1 v => state v -> input v -> Var output v -> Callback input output state -> state v callbackUpdate1 s i o = \case Require _ -> s Update f -> f s i o Ensure _ -> s callbackEnsure1 :: state Concrete -> state Concrete -> input Concrete -> output -> Callback input output state -> Test () callbackEnsure1 s0 s i o = \case Require _ -> success Update _ -> success Ensure f -> f s0 s i o callbackRequire :: [Callback input output state] -> state Symbolic -> input Symbolic -> Bool callbackRequire callbacks s i = all (callbackRequire1 s i) callbacks callbackUpdate :: Ord1 v => [Callback input output state] -> state v -> input v -> Var output v -> state v callbackUpdate callbacks s0 i o = foldl (\s -> callbackUpdate1 s i o) s0 callbacks callbackEnsure :: [Callback input output state] -> state Concrete -> state Concrete -> input Concrete -> output -> Test () callbackEnsure callbacks s0 s i o = traverse_ (callbackEnsure1 s0 s i o) callbacks ------------------------------------------------------------------------ -- | The specification for the expected behaviour of an -- 'Action'. These are used to generate sequences of actions to test. -- -- This is the main type you will use when writing state machine -- tests. @gen@ is usually an instance of 'MonadGen', and @m@ is usually -- an instance of 'MonadTest'. These constraints appear when you pass -- your 'Command' list to 'sequential' or 'parallel'. -- data Command gen m (state :: (* -> *) -> *) = forall input output. (HTraversable input, Show (input Symbolic), Show output, Typeable output) => Command { -- | A generator which provides random arguments for a command. If the -- command cannot be executed in the current state, it should return -- 'Nothing'. -- commandGen :: state Symbolic -> Maybe (gen (input Symbolic)) -- | Executes a command using the arguments generated by 'commandGen'. -- , commandExecute :: input Concrete -> m output -- | A set of callbacks which provide optional command configuration such -- as pre-condtions, post-conditions and state updates. -- , commandCallbacks :: [Callback input output state] } -- | Checks that input for a command can be executed in the given state. -- commandGenOK :: Command gen m state -> state Symbolic -> Bool commandGenOK (Command inputGen _ _) state = Maybe.isJust (inputGen state) -- | An instantiation of a 'Command' which can be executed, and its effect -- evaluated. -- data Action m (state :: (* -> *) -> *) = forall input output. (HTraversable input, Show (input Symbolic), Show output) => Action { actionInput :: input Symbolic , actionOutput :: Symbolic output , actionExecute :: input Concrete -> m output , actionRequire :: state Symbolic -> input Symbolic -> Bool , actionUpdate :: forall v. Ord1 v => state v -> input v -> Var output v -> state v , actionEnsure :: state Concrete -> state Concrete -> input Concrete -> output -> Test () } instance Show (Action m state) where showsPrec p (Action input (Symbolic (Name output)) _ _ _ _) = showParen (p > 10) $ showString "Var " . showsPrec 11 output . showString " :<- " . showsPrec 11 input -- | Extract the variable name and the type from a symbolic value. -- takeSymbolic :: forall a. Symbolic a -> (Name, TypeRep) takeSymbolic (Symbolic name) = (name, typeRep (Proxy :: Proxy a)) -- | Insert a symbolic variable in to a map of variables to types. -- insertSymbolic :: Symbolic a -> Map Name TypeRep -> Map Name TypeRep insertSymbolic s = let (name, typ) = takeSymbolic s in Map.insert name typ -- | Collects all the symbolic values in a data structure and produces a set of -- all the variables they refer to. -- takeVariables :: forall t. HTraversable t => t Symbolic -> Map Name TypeRep takeVariables xs = let go x = do modify (insertSymbolic x) pure x in flip execState Map.empty $ htraverse go xs -- | Checks that the symbolic values in the data structure refer only to the -- variables in the provided set, and that they are of the correct type. -- variablesOK :: HTraversable t => t Symbolic -> Map Name TypeRep -> Bool variablesOK xs allowed = let vars = takeVariables xs in Map.null (vars `Map.difference` allowed) && and (Map.intersectionWith (==) vars allowed) data Context state = Context { contextState :: state Symbolic , _contextVars :: Map Name TypeRep } mkContext :: state Symbolic -> Context state mkContext initial = Context initial Map.empty contextUpdate :: MonadState (Context state) m => state Symbolic -> m () contextUpdate state = do Context _ vars <- get put $ Context state vars contextNewVar :: (MonadState (Context state) m, Typeable a) => m (Symbolic a) contextNewVar = do Context state vars <- get let var = case Map.maxViewWithKey vars of Nothing -> Symbolic 0 Just ((name, _), _) -> Symbolic (name + 1) put $ Context state (insertSymbolic var vars) pure var -- | Drops invalid actions from the sequence. -- dropInvalid :: [Action m state] -> State (Context state) [Action m state] dropInvalid = let loop step@(Action input output _execute require update _ensure) = do Context state0 vars0 <- get if require state0 input && variablesOK input vars0 then do let state = update state0 input (Var output) vars = insertSymbolic output vars0 put $ Context state vars pure $ Just step else pure Nothing in fmap Maybe.catMaybes . traverse loop -- | Generates a single action from a set of possible commands. -- action :: (MonadGen gen, MonadTest m) => [Command gen m state] -> GenT (StateT (Context state) (GenBase gen)) (Action m state) action commands = Gen.justT $ do Context state0 _ <- get Command mgenInput exec callbacks <- Gen.element $ filter (\c -> commandGenOK c state0) commands 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 not $ callbackRequire callbacks state0 input then pure Nothing else do output <- contextNewVar contextUpdate $ callbackUpdate callbacks state0 input (Var output) pure . Just $ Action input output exec (callbackRequire callbacks) (callbackUpdate callbacks) (callbackEnsure callbacks) genActions :: (MonadGen gen, MonadTest m) => Range Int -> [Command gen m state] -> Context state -> gen ([Action m state], Context state) genActions range commands ctx = do xs <- Gen.fromGenT . (`evalStateT` ctx) . distributeT $ Gen.list range (action commands) pure $ dropInvalid xs `runState` ctx -- | A sequence of actions to execute. -- data Sequential m state = Sequential { -- | The sequence of actions. sequentialActions :: [Action m state] } renderAction :: Action m state -> [String] renderAction (Action input (Symbolic (Name output)) _ _ _ _) = let prefix0 = "Var " ++ show output ++ " = " prefix = replicate (length prefix0) ' ' in case lines (showPretty input) of [] -> [prefix0 ++ "?"] x : xs -> (prefix0 ++ x) : fmap (prefix ++) xs renderActionResult :: Environment -> Action m state -> [String] renderActionResult env (Action _ output@(Symbolic (Name name)) _ _ _ _) = let prefix0 = "Var " ++ show name ++ " = " prefix = replicate (length prefix0) ' ' unfound = \case EnvironmentValueNotFound _ -> "<>" EnvironmentTypeError _ _ -> "<>" actual = either unfound showPretty $ reifyEnvironment env output in case lines actual of [] -> [prefix0 ++ "?"] x : xs -> (prefix0 ++ x) : fmap (prefix ++) xs -- FIXME we should not abuse Show to get nice output for actions instance Show (Sequential m state) where show (Sequential xs) = unlines $ concatMap renderAction xs -- | Generates a sequence of actions from an initial model state and set of commands. -- sequential :: (MonadGen gen, MonadTest m) => Range Int -> (forall v. state v) -> [Command gen m state] -> gen (Sequential m state) sequential range initial commands = fmap (Sequential . fst) $ genActions range commands (mkContext initial) -- | A sequential prefix of actions to execute, with two branches to execute in parallel. -- data Parallel m state = Parallel { -- | The sequential prefix. parallelPrefix :: [Action m state] -- | The first branch. , parallelBranch1 :: [Action m state] -- | The second branch. , parallelBranch2 :: [Action m state] } -- FIXME we should not abuse Show to get nice output for actions instance Show (Parallel m state) where show = renderParallel renderAction renderParallel :: (Action m state -> [String]) -> Parallel m state -> String renderParallel render (Parallel pre xs ys) = unlines $ concat [ ["━━━ Prefix ━━━"] , concatMap render pre , ["", "━━━ Branch 1 ━━━"] , concatMap render xs , ["", "━━━ Branch 2 ━━━"] , concatMap render ys ] -- | Given the initial model state and set of commands, generates prefix -- actions to be run sequentially, followed by two branches to be run in -- parallel. -- parallel :: (MonadGen gen, MonadTest m) => Range Int -> Range Int -> (forall v. state v) -> [Command gen m state] -> gen (Parallel m state) parallel prefixN parallelN initial commands = do (prefix, ctx0) <- genActions prefixN commands (mkContext initial) (branch1, ctx1) <- genActions parallelN commands ctx0 (branch2, _ctx2) <- genActions parallelN commands ctx1 { contextState = contextState ctx0 } pure $ Parallel prefix branch1 branch2 data ActionCheck state = ActionCheck { checkUpdate :: state Concrete -> state Concrete , checkEnsure :: state Concrete -> state Concrete -> Test () } execute :: (MonadTest m, HasCallStack) => Action m state -> StateT Environment m (ActionCheck state) execute (Action sinput soutput exec _require update ensure) = withFrozenCallStack $ do env0 <- get input <- evalEither $ reify env0 sinput output <- lift $ exec input let coutput = Concrete output env = insertConcrete soutput coutput env0 put env pure $ ActionCheck (\s0 -> update s0 input (Var coutput)) (\s0 s -> ensure s0 s input output) -- | Executes a single action in the given evironment. -- executeUpdateEnsure :: (MonadTest m, HasCallStack) => (state Concrete, Environment) -> Action m state -> m (state Concrete, Environment) executeUpdateEnsure (state0, env0) (Action sinput soutput exec _require update ensure) = withFrozenCallStack $ do input <- evalEither $ reify env0 sinput output <- exec input let coutput = Concrete output state = update state0 input (Var coutput) env = insertConcrete soutput coutput env0 liftTest $ ensure state0 state input output pure (state, env) -- | Executes a list of actions sequentially, verifying that all -- post-conditions are met and no exceptions are thrown. -- -- To generate a sequence of actions to execute, see the -- 'Hedgehog.Gen.sequential' combinator in the "Hedgehog.Gen" module. -- executeSequential :: (MonadTest m, MonadCatch m, HasCallStack) => (forall v. state v) -> Sequential m state -> m () executeSequential initial (Sequential xs) = withFrozenCallStack $ evalM $ foldM_ executeUpdateEnsure (initial, emptyEnvironment) xs successful :: Test () -> Bool successful x = case runTest x of (Left _, _) -> False (Right _, _) -> True interleave :: [a] -> [a] -> [[a]] interleave xs00 ys00 = case (xs00, ys00) of ([], []) -> [] (xs, []) -> [xs] ([], ys) -> [ys] (xs0@(x:xs), ys0@(y:ys)) -> [ x : zs | zs <- interleave xs ys0 ] ++ [ y : zs | zs <- interleave xs0 ys ] checkActions :: state Concrete -> [ActionCheck state] -> Test () checkActions s0 = \case [] -> pure () x : xs -> do let s = checkUpdate x s0 checkEnsure x s0 s checkActions s xs linearize :: MonadTest m => state Concrete -> [ActionCheck state] -> [ActionCheck state] -> m () linearize initial branch1 branch2 = withFrozenCallStack $ let ok = any successful . fmap (checkActions initial) $ interleave branch1 branch2 in if ok then pure () else failWith Nothing "no valid interleaving" -- | Executes the prefix actions sequentially, then executes the two branches -- in parallel, verifying that no exceptions are thrown and that there is at -- least one sequential interleaving where all the post-conditions are met. -- -- To generate parallel actions to execute, see the 'Hedgehog.Gen.parallel' -- combinator in the "Hedgehog.Gen" module. -- executeParallel :: (MonadTest m, MonadCatch m, MonadBaseControl IO m, HasCallStack) => (forall v. state v) -> Parallel m state -> m () executeParallel initial p@(Parallel prefix branch1 branch2) = withFrozenCallStack $ evalM $ do (s0, env0) <- foldM executeUpdateEnsure (initial, emptyEnvironment) prefix ((xs, env1), (ys, env2)) <- Async.concurrently (runStateT (traverse execute branch1) env0) (runStateT (traverse execute branch2) env0) let env = unionsEnvironment [env0, env1, env2] annotate $ renderParallel (renderActionResult env) p linearize s0 xs ys hedgehog-1.0.3/src/Hedgehog/Internal/TH.hs0000644060175106010010000000325113675330725017453 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} module Hedgehog.Internal.TH ( TExpQ , discover , discoverPrefix ) where import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Ord as Ord import Hedgehog.Internal.Discovery import Hedgehog.Internal.Property import Language.Haskell.TH (Exp(..), Q, TExp, location, runIO) import Language.Haskell.TH.Syntax (Loc(..), mkName, unTypeQ, unsafeTExpCoerce) type TExpQ a = Q (TExp a) -- | Discover all the properties in a module. -- -- Functions starting with `prop_` are assumed to be properties. -- discover :: TExpQ Group discover = discoverPrefix "prop_" discoverPrefix :: String -> TExpQ Group discoverPrefix prefix = do file <- getCurrentFile properties <- Map.toList <$> runIO (readProperties prefix file) let startLine = Ord.comparing $ posLine . posPostion . propertySource . snd names = fmap (mkNamedProperty . fst) $ List.sortBy startLine properties [|| Group $$(moduleName) $$(listTE names) ||] mkNamedProperty :: PropertyName -> TExpQ (PropertyName, Property) mkNamedProperty name = do [|| (name, $$(unsafeProperty name)) ||] unsafeProperty :: PropertyName -> TExpQ Property unsafeProperty = unsafeTExpCoerce . pure . VarE . mkName . unPropertyName listTE :: [TExpQ a] -> TExpQ [a] listTE xs = do unsafeTExpCoerce . pure . ListE =<< traverse unTypeQ xs moduleName :: TExpQ GroupName moduleName = do loc <- GroupName . loc_module <$> location [|| loc ||] getCurrentFile :: Q FilePath getCurrentFile = loc_filename <$> location hedgehog-1.0.3/src/Hedgehog/Internal/Tree.hs0000644060175106010010000004261713675330725020050 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- MonadBase #if __GLASGOW_HASKELL__ < 802 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} #endif module Hedgehog.Internal.Tree ( Tree , pattern Tree , TreeT(..) , runTree , mapTreeT , treeValue , treeChildren , Node , pattern Node , NodeT(..) , fromNodeT , unfold , unfoldForest , expand , prune , catMaybes , filter , mapMaybe , filterMaybeT , mapMaybeMaybeT , filterT , mapMaybeT , depth , interleave , render , renderT ) where import Control.Applicative (Alternative(..), liftA2) import Control.Monad (MonadPlus(..), guard, join) import Control.Monad.Base (MonadBase(..)) 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) import Control.Monad.Primitive (PrimMonad(..)) import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Resource (MonadResource(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Zip (MonadZip(..)) import Data.Functor.Identity (Identity(..)) import Data.Functor.Classes (Eq1(..)) import Data.Functor.Classes (Show1(..), showsPrec1) import Data.Functor.Classes (showsUnaryWith, showsBinaryWith) import qualified Data.List as List import qualified Data.Maybe as Maybe import Hedgehog.Internal.Distributive import Control.Monad.Trans.Control (MonadBaseControl (..)) import Prelude hiding (filter) ------------------------------------------------------------------------ -- | A rose tree. -- type Tree = TreeT Identity -- | Pattern to ease construction / deconstruction of pure trees. -- pattern Tree :: NodeT Identity a -> Tree a pattern Tree node = TreeT (Identity node) #if __GLASGOW_HASKELL__ >= 802 {-# COMPLETE Tree #-} #endif -- | An effectful tree, each node in the tree can have an effect before it is -- produced. -- newtype TreeT m a = TreeT { runTreeT :: m (NodeT m a) } instance MonadBaseControl b m => MonadBaseControl b (TreeT m) where type StM (TreeT m) a = StM m (NodeT m a) liftBaseWith f = TreeT $ liftBaseWith (\g -> pure <$> f (g . runTreeT)) restoreM = TreeT . restoreM -- | A node in a rose tree. -- type Node = NodeT Identity #if __GLASGOW_HASKELL__ >= 802 {-# COMPLETE Node #-} #endif -- | Pattern to ease construction / deconstruction of pure nodes. -- pattern Node :: a -> [Tree a] -> Node a pattern Node x xs = NodeT x xs -- | A node in an effectful tree, as well as its unevaluated children. -- data NodeT m a = NodeT { -- | The value at this 'NodeT' in the 'TreeT'. nodeValue :: a -- | The children of this 'NodeT'. , nodeChildren :: [TreeT m a] } deriving (Eq) -- | Extracts the 'Node' from a 'Tree'. -- runTree :: Tree a -> Node a runTree = runIdentity . runTreeT -- | Map between 'TreeT' computations. -- mapTreeT :: (m (NodeT m a) -> m (NodeT m a)) -> TreeT m a -> TreeT m a mapTreeT f = TreeT . f . runTreeT -- | Create a 'TreeT' from a 'NodeT' -- fromNodeT :: Applicative m => NodeT m a -> TreeT m a fromNodeT = TreeT . pure -- | The value at the root of the 'Tree'. -- treeValue :: Tree a -> a treeValue = nodeValue . runTree -- | The children of the 'Tree'. -- treeChildren :: Tree a -> [Tree a] treeChildren = nodeChildren . runTree -- | Create a tree from a value and an unfolding function. -- unfold :: Monad m => (a -> [a]) -> a -> TreeT m a unfold f x = TreeT . pure $ NodeT x (unfoldForest f x) -- | Create a forest from a value and an unfolding function. -- unfoldForest :: Monad m => (a -> [a]) -> a -> [TreeT m a] unfoldForest f = fmap (unfold f) . f -- | Expand a tree using an unfolding function. -- expand :: Monad m => (a -> [a]) -> TreeT m a -> TreeT m a expand f m = TreeT $ do NodeT x xs <- runTreeT m pure . NodeT x $ fmap (expand f) xs ++ unfoldForest f x -- | Throw away @n@ levels of a tree's children. -- -- /@prune 0@ will throw away all of a tree's children./ -- prune :: Monad m => Int -> TreeT m a -> TreeT m a prune n m = if n <= 0 then TreeT $ do NodeT x _ <- runTreeT m pure $ NodeT x [] else TreeT $ do NodeT x xs0 <- runTreeT m pure . NodeT x $ fmap (prune (n - 1)) xs0 -- | Returns the depth of the deepest leaf node in the tree. -- depth :: Tree a -> Int depth m = let NodeT _ xs = runTree m n = if null xs then 0 else maximum (fmap depth xs) in 1 + n -- | Takes a tree of 'Maybe's and returns a tree of all the 'Just' values. -- -- If the root of the tree is 'Nothing' then 'Nothing' is returned. -- catMaybes :: Tree (Maybe a) -> Maybe (Tree a) catMaybes m = let NodeT mx mxs = runTree m in case mx of Nothing -> do case Maybe.mapMaybe catMaybes mxs of [] -> Nothing Tree (NodeT x xs0) : xs1 -> Just . Tree $ Node x (xs0 ++ xs1) Just x -> Just . Tree $ Node x (Maybe.mapMaybe catMaybes mxs) fromPred :: (a -> Bool) -> a -> Maybe a fromPred p a = a <$ guard (p a) -- | Returns a tree containing only elements that match the predicate. -- -- If the root of the tree does not match the predicate then 'Nothing' is -- returned. -- filter :: (a -> Bool) -> Tree a -> Maybe (Tree a) filter p = mapMaybe (fromPred p) mapMaybe :: (a -> Maybe b) -> Tree a -> Maybe (Tree b) mapMaybe p = catMaybes . runTreeMaybeT . mapMaybeMaybeT p . hoist lift runTreeMaybeT :: Monad m => TreeT (MaybeT m) a -> TreeT m (Maybe a) runTreeMaybeT = runMaybeT . distributeT -- | Returns a tree containing only elements that match the predicate. -- -- If the root of the tree does not match the predicate then 'Nothing' is -- returned. -- filterMaybeT :: (a -> Bool) -> TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) a filterMaybeT p = mapMaybeMaybeT (fromPred p) mapMaybeMaybeT :: (a -> Maybe b) -> TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) b mapMaybeMaybeT p t = case runTreeMaybeT t of Tree (Node Nothing _) -> TreeT . MaybeT . Identity $ Nothing Tree (Node (Just x) xs) -> case p x of Nothing -> TreeT . MaybeT . Identity $ Nothing Just x' -> hoist generalize $ Tree . Node x' $ concatMap (flattenTree p) xs flattenTree :: (a -> Maybe b) -> Tree (Maybe a) -> [Tree b] flattenTree p (Tree (Node mx mxs0)) = let mxs = concatMap (flattenTree p) mxs0 in case mx of Nothing -> mxs Just x -> case p x of Just x' -> [Tree (Node x' mxs)] Nothing -> mxs -- | Returns a tree containing only elements that match the predicate. -- -- When an element does not match the predicate its node is replaced with -- 'empty'. -- filterT :: (Monad m, Alternative m) => (a -> Bool) -> TreeT m a -> TreeT m a filterT p = mapMaybeT (fromPred p) mapMaybeT :: (Monad m, Alternative m) => (a -> Maybe b) -> TreeT m a -> TreeT m b mapMaybeT p m = TreeT $ do NodeT x xs <- runTreeT m case p x of Just x' -> pure $ NodeT x' (fmap (mapMaybeT p) xs) Nothing -> empty ------------------------------------------------------------------------ -- | All ways a list can be split -- -- > splits [1,2,3] -- > == -- > [ ([], 1, [2, 3]) -- , ([1], 2, [3]) -- , ([1, 2], 3, []) -- ] -- splits :: [a] -> [([a], a, [a])] splits xs0 = let go (front : fronts) (x : xs) = (front, x, xs) : go fronts xs go _ _ = [] in go (List.inits xs0) xs0 -- | @removes n@ computes all ways we can remove chunks of size @n@ from a list -- -- Examples -- -- > removes 1 [1..3] == [[2,3],[1,3],[1,2]] -- > removes 2 [1..4] == [[3,4],[1,2]] -- > removes 2 [1..5] == [[3,4,5],[1,2,5],[1,2,3,4]] -- > removes 3 [1..5] == [[4,5],[1,2,3]] -- -- Note that the last chunk we delete might have fewer elements than @n@. removes :: forall a. Int -> [a] -> [[a]] removes k = \xs -> go xs where go :: [a] -> [[a]] go [] = [] go xs = xs2 : map (xs1 ++) (go xs2) where (xs1, xs2) = splitAt k xs dropSome :: Monad m => [NodeT m a] -> [TreeT m [a]] dropSome ts = do n <- takeWhile (> 0) $ iterate (`div` 2) (length ts) ts' <- removes n ts pure . TreeT . pure $ interleave ts' shrinkOne :: Monad m => [NodeT m a] -> [TreeT m [a]] shrinkOne ts = do (xs, y0, zs) <- splits ts y1 <- nodeChildren y0 pure . TreeT $ do y2 <- runTreeT y1 pure $ interleave (xs ++ [y2] ++ zs) interleave :: forall m a. Monad m => [NodeT m a] -> NodeT m [a] interleave ts = NodeT (fmap nodeValue ts) $ concat [ dropSome ts , shrinkOne ts ] ------------------------------------------------------------------------ instance Foldable Tree where foldMap f (TreeT mx) = foldMap f (runIdentity mx) instance Foldable Node where foldMap f (NodeT x xs) = f x `mappend` mconcat (fmap (foldMap f) xs) instance Traversable Tree where traverse f (TreeT mx) = TreeT <$> traverse (traverse f) mx instance Traversable Node where traverse f (NodeT x xs) = NodeT <$> f x <*> traverse (traverse f) xs ------------------------------------------------------------------------ -- NodeT/TreeT instances instance (Eq1 m, Eq a) => Eq (TreeT m a) where TreeT m0 == TreeT m1 = liftEq (==) m0 m1 instance Functor m => Functor (NodeT m) where fmap f (NodeT x xs) = NodeT (f x) (fmap (fmap f) xs) instance Functor m => Functor (TreeT m) where fmap f = TreeT . fmap (fmap f) . runTreeT instance Applicative m => Applicative (NodeT m) where pure x = NodeT x [] (<*>) (NodeT ab tabs) na@(NodeT a tas) = NodeT (ab a) $ map (<*> (fromNodeT na)) tabs ++ map (fmap ab) tas instance Applicative m => Applicative (TreeT m) where pure = TreeT . pure . pure (<*>) (TreeT mab) (TreeT ma) = TreeT $ liftA2 (<*>) mab ma instance Monad m => Monad (NodeT m) where return = pure (>>=) (NodeT x xs) k = case k x of NodeT y ys -> NodeT y $ fmap (TreeT . fmap (>>= k) . runTreeT) xs ++ ys instance Monad m => Monad (TreeT m) where return = pure (>>=) m k = TreeT $ do NodeT x xs <- runTreeT m NodeT y ys <- runTreeT (k x) pure . NodeT y $ fmap (>>= k) xs ++ ys instance Alternative m => Alternative (TreeT m) where empty = TreeT empty (<|>) x y = TreeT (runTreeT x <|> runTreeT y) instance MonadPlus m => MonadPlus (TreeT m) where mzero = TreeT mzero mplus x y = TreeT (runTreeT x `mplus` runTreeT y) zipTreeT :: forall f a b. Applicative f => TreeT f a -> TreeT f b -> TreeT f (a, b) zipTreeT l0@(TreeT left) r0@(TreeT right) = TreeT $ let zipNodeT :: NodeT f a -> NodeT f b -> NodeT f (a, b) zipNodeT (NodeT a ls) (NodeT b rs) = NodeT (a, b) $ concat [ [zipTreeT l1 r0 | l1 <- ls] , [zipTreeT l0 r1 | r1 <- rs] ] in zipNodeT <$> left <*> right instance Monad m => MonadZip (TreeT m) where mzip = zipTreeT instance MonadTrans TreeT where lift f = TreeT $ fmap (\x -> NodeT x []) f instance MFunctor NodeT where hoist f (NodeT x xs) = NodeT x (fmap (hoist f) xs) instance MFunctor TreeT where hoist f (TreeT m) = TreeT . f $ fmap (hoist f) m embedNodeT :: Monad m => (t (NodeT t b) -> TreeT m (NodeT t b)) -> NodeT t b -> NodeT m b embedNodeT f (NodeT x xs) = NodeT x (fmap (embedTreeT f) xs) embedTreeT :: Monad m => (t (NodeT t b) -> TreeT m (NodeT t b)) -> TreeT t b -> TreeT m b embedTreeT f (TreeT m) = TreeT . pure . embedNodeT f =<< f m instance MMonad TreeT where embed f m = embedTreeT f m distributeNodeT :: Transformer t TreeT m => NodeT (t m) a -> t (TreeT m) a distributeNodeT (NodeT x xs) = join . lift . fromNodeT . NodeT (pure x) $ fmap (pure . distributeTreeT) xs distributeTreeT :: Transformer t TreeT m => TreeT (t m) a -> t (TreeT m) a distributeTreeT x = distributeNodeT =<< hoist lift (runTreeT x) instance MonadTransDistributive TreeT where distributeT = distributeTreeT instance PrimMonad m => PrimMonad (TreeT m) where type PrimState (TreeT m) = PrimState m primitive = lift . primitive instance MonadIO m => MonadIO (TreeT m) where liftIO = lift . liftIO instance MonadBase b m => MonadBase b (TreeT m) where liftBase = lift . liftBase instance MonadThrow m => MonadThrow (TreeT m) where throwM = lift . throwM handleNodeT :: (Exception e, MonadCatch m) => (e -> TreeT m a) -> NodeT m a -> NodeT m a handleNodeT onErr (NodeT x xs) = NodeT x $ fmap (handleTreeT onErr) xs handleTreeT :: (Exception e, MonadCatch m) => (e -> TreeT m a) -> TreeT m a -> TreeT m a handleTreeT onErr m = TreeT . fmap (handleNodeT onErr) $ catch (runTreeT m) (runTreeT . onErr) instance MonadCatch m => MonadCatch (TreeT m) where catch = flip handleTreeT localNodeT :: MonadReader r m => (r -> r) -> NodeT m a -> NodeT m a localNodeT f (NodeT x xs) = NodeT x $ fmap (localTreeT f) xs localTreeT :: MonadReader r m => (r -> r) -> TreeT m a -> TreeT m a localTreeT f (TreeT m) = TreeT $ pure . localNodeT f =<< local f m instance MonadReader r m => MonadReader r (TreeT m) where ask = lift ask local = localTreeT instance MonadState s m => MonadState s (TreeT m) where get = lift get put = lift . put state = lift . state listenNodeT :: MonadWriter w m => w -> NodeT m a -> NodeT m (a, w) listenNodeT w (NodeT x xs) = NodeT (x, w) $ fmap (listenTreeT w) xs listenTreeT :: MonadWriter w m => w -> TreeT m a -> TreeT m (a, w) listenTreeT w0 (TreeT m) = TreeT $ do (x, w) <- listen m pure $ listenNodeT (mappend w0 w) x -- FIXME This just throws away the writer modification function. passNodeT :: MonadWriter w m => NodeT m (a, w -> w) -> NodeT m a passNodeT (NodeT (x, _) xs) = NodeT x $ fmap passTreeT xs passTreeT :: MonadWriter w m => TreeT m (a, w -> w) -> TreeT m a passTreeT (TreeT m) = TreeT $ pure . passNodeT =<< m instance MonadWriter w m => MonadWriter w (TreeT m) where writer = lift . writer tell = lift . tell listen = listenTreeT mempty pass = passTreeT handleErrorNodeT :: MonadError e m => (e -> TreeT m a) -> NodeT m a -> NodeT m a handleErrorNodeT onErr (NodeT x xs) = NodeT x $ fmap (handleErrorTreeT onErr) xs handleErrorTreeT :: MonadError e m => (e -> TreeT m a) -> TreeT m a -> TreeT m a handleErrorTreeT onErr m = TreeT . fmap (handleErrorNodeT onErr) $ catchError (runTreeT m) (runTreeT . onErr) instance MonadError e m => MonadError e (TreeT m) where throwError = lift . throwError catchError = flip handleErrorTreeT instance MonadResource m => MonadResource (TreeT m) where liftResourceT = lift . liftResourceT ------------------------------------------------------------------------ -- Show/Show1 instances instance (Show1 m, Show a) => Show (NodeT m a) where showsPrec = showsPrec1 instance (Show1 m, Show a) => Show (TreeT m a) where showsPrec = showsPrec1 instance Show1 m => Show1 (NodeT m) where liftShowsPrec sp sl d (NodeT x xs) = let sp1 = liftShowsPrec sp sl sl1 = liftShowList sp sl sp2 = liftShowsPrec sp1 sl1 in showsBinaryWith sp sp2 "NodeT" d x xs instance Show1 m => Show1 (TreeT m) where liftShowsPrec sp sl d (TreeT m) = let sp1 = liftShowsPrec sp sl sl1 = liftShowList sp sl sp2 = liftShowsPrec sp1 sl1 in showsUnaryWith sp2 "TreeT" d m ------------------------------------------------------------------------ -- Pretty Printing -- -- Rendering implementation based on the one from containers/Data.Tree -- renderTreeTLines :: Monad m => TreeT m String -> m [String] renderTreeTLines (TreeT m) = do NodeT x xs0 <- m xs <- renderForestLines xs0 pure $ lines (renderNodeT x) ++ xs renderNodeT :: String -> String renderNodeT xs = case xs of [_] -> ' ' : xs _ -> xs renderForestLines :: Monad m => [TreeT m String] -> m [String] renderForestLines xs0 = let shift hd other = zipWith (++) (hd : repeat other) in case xs0 of [] -> pure [] [x] -> do s <- renderTreeTLines x pure $ shift " └╼" " " s x : xs -> do s <- renderTreeTLines x ss <- renderForestLines xs pure $ shift " ├╼" " │ " s ++ ss -- | Render a tree of strings. -- render :: Tree String -> String render = runIdentity . renderT -- | Render a tree of strings, note that this forces all the delayed effects in -- the tree. -- renderT :: Monad m => TreeT m String -> m String renderT = fmap unlines . renderTreeTLines hedgehog-1.0.3/src/Hedgehog/Internal/Tripping.hs0000644060175106010010000000342513675330725020737 0ustar00Nikos00000000000000{-# OPTIONS_HADDOCK not-home #-} module Hedgehog.Internal.Tripping ( tripping ) where import Hedgehog.Internal.Property (MonadTest, Diff(..), success, failWith) import Hedgehog.Internal.Show (valueDiff, mkValue, showPretty) import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack) -- | Test that a pair of encode / decode functions are compatible. -- -- Given a printer from some type 'a -> b', and a parser with a -- potential failure case 'b -> f a'. Ensure that a valid 'a' round -- trips through the "print" and "parse" to yield the same 'a'. -- -- For example, types __should__ have tripping 'Read' and 'Show' -- instances. -- -- @ -- trippingShowRead :: (Show a, Read a, Eq a, MonadTest m) => a -> m () -- trippingShowRead a = tripping a show readEither -- @ tripping :: (MonadTest m, Applicative f, Show b, Show (f a), Eq (f a), HasCallStack) => a -> (a -> b) -> (b -> f a) -> m () tripping x encode decode = let mx = pure x i = encode x my = decode i in if mx == my then success else case valueDiff <$> mkValue mx <*> mkValue my of Nothing -> withFrozenCallStack $ failWith Nothing $ unlines [ "━━━ Original ━━━" , showPretty mx , "━━━ Intermediate ━━━" , showPretty i , "━━━ Roundtrip ━━━" , showPretty my ] Just diff -> withFrozenCallStack $ failWith (Just $ Diff "━━━ " "- Original" ") (" "+ Roundtrip" " ━━━" diff) $ unlines [ "━━━ Intermediate ━━━" , showPretty i ] hedgehog-1.0.3/src/Hedgehog/Main.hs0000644060175106010010000000076513675330725016257 0ustar00Nikos00000000000000module Hedgehog.Main ( -- * Running tests defaultMain ) where import Control.Monad (unless) import System.Exit (exitFailure) import System.IO (BufferMode (LineBuffering), hSetBuffering, stderr, stdout) -- | An entry point that can be used as a main function. -- defaultMain :: [IO Bool] -> IO () defaultMain tests = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering result <- and <$> sequence tests unless result exitFailure hedgehog-1.0.3/src/Hedgehog/Range.hs0000644060175106010010000000101013675330725016407 0ustar00Nikos00000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hedgehog.Range ( -- * Size Size(..) -- * Range , Range , origin , bounds , lowerBound , upperBound -- * Constant , singleton , constant , constantFrom , constantBounded -- * Linear , linear , linearFrom , linearFrac , linearFracFrom , linearBounded -- * Exponential , exponential , exponentialFrom , exponentialBounded , exponentialFloat , exponentialFloatFrom ) where import Hedgehog.Internal.Range hedgehog-1.0.3/src/Hedgehog.hs0000644060175106010010000001141213675330725015362 0ustar00Nikos00000000000000-- | -- This module includes almost everything you need to get started writing -- property tests with Hedgehog. -- -- It is designed to be used alongside "Hedgehog.Gen" and "Hedgehog.Range", -- which should be imported qualified. You also need to enable Template Haskell -- so the Hedgehog test runner can find your properties. -- -- > {-# LANGUAGE TemplateHaskell #-} -- > -- > import Hedgehog -- > import qualified Hedgehog.Gen as Gen -- > import qualified Hedgehog.Range as Range -- -- Once you have your imports set up, you can write a simple property: -- -- > prop_reverse :: Property -- > prop_reverse = -- > property $ do -- > xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha -- > reverse (reverse xs) === xs -- -- And add the Template Haskell splice which will discover your properties: -- -- > tests :: IO Bool -- > tests = -- > checkParallel $$(discover) -- -- If you prefer to avoid macros, you can specify the group of properties to -- run manually instead: -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > tests :: IO Bool -- > tests = -- > checkParallel $ Group "Test.Example" [ -- > ("prop_reverse", prop_reverse) -- > ] -- -- You can then load the module in GHCi, and run it: -- -- > λ tests -- > ━━━ Test.Example ━━━ -- > ✓ prop_reverse passed 100 tests. -- module Hedgehog ( -- * Properties Property , PropertyT , Group(..) , PropertyName , GroupName , property , test , forAll , forAllWith , discard , check , recheck , discover , discoverPrefix , checkParallel , checkSequential , Confidence , verifiedTermination , withConfidence , withTests , TestLimit , withDiscards , DiscardLimit , withShrinks , ShrinkLimit , withRetries , ShrinkRetries -- * Generating Test Data , Gen , GenT , MonadGen(..) , Range , Size(..) , Seed(..) -- * Tests , Test , TestT , MonadTest(..) , annotate , annotateShow , footnote , footnoteShow , success , failure , assert , diff , (===) , (/==) , tripping , eval , evalNF , evalM , evalIO , evalEither , evalExceptT -- * Coverage , LabelName , classify , cover , label , collect -- * State Machine Tests , Command(..) , Callback(..) , Action , Sequential(..) , Parallel(..) , executeSequential , executeParallel , Var(..) , concrete , opaque , Symbolic , Concrete(..) , Opaque(..) -- * Transformers , distributeT -- * Functors , HTraversable(..) , Eq1 , eq1 , Ord1 , compare1 , Show1 , showsPrec1 ) where import Data.Functor.Classes (Eq1, eq1, Ord1, compare1, Show1, showsPrec1) import Hedgehog.Internal.Distributive (distributeT) import Hedgehog.Internal.Gen (Gen, GenT, MonadGen(..)) import Hedgehog.Internal.HTraversable (HTraversable(..)) import Hedgehog.Internal.Opaque (Opaque(..)) import Hedgehog.Internal.Property (annotate, annotateShow) import Hedgehog.Internal.Property (assert, diff, (===), (/==)) import Hedgehog.Internal.Property (classify, cover) import Hedgehog.Internal.Property (discard, failure, success) import Hedgehog.Internal.Property (DiscardLimit, withDiscards) import Hedgehog.Internal.Property (eval, evalNF, evalM, evalIO) import Hedgehog.Internal.Property (evalEither, evalExceptT) import Hedgehog.Internal.Property (footnote, footnoteShow) import Hedgehog.Internal.Property (forAll, forAllWith) import Hedgehog.Internal.Property (LabelName, MonadTest(..)) import Hedgehog.Internal.Property (Property, PropertyT, PropertyName) import Hedgehog.Internal.Property (Group(..), GroupName) import Hedgehog.Internal.Property (Confidence, verifiedTermination, withConfidence) import Hedgehog.Internal.Property (ShrinkLimit, withShrinks) import Hedgehog.Internal.Property (ShrinkRetries, withRetries) 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.Seed (Seed(..)) import Hedgehog.Internal.State (Command(..), Callback(..)) import Hedgehog.Internal.State (Action, Sequential(..), Parallel(..)) import Hedgehog.Internal.State (executeSequential, executeParallel) import Hedgehog.Internal.State (Var(..), Symbolic, Concrete(..), concrete, opaque) import Hedgehog.Internal.TH (discover, discoverPrefix) import Hedgehog.Internal.Tripping (tripping) hedgehog-1.0.3/test/0000755060175106010010000000000013675361065013506 5ustar00Nikos00000000000000hedgehog-1.0.3/test/Test/0000755060175106010010000000000013675330725014424 5ustar00Nikos00000000000000hedgehog-1.0.3/test/Test/Hedgehog/0000755060175106010010000000000013675361065016137 5ustar00Nikos00000000000000hedgehog-1.0.3/test/Test/Hedgehog/Applicative.hs0000644060175106010010000000423013675330725020732 0ustar00Nikos00000000000000{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} module Test.Hedgehog.Applicative where import Control.Monad.Morph (hoist) import Control.Monad.State.Class (MonadState(..), modify) import qualified Control.Monad.Trans.State.Lazy as Lazy import Data.Foldable (traverse_) import qualified Data.List as List import qualified Data.Map as Map import Hedgehog hiding (Command, Var) import qualified Hedgehog.Range as Range import qualified Hedgehog.Internal.Gen as Gen import qualified Hedgehog.Internal.Tree as Tree newtype Var = Var Int deriving (Eq, Ord, Show) data Command = Add | Remove deriving (Eq, Ord, Show) data a :<- b = a :<- b deriving (Eq, Ord, Show) takeVar :: a :<- b -> a takeVar (var :<- _) = var genVar :: (MonadState Int m, MonadGen m) => m Var genVar = do modify (+1) Var <$> get genCommand :: MonadGen m => m Command genCommand = Gen.element [Add, Remove] genCommands :: (MonadState Int m, MonadGen m) => m [Var :<- Command] genCommands = Gen.list (Range.constant 0 3) $ do var <- genVar cmd <- genCommand pure $ var :<- cmd -- | Uncomment to observe invalid Applicative behaviour -- -- /This actually also works, if you comment out the ApplicativeDo above./ -- xprop_StateT_inside :: Property xprop_StateT_inside = propVars $ hoist (`Lazy.evalStateT` 0) genCommands prop_StateT_outside :: Property prop_StateT_outside = propVars . (`Lazy.evalStateT` 0) $ distributeT genCommands propVars :: Gen [Var :<- Command] -> Property propVars gen = property $ do let tree <- forAllWith (Tree.render . fmap show . Tree.prune 3) $ Gen.toTree gen let noDuplicates xs = let sorted = List.sort xs unique = Map.elems (Map.fromList (fmap (\x -> (takeVar x, x)) xs)) varsEq ys zs = fmap takeVar ys == fmap takeVar zs in diff sorted varsEq unique traverse_ noDuplicates tree tests :: IO Bool tests = checkParallel $$(discover) hedgehog-1.0.3/test/Test/Hedgehog/Confidence.hs0000644060175106010010000000151713675330725020533 0ustar00Nikos00000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Test.Hedgehog.Confidence where import Hedgehog import qualified Hedgehog.Range as Range import qualified Hedgehog.Internal.Gen as Gen confidence :: Confidence confidence = 10 ^ (9 :: Int) prop_with_confidence :: Property prop_with_confidence = verifiedTermination . withConfidence confidence . property $ do number <- forAll (Gen.int $ Range.linear 1 10) cover 20 "number == 1" $ number == 1 -- This tests that at least 1000 tests are run for the property prop_with_confidence_and_min_tests :: Property prop_with_confidence_and_min_tests = withConfidence confidence . withTests 1000 . property $ do number <- forAll (Gen.int $ Range.linear 1 10) cover 10 "number == 2" $ number == 2 tests :: IO Bool tests = checkParallel $$(discover) hedgehog-1.0.3/test/Test/Hedgehog/Filter.hs0000644060175106010010000000431513675330725017722 0ustar00Nikos00000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} module Test.Hedgehog.Filter where import Data.Foldable (toList) import qualified Data.Set as Set import Hedgehog import qualified Hedgehog.Range as Range import qualified Hedgehog.Internal.Gen as Gen import Hedgehog.Internal.Tree (NodeT(..)) import qualified Hedgehog.Internal.Tree as Tree -- | Prevent this bug from returning: -- -- https://stackoverflow.com/questions/54412108/why-the-does-this-shrink-tree-looks-the-way-it-does-when-using-filter -- -- I'm trying to understand what is the effect that filter has in the shrink -- tree of a generator when using _integrated shrinking_. -- -- Consider the following function: -- -- @ -- {-# LANGUAGE OverloadedStrings #-} -- -- import Hedgehog -- import qualified Hedgehog.Gen as Gen -- -- genChar:: Gen Char -- genChar = -- Gen.filter (`elem` ("x" :: String)) (Gen.element "yx") -- -- @ -- -- When a print the shrink tree: -- -- @ -- >>> Gen.printTree genChar -- @ -- -- I'd get shrink trees that look as follow: -- -- @ -- 'x' -- └╼'x' -- └╼'x' -- └╼'x' -- ... -- -- └╼ -- @ -- -- This is, a very deep tree containing only @x@'s, and a @discard@ at the -- end. -- prop_filter_repetition :: Property prop_filter_repetition = property $ do let genChar:: Gen Char genChar = Gen.filter (`elem` ("x" :: String)) (Gen.element "yx") tree <- forAllWith (Tree.render . fmap show . Tree.prune 10) (Gen.toTree genChar) Tree.depth tree === 1 prop_filter_even :: Property prop_filter_even = property $ do let genEven :: Gen Int genEven = Gen.filter even (Gen.int (Range.constant 0 8)) tree <- forAllWith (Tree.render . fmap show . Tree.prune 5) (Gen.toTree genEven) let NodeT x _ = Tree.runTree tree required = Set.fromList (filter even [0..x]) actual = Set.fromList (toList tree) missing = required `Set.difference` actual annotateShow missing required === actual tests :: IO Bool tests = checkParallel $$(discover) hedgehog-1.0.3/test/Test/Hedgehog/Maybe.hs0000644060175106010010000000210213675330725017522 0ustar00Nikos00000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.Hedgehog.Maybe where import Data.Foldable (toList) import Hedgehog import qualified Hedgehog.Internal.Shrink as Shrink import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack) import Hedgehog.Internal.Tree (Tree) import qualified Hedgehog.Internal.Tree as Tree mkTree :: Int -> Tree Int mkTree n = Tree.expand (Shrink.towards 0) (pure n) showOdd :: Int -> Maybe String showOdd n = if n `mod` 2 == 0 then Nothing else Just (show n) render :: (HasCallStack, Show a) => Tree a -> PropertyT IO () render x = withFrozenCallStack $ do annotate . Tree.render $ fmap show x prop_mapMaybe :: Property prop_mapMaybe = withTests 1 . property $ do let original = mkTree 5 case Tree.mapMaybe showOdd original of Nothing -> failure Just mapped -> do render original render mapped ["5" , "3" , "1" , "1" , "3" , "1"] === toList mapped tests :: IO Bool tests = checkParallel $$(discover) hedgehog-1.0.3/test/Test/Hedgehog/Seed.hs0000644060175106010010000000465713675330725017366 0ustar00Nikos00000000000000{-# LANGUAGE TemplateHaskell #-} module Test.Hedgehog.Seed ( tests ) where import Data.Foldable (for_) import Hedgehog import qualified Hedgehog.Internal.Seed as Seed data Assert = Assert { expected :: !Seed , actual :: !Seed } deriving (Show) -- | Verify that SplitMix avoids pathological γ-values, as discussed by -- Melissa E. O'Neill in the post with title Bugs in SplitMix(es), at -- http://www.pcg-random.org/posts/bugs-in-splitmix.html -- -- See also: -- https://github.com/hedgehogqa/haskell-hedgehog/issues/191 -- prop_avoid_pathological_gamma_values :: Property prop_avoid_pathological_gamma_values = withTests 1 . property $ do for_ asserts $ \a -> expected a === actual a asserts :: [Assert] asserts = [ Assert (Seed 15210016002011668638 12297829382473034411) (Seed.from 0x61c8864680b583eb) , Assert (Seed 11409286845259996466 12297829382473034411) (Seed.from 0xf8364607e9c949bd) , Assert (Seed 1931727433621677744 12297829382473034411) (Seed.from 0x88e48f4fcc823718) , Assert (Seed 307741759840609752 12297829382473034411) (Seed.from 0x7f83ab8da2e71dd1) , Assert (Seed 8606169619657412120 12297829382473034413) (Seed.from 0x7957d809e827ff4c) , Assert (Seed 13651108307767328632 12297829382473034413) (Seed.from 0xf8d059aee4c53639) , Assert (Seed 125750466559701114 12297829382473034413) (Seed.from 0x9cd9f015db4e58b7) , Assert (Seed 6781260234005250507 12297829382473034413) (Seed.from 0xf4077b0dbebc73c0) , Assert (Seed 15306535823716590088 12297829382473034405) (Seed.from 0x305cb877109d0686) , Assert (Seed 7344074043290227165 12297829382473034405) (Seed.from 0x359e58eeafebd527) , Assert (Seed 9920554987610416076 12297829382473034405) (Seed.from 0xbeb721c511b0da6d) , Assert (Seed 3341781972484278810 12297829382473034405) (Seed.from 0x86466fd0fcc363a6) , Assert (Seed 12360157267739240775 12297829382473034421) (Seed.from 0xefee3e7b93db3075) , Assert (Seed 600595566262245170 12297829382473034421) (Seed.from 0x79629ee76aa83059) , Assert (Seed 1471112649570176389 12297829382473034421) (Seed.from 0x05d507d05e785673) , Assert (Seed 8100917074368564322 12297829382473034421) (Seed.from 0x76442b62dddf926c) ] tests :: IO Bool tests = checkParallel $$(discover) hedgehog-1.0.3/test/Test/Hedgehog/Text.hs0000644060175106010010000000332013675330725017414 0ustar00Nikos00000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.Hedgehog.Text where import Data.Int (Int64) import Data.Typeable (Typeable) import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Text.Read (readEither) genSize :: Gen Size genSize = Size <$> Gen.enumBounded genOdd :: Gen Int64 genOdd = let mkOdd x = if odd x then x else pred x in mkOdd <$> Gen.int64 (Range.constant 1 maxBound) genSeed :: Gen Seed genSeed = Seed <$> Gen.word64 Range.constantBounded <*> fmap fromIntegral genOdd genPrecedence :: Gen Int genPrecedence = Gen.int (Range.constant 0 11) genString :: Gen String genString = Gen.string (Range.constant 0 100) Gen.alpha checkShowAppend :: (Typeable a, Show a) => Gen a -> Property checkShowAppend gen = property $ do prec <- forAll genPrecedence x <- forAll gen xsuffix <- forAll genString ysuffix <- forAll genString showsPrec prec x xsuffix ++ ysuffix === showsPrec prec x (xsuffix ++ ysuffix) trippingReadShow :: (Eq a, Typeable a, Show a, Read a) => Gen a -> Property trippingReadShow gen = property $ do prec <- forAll genPrecedence x <- forAll gen tripping x (\z -> showsPrec prec z "") readEither prop_show_append_size :: Property prop_show_append_size = checkShowAppend genSize prop_tripping_append_size :: Property prop_tripping_append_size = trippingReadShow genSize prop_show_append_seed :: Property prop_show_append_seed = checkShowAppend genSeed prop_tripping_append_seed :: Property prop_tripping_append_seed = trippingReadShow genSeed tests :: IO Bool tests = checkParallel $$(discover) hedgehog-1.0.3/test/Test/Hedgehog/Zip.hs0000644060175106010010000000273613675330725017244 0ustar00Nikos00000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} module Test.Hedgehog.Zip where import Control.Monad.Zip (mzip) import Data.Maybe (fromJust) import Hedgehog import qualified Hedgehog.Range as Range import qualified Hedgehog.Internal.Gen as Gen import qualified Hedgehog.Internal.Shrink as Shrink import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack) import Hedgehog.Internal.Tree (Tree) import qualified Hedgehog.Internal.Tree as Tree mkTree :: Int -> Tree Int mkTree n = Tree.expand (Shrink.towards 0) (pure n) mkGen :: Int -> Gen Int mkGen = Gen.fromTree . mkTree render :: Show a => HasCallStack => Tree a -> PropertyT IO () render x = withFrozenCallStack $ do annotate . Tree.render $ fmap show x prop_gen_applicative :: Property prop_gen_applicative = property $ do let treeApplicative n m = (,) <$> mkTree n <*> mkTree m treeZip n m = mzip (mkTree n) (mkTree m) genApplicative n m = fromJust . Gen.evalGen 0 (Seed 0 0) $ (,) <$> mkGen n <*> mkGen m n <- forAll $ Gen.int (Range.constant 1 5) m <- forAll $ Gen.int (Range.constant 1 5) render $ genApplicative n m render $ treeZip n m render $ treeApplicative n m genApplicative n m === treeZip n m genApplicative n m /== treeApplicative n m success tests :: IO Bool tests = checkParallel $$(discover) hedgehog-1.0.3/test/test.hs0000644060175106010010000000111613675330725015017 0ustar00Nikos00000000000000import Hedgehog.Main (defaultMain) import qualified Test.Hedgehog.Applicative import qualified Test.Hedgehog.Confidence import qualified Test.Hedgehog.Filter import qualified Test.Hedgehog.Maybe import qualified Test.Hedgehog.Seed import qualified Test.Hedgehog.Text import qualified Test.Hedgehog.Zip main :: IO () main = defaultMain [ Test.Hedgehog.Applicative.tests , Test.Hedgehog.Confidence.tests , Test.Hedgehog.Filter.tests , Test.Hedgehog.Maybe.tests , Test.Hedgehog.Seed.tests , Test.Hedgehog.Text.tests , Test.Hedgehog.Zip.tests ]