--- /dev/null
+## Version 1.0.5 (2021-03-12)
+
+- GHC 9 Support ([#392][392], [@utdemir][utdemir])
+- Use binary shrinking for integral ([#413][413], [@HuwCampbell][HuwCampbell])
+- Build tree from values instead of wrapping and unwrapping ([#414][414], [@HuwCampbell][HuwCampbell])
+- Don't shrink the action chosen in state machine testing ([#415][415], [@HuwCampbell][HuwCampbell])
+- Support shrinking 1-bit numbers for CLaSH ([#397][397], [@jonfowler][jonfowler] / [@jacobstanley][jacobstanley])
+
+## Version 1.0.4 (2020-12-11)
+
+- Bump ansi-terminal to 0.11 ([#394][394], [@mpilgrem][mpilgrem])
+- Clean up hedgehog.cabal for GHC 8.0+ ([#391][391], [@felixonmars][felixonmars])
+- Bump random to 1.2 ([#396][396], [@felixonmars][felixonmars])
+- Improve the distribution of `Range.scaleLinear` ([#405][405], [@jonfowler][jonfowler] / [@moodmosaic][moodmosaic])
+- Change `Gen.frequency` generator immediately shrink ([#406][406], [@ocharles][ocharles] / [@HuwCampbell][HuwCampbell])
+- Add `Property.evalMaybe`, `Property.evalMaybeM` and `Property.evalEitherM` ([#381][381], [@markus1189][markus1189] / [@moodmosaic][moodmosaic])
+- Bump QuickCheck to 2.14 ([#409][409], [@lehins][lehins])
+- Bump bytestring to 0.11 ([#408][408], [@Bodigrim][Bodigrim])
+- Minor Haddock formatting improvments ([#398][398], [@sshine][sshine] / [@moodmosaic][moodmosaic])
+
+## Version 1.0.3 (2020-06-26)
+
+- Bump cabal-version to 1.10 ([#390][390], [@moodmosaic][moodmosaic])
+- 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
+[Bodigrim]:
+ https://github.com/Bodigrim
+[lehins]:
+ https://github.com/lehins
+[markus1189]:
+ https://github.com/markus1189
+[ocharles]:
+ https://github.com/ocharles
+[jonfowler]:
+ https://github.com/jonfowler
+[felixonmars]:
+ https://github.com/felixonmars
+[mpilgrem]:
+ https://github.com/mpilgrem
+[utdemir]:
+ https://github.com/utdemir
+
+
+[415]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/415
+[414]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/414
+[413]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/413
+[409]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/409
+[408]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/408
+[406]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/406
+[405]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/405
+[398]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/398
+[397]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/397
+[396]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/396
+[394]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/394
+[392]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/392
+[391]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/391
+[390]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/390
+[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
+[381]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/381
+[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
--- /dev/null
+Copyright 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.
--- /dev/null
+<!--
+Apologies to those who are able to read this. Unfortunately, Hackage
+doesn't seem to render the HTML portion of the markdown spec so you may
+be better off paying us a visit on GitHub instead:
+https://github.com/hedgehogqa/haskell-hedgehog
+-->
+
+<div align="center">
+
+<img width="400" src="https://github.com/hedgehogqa/haskell-hedgehog/raw/master/img/hedgehog-text-logo.png" />
+
+# Release with confidence.
+
+[![Hackage][hackage-shield]][hackage] [![Travis][travis-shield]][travis] [![AppVeyor][appveyor-shield]][appveyor]
+
+<div align="left">
+
+[Hedgehog](http://hedgehog.qa/) automatically generates a comprehensive array of test cases, exercising your software in ways human testers would never imagine.
+
+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.
+
+```
+
+<div align="center">
+<br />
+<img width="307" src="https://github.com/hedgehogqa/haskell-hedgehog/raw/master/img/hedgehog-logo-grey.png" />
+
+ [hackage]: http://hackage.haskell.org/package/hedgehog
+ [hackage-shield]: https://img.shields.io/hackage/v/hedgehog.svg?style=flat
+
+ [travis]: https://travis-ci.com/hedgehogqa/haskell-hedgehog
+ [travis-shield]: https://travis-ci.com/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
--- /dev/null
+version: 1.0.5
+
+name:
+ hedgehog
+author:
+ Jacob Stanley
+maintainer:
+ Jacob Stanley <jacob@stanley.io>
+homepage:
+ https://hedgehog.qa
+bug-reports:
+ https://github.com/hedgehogqa/haskell-hedgehog/issues
+synopsis:
+ Release with confidence.
+description:
+ <http://hedgehog.qa/ Hedgehog> automatically generates a comprehensive array
+ of test cases, exercising your software in ways human testers would never
+ imagine.
+ .
+ Generate hundreds of test cases automatically, exposing even the
+ most insidious of corner cases. Failures are automatically simplified, giving
+ developers coherent, intelligible error messages.
+ .
+ To get started quickly, see the <https://github.com/hedgehogqa/haskell-hedgehog/tree/master/hedgehog-example examples>.
+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.12
+ , async >= 2.0 && < 2.3
+ , bytestring >= 0.10 && < 0.12
+ , 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
+ , 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.3
+ , resourcet >= 1.1 && < 1.3
+ , stm >= 2.4 && < 2.6
+ , template-haskell >= 2.10 && < 2.18
+ , 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
+
+ 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
+ , text >= 1.1 && < 1.3
+ , transformers >= 0.3 && < 0.6
+
+ default-language:
+ Haskell2010
--- /dev/null
+-- |
+-- 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
+ , evalEitherM
+ , evalExceptT
+ , evalMaybe
+ , evalMaybeM
+
+ -- * 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, evalEitherM, evalExceptT, evalMaybe, evalMaybeM)
+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)
--- /dev/null
+module 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)
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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 Data.Kind (Type)
+import GHC.Exts (Constraint)
+
+------------------------------------------------------------------------
+-- * MonadTransDistributive
+
+class MonadTransDistributive g where
+ type Transformer
+ (f :: (Type -> Type) -> Type -> Type)
+ (g :: (Type -> Type) -> Type -> Type)
+ (m :: Type -> Type) :: 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)
--- /dev/null
+{-# 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))
--- /dev/null
+{-# 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
+ , 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.Kind (Type)
+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 :: (Type -> Type)
+
+ -- | 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 :: forall m a. (MonadGen m, Integral a) => Range a -> m a
+integral range =
+ -- https://github.com/hedgehogqa/haskell-hedgehog/pull/413/files
+ let
+ origin_ =
+ Range.origin range
+
+ binarySearchTree bottom top =
+ Tree.Tree $
+ let
+ shrinks =
+ Shrink.towards bottom top
+ children =
+ zipWith binarySearchTree shrinks (drop 1 shrinks)
+ in
+ Tree.NodeT top children
+
+ createTree root =
+ if root == origin_ then
+ pure root
+ else
+ hoist Morph.generalize $
+ Tree.consChild origin_ $
+ binarySearchTree origin_ root
+
+ in
+ fromGenT . GenT $ \size seed ->
+ createTree $ integralHelper range size seed
+
+-- | 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_ =
+ generate . integralHelper
+
+
+-- | Generates a random integral value from a range.
+integralHelper :: (Integral a, Num c) => Range a -> Size -> Seed -> c
+integralHelper range 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 elements in the list.
+--
+-- This generator does not shrink the choice of element.
+--
+-- /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
+
+ iis =
+ scanl1 (+) (fmap fst xs0)
+
+ total =
+ sum (fmap fst xs0)
+
+ n <- shrink (\n -> takeWhile (< n) iis) $ 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 "<discard>"
+
+ 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 ->
+ "<discard>"
+ 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.
--- /dev/null
+{-# 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)
--- /dev/null
+{-# 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"
--- /dev/null
+{-# 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)
--- /dev/null
+{-# 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
+ , evalEitherM
+ , evalExceptT
+ , evalMaybe
+ , evalMaybeM
+
+ -- * 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 action throws an exception, or if the
+-- 'Either' is 'Left', otherwise returns the value in the 'Right'.
+--
+evalEitherM :: (MonadTest m, Show x, MonadCatch m, HasCallStack) => m (Either x a) -> m a
+evalEitherM =
+ evalEither <=< evalM
+
+-- | 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
+
+-- | Fails the test if the 'Maybe' is 'Nothing', otherwise returns the value in
+-- the 'Just'.
+--
+evalMaybe :: (MonadTest m, Show a, HasCallStack) => Maybe a -> m a
+evalMaybe = \case
+ Nothing ->
+ withFrozenCallStack $ failWith Nothing "the value was Nothing"
+ Just x ->
+ pure x
+
+-- | Fails the test if the action throws an exception, or if the
+-- 'Maybe' is 'Nothing', otherwise returns the value in the 'Just'.
+--
+evalMaybeM :: (MonadTest m, Show a, MonadCatch m, HasCallStack) => m (Maybe a) -> m a
+evalMaybeM =
+ evalMaybe <=< evalM
+
+------------------------------------------------------------------------
+-- 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
+-- (<https://en.wikipedia.org/wiki/Binomial_proportion_confidence_interval#Wilson_score_interval
+-- wikipedia>) 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.
--- /dev/null
+{-# 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)
--- /dev/null
+{-# 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
+
+ -- @rng@ has magnitude 1 bigger than the biggest diff
+ -- i.e. it specifies the range the diff can be in [0,rng)
+ -- with the upper bound being exclusive.
+ rng =
+ n - z + signum (n - z)
+
+ diff =
+ (rng * fromIntegral sz) `quot` 100
+ 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.
--- /dev/null
+{-# 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 ()
--- /dev/null
+{-# 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 "<property>" (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 ->
+ "<interactive>"
+ 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
--- /dev/null
+{-# 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
+ }
--- /dev/null
+{-# 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.
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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
+ []
+ -- special case for 1-bit numbers
+ else if destination == 0 && x == 1 then
+ [0]
+ 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
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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.Kind (Type)
+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 :: (Type -> Type) -> Type) =
+ 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 :: (Type -> Type) -> Type) =
+ 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.
+--
+newtype 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 _
+ -> "<<not found in environment>>"
+ EnvironmentTypeError _ _
+ -> "<<type representation in environment unexpected>>"
+
+ 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
--- /dev/null
+{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE CPP #-}
+{-# 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, location, runIO
+#if MIN_VERSION_template_haskell(2,17,0)
+ , CodeQ, joinCode, unTypeCode, unsafeCodeCoerce
+#endif
+ )
+import Language.Haskell.TH.Syntax (Loc(..), mkName
+#if !MIN_VERSION_template_haskell(2,17,0)
+ , TExp, unsafeTExpCoerce, unTypeQ
+#endif
+ )
+
+#if MIN_VERSION_template_haskell(2,17,0)
+type TExpQ a = CodeQ a
+#else
+-- Originally `Code` is a more polymorphic newtype wrapper, but for this module
+-- we can get away with just making it a type alias.
+type TExpQ a = Q (TExp a)
+joinCode :: Q (TExpQ a) -> TExpQ a
+joinCode = (>>= id)
+unsafeCodeCoerce :: Q Exp -> TExpQ a
+unsafeCodeCoerce = unsafeTExpCoerce
+unTypeCode :: TExpQ a -> Q Exp
+unTypeCode = unTypeQ
+#endif
+
+-- | 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 = joinCode $ 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
+
+ return [|| Group $$(moduleName) $$(listTE names) ||]
+
+mkNamedProperty :: PropertyName -> TExpQ (PropertyName, Property)
+mkNamedProperty name =
+ [|| (name, $$(unsafeProperty name)) ||]
+
+unsafeProperty :: PropertyName -> TExpQ Property
+unsafeProperty =
+ unsafeCodeCoerce . pure . VarE . mkName . unPropertyName
+
+listTE :: [TExpQ a] -> TExpQ [a]
+listTE xs =
+ unsafeCodeCoerce $ pure . ListE =<< traverse unTypeCode xs
+
+moduleName :: TExpQ GroupName
+moduleName = joinCode $ do
+ loc <- GroupName . loc_module <$> location
+ return [|| loc ||]
+
+getCurrentFile :: Q FilePath
+getCurrentFile =
+ loc_filename <$> location
--- /dev/null
+{-# 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
+ , consChild
+ , 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
+
+consChild :: (Monad m) => a -> TreeT m a -> TreeT m a
+consChild a m =
+ TreeT $ do
+ NodeT x xs <- runTreeT m
+ pure $
+ NodeT x $
+ pure a : xs
+
+------------------------------------------------------------------------
+
+-- | 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
--- /dev/null
+{-# 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
+ ]
--- /dev/null
+module 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
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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)
--- /dev/null
+{-# 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)
--- /dev/null
+{-# 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'
+-- ...
+--
+-- └╼<discard>
+-- @
+--
+-- 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)
--- /dev/null
+{-# 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)
--- /dev/null
+{-# 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)
--- /dev/null
+{-# 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)
--- /dev/null
+{-# 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)
--- /dev/null
+import 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
+ ]
projects / haskell-hedgehog.git / commitdiff