From 13797a952cddb7595cc53cd4b55e16024301c913 Mon Sep 17 00:00:00 2001 From: Clint Adams Date: Fri, 8 Jun 2018 05:38:24 +0100 Subject: [PATCH] Import haskell-hedgehog_0.6.orig.tar.gz [dgit import orig haskell-hedgehog_0.6.orig.tar.gz] --- CHANGELOG.md | 160 +++ LICENSE | 29 + README.md | 87 ++ Setup.hs | 2 + hedgehog.cabal | 136 ++ src/Hedgehog.hs | 172 +++ src/Hedgehog/Gen.hs | 111 ++ src/Hedgehog/Internal/Config.hs | 172 +++ src/Hedgehog/Internal/Discovery.hs | 235 ++++ src/Hedgehog/Internal/Distributive.hs | 54 + src/Hedgehog/Internal/Exception.hs | 24 + src/Hedgehog/Internal/Gen.hs | 1638 +++++++++++++++++++++++++ src/Hedgehog/Internal/HTraversable.hs | 13 + src/Hedgehog/Internal/Opaque.hs | 28 + src/Hedgehog/Internal/Property.hs | 806 ++++++++++++ src/Hedgehog/Internal/Queue.hs | 118 ++ src/Hedgehog/Internal/Range.hs | 478 ++++++++ src/Hedgehog/Internal/Region.hs | 128 ++ src/Hedgehog/Internal/Report.hs | 903 ++++++++++++++ src/Hedgehog/Internal/Runner.hs | 400 ++++++ src/Hedgehog/Internal/Seed.hs | 230 ++++ src/Hedgehog/Internal/Show.hs | 275 +++++ src/Hedgehog/Internal/Shrink.hs | 129 ++ src/Hedgehog/Internal/Source.hs | 109 ++ src/Hedgehog/Internal/State.hs | 804 ++++++++++++ src/Hedgehog/Internal/TH.hs | 64 + src/Hedgehog/Internal/Tree.hs | 390 ++++++ src/Hedgehog/Internal/Tripping.hs | 52 + src/Hedgehog/Range.hs | 34 + test/Test/Hedgehog/Text.hs | 76 ++ test/test.hs | 18 + 31 files changed, 7875 insertions(+) create mode 100644 CHANGELOG.md create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 hedgehog.cabal create mode 100644 src/Hedgehog.hs create mode 100644 src/Hedgehog/Gen.hs create mode 100644 src/Hedgehog/Internal/Config.hs create mode 100644 src/Hedgehog/Internal/Discovery.hs create mode 100644 src/Hedgehog/Internal/Distributive.hs create mode 100644 src/Hedgehog/Internal/Exception.hs create mode 100644 src/Hedgehog/Internal/Gen.hs create mode 100644 src/Hedgehog/Internal/HTraversable.hs create mode 100644 src/Hedgehog/Internal/Opaque.hs create mode 100644 src/Hedgehog/Internal/Property.hs create mode 100644 src/Hedgehog/Internal/Queue.hs create mode 100644 src/Hedgehog/Internal/Range.hs create mode 100644 src/Hedgehog/Internal/Region.hs create mode 100644 src/Hedgehog/Internal/Report.hs create mode 100644 src/Hedgehog/Internal/Runner.hs create mode 100644 src/Hedgehog/Internal/Seed.hs create mode 100644 src/Hedgehog/Internal/Show.hs create mode 100644 src/Hedgehog/Internal/Shrink.hs create mode 100644 src/Hedgehog/Internal/Source.hs create mode 100644 src/Hedgehog/Internal/State.hs create mode 100644 src/Hedgehog/Internal/TH.hs create mode 100644 src/Hedgehog/Internal/Tree.hs create mode 100644 src/Hedgehog/Internal/Tripping.hs create mode 100644 src/Hedgehog/Range.hs create mode 100644 test/Test/Hedgehog/Text.hs create mode 100644 test/test.hs diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..c9b3699 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,160 @@ +## 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], [@jystic][jystic]) +- Easier to use variables for state machine testing ([#94][94], [@jystic][jystic]) +- `MonadGen` class allows the use of transformers like `ReaderT` and `StateT` on the outside of generators ([#99][99], [@jystic][jystic]) +- Better error messages for tests which throw exceptions ([#95][95], [@jystic][jystic]) +- Separated test input generation and assertions in to `PropertyT` and `TestT` respectively, this allows `TestT` to have a `MonadBaseControl` instance ([#96][96], [@jystic][jystic]) +- 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], [@jystic][jystic]) + +## 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], [@jystic][jystic]) +- `liftCatch`, `liftCatchIO`, `withCatch` functions for isolating exceptions during tests ([#89][89], [@jystic][jystic]) + +## 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], [@jystic][jystic]) +- `distribute` function for pulling a transformer out to the top level ([#83][83], [@jystic][jystic]) +- `withExceptT` function for executing tests with an inner `ExceptT` (e.g. `Test (ExceptT x m) a`) ([#83][83], [@jystic][jystic]) + +## 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], [@jystic][jystic]) + +## Version 0.2 (2017-05-06) + +- Added a quiet test runner which can be activated by setting `HEDGEHOG_VERBOSITY=0` ([@jystic][jystic]) +- Concurrent test runner does not display tests until they are executing ([@jystic][jystic]) +- Test runner now outputs a summary of how many successful / failed tests were run ([@jystic][jystic]) +- `checkSequential` and `checkParallel` now allow for tests to be run without Template Haskell ([@jystic][jystic]) +- Auto-discovery of properties is now available via `discover` instead of being baked in ([@jystic][jystic]) +- `annotate` allows source code to be annotated inline with extra information ([@jystic][jystic]) +- `forAllWith` can be used to generate values without a `Show` instance ([@jystic][jystic]) +- Removed uses of `Typeable` to allow for generating types which cannot implement it ([@jystic][jystic]) + +[Dieharder]: + https://webhome.phy.duke.edu/~rgb/General/dieharder.php + +[jystic]: + https://github.com/jystic +[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 + +[185]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/185 +[184]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/184 +[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 diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..65566f6 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..830dfdc --- /dev/null +++ b/README.md @@ -0,0 +1,87 @@ +hedgehog [![Hackage][hackage-shield]][hackage] [![Travis][travis-shield]][travis] +======== + +> Hedgehog will eat all your bugs. + + + +[Hedgehog](http://hedgehog.qa/) is a modern property-based testing +system, in the spirit of QuickCheck. Hedgehog uses integrated shrinking, +so shrinks obey the invariants of generated values by construction. + +## Features + +- Integrated shrinking, shrinks obey invariants by construction. +- Abstract state machine testing. +- Generators allow monadic effects. +- Range combinators for full control over the scope of generated numbers and collections. +- Equality and roundtrip assertions show a diff instead of the two inequal values. +- Template Haskell test runner which executes properties concurrently. + +## Example + +The main module, [Hedgehog][haddock-hedgehog], includes almost +everything you need to get started writing property tests with Hedgehog. + +It is designed to be used alongside [Hedgehog.Gen][haddock-hedgehog-gen] +and [Hedgehog.Range][haddock-hedgehog-range] which should be imported +qualified. You also need to enable Template Haskell so the Hedgehog test +runner can find your properties. + +```hs +{-# LANGUAGE TemplateHaskell #-} + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +``` + +Once you have your imports set up, you can write a simple property: + +```hs +prop_reverse :: Property +prop_reverse = + property $ do + xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha + reverse (reverse xs) === xs +``` + +And add the Template Haskell splice which will discover your properties: + +```hs +tests :: IO Bool +tests = + checkParallel $$(discover) +``` + +If you prefer to avoid macros, you can specify the group of properties +to run manually instead: + +```hs +{-# LANGUAGE OverloadedStrings #-} + +tests :: IO Bool +tests = + checkParallel $ Group "Test.Example" [ + ("prop_reverse", prop_reverse) + ] +``` + +You can then load the module in GHCi, and run it: + +``` +λ tests +━━━ Test.Example ━━━ + ✓ prop_reverse passed 100 tests. + +``` + + [hackage]: http://hackage.haskell.org/package/hedgehog + [hackage-shield]: https://img.shields.io/badge/hackage-v0.5-blue.svg + + [travis]: https://travis-ci.org/hedgehogqa/haskell-hedgehog + [travis-shield]: https://travis-ci.org/hedgehogqa/haskell-hedgehog.svg?branch=master + + [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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hedgehog.cabal b/hedgehog.cabal new file mode 100644 index 0000000..2bb2449 --- /dev/null +++ b/hedgehog.cabal @@ -0,0 +1,136 @@ +version: 0.6 + +name: + hedgehog +author: + Jacob Stanley +maintainer: + Jacob Stanley +homepage: + https://hedgehog.qa +bug-reports: + https://github.com/hedgehogqa/haskell-hedgehog/issues +synopsis: + Hedgehog will eat all your bugs. +description: + Hedgehog is a modern property-based testing system, in the spirit of + QuickCheck. Hedgehog uses integrated shrinking, so shrinks obey the + invariants of generated values by construction. + . + To get started quickly, see the examples: + +category: + Testing +license: + BSD3 +license-file: + LICENSE +cabal-version: + >= 1.8 +build-type: + Simple +tested-with: + GHC == 7.10.2 + , GHC == 7.10.3 + , GHC == 8.0.1 + , GHC == 8.0.2 + , GHC == 8.2.1 + , GHC == 8.2.2 + , GHC == 8.4.1 +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: git://github.com/hedgehogqa/haskell-hedgehog.git + +library + build-depends: + base >= 3 && < 5 + , ansi-terminal >= 0.6 && < 0.9 + , async >= 2.0 && < 2.3 + , bytestring >= 0.10 && < 0.11 + , concurrent-output >= 1.7 && < 1.11 + , containers >= 0.4 && < 0.6 + , directory >= 1.2 && < 1.4 + , 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.8 + , primitive >= 0.6 && < 0.7 + , random >= 1.1 && < 1.2 + , resourcet >= 1.1 && < 1.3 + , semigroups >= 0.16 && < 0.19 + , stm >= 2.4 && < 2.5 + , template-haskell >= 2.10 && < 2.14 + , text >= 1.1 && < 1.3 + , th-lift >= 0.7 && < 0.8 + , time >= 1.4 && < 1.9 + , transformers >= 0.4 && < 0.6 + , transformers-base >= 0.4 && < 0.5 + , wl-pprint-annotated >= 0.0 && < 0.2 + + if !os(windows) + build-depends: + unix >= 2.6 && < 2.8 + + ghc-options: + -Wall + + hs-source-dirs: + src + + exposed-modules: + Hedgehog + Hedgehog.Gen + 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.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 + +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.Text + + build-depends: + hedgehog + , base >= 3 && < 5 + , containers >= 0.4 && < 0.6 + , pretty-show >= 1.6 && < 1.8 + , semigroups >= 0.16 && < 0.19 + , text >= 1.1 && < 1.3 + , transformers >= 0.3 && < 0.6 diff --git a/src/Hedgehog.hs b/src/Hedgehog.hs new file mode 100644 index 0000000..8c4b196 --- /dev/null +++ b/src/Hedgehog.hs @@ -0,0 +1,172 @@ +-- | +-- 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 + , checkParallel + , checkSequential + + , 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 + , (===) + , (/==) + , tripping + + , eval + , evalM + , evalIO + , evalEither + , evalExceptT + + -- * State Machine Tests + , Command(..) + , Callback(..) + , Action + , Sequential(..) + , Parallel(..) + , executeSequential + , executeParallel + + , Var(..) + , concrete + , opaque + + , Symbolic + , Concrete(..) + , Opaque(..) + + -- * Transformers + , distribute + + -- * Functors + , HTraversable(..) + + , Eq1 + , eq1 + + , Ord1 + , compare1 + + , Show1 + , showsPrec1 + ) where + +import Data.Functor.Classes (Eq1, eq1, Ord1, compare1, Show1, showsPrec1) + +import Hedgehog.Internal.Distributive (Distributive(..)) +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, (===), (/==)) +import Hedgehog.Internal.Property (discard, failure, success) +import Hedgehog.Internal.Property (DiscardLimit, withDiscards) +import Hedgehog.Internal.Property (eval, evalM, evalIO) +import Hedgehog.Internal.Property (evalEither, evalExceptT) +import Hedgehog.Internal.Property (footnote, footnoteShow) +import Hedgehog.Internal.Property (forAll, forAllWith) +import Hedgehog.Internal.Property (MonadTest(..)) +import Hedgehog.Internal.Property (Property, PropertyT, PropertyName) +import Hedgehog.Internal.Property (Group(..), GroupName) +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.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) +import Hedgehog.Internal.Tripping (tripping) diff --git a/src/Hedgehog/Gen.hs b/src/Hedgehog/Gen.hs new file mode 100644 index 0000000..108f36a --- /dev/null +++ b/src/Hedgehog/Gen.hs @@ -0,0 +1,111 @@ +module Hedgehog.Gen ( + -- * Combinators + lift + + -- ** 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 + , just + + -- ** Collections + , maybe + , 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 (filter, print, maybe, map, seq) diff --git a/src/Hedgehog/Internal/Config.hs b/src/Hedgehog/Internal/Config.hs new file mode 100644 index 0000000..91b661c --- /dev/null +++ b/src/Hedgehog/Internal/Config.hs @@ -0,0 +1,172 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE CPP #-} +{-# 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.Lift (deriveLift) + +import System.Console.ANSI (hSupportsANSI) +import System.Environment (lookupEnv) +import System.IO (stdout) + +#if !mingw32_HOST_OS +import System.Posix.User (getEffectiveUserName) +#endif + +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) + +-- | 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) + +-- | The number of workers to use when running properties in parallel. +-- +newtype WorkerCount = + WorkerCount Int + deriving (Eq, Ord, Show, Num, Enum, Real, Integral) + +detectMark :: MonadIO m => m Bool +detectMark = do +#if mingw32_HOST_OS + pure False +#else + user <- liftIO getEffectiveUserName + pure $ user == "mth" +#endif + +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 + +------------------------------------------------------------------------ +-- FIXME Replace with DeriveLift when we drop 7.10 support. + +$(deriveLift ''UseColor) +$(deriveLift ''Verbosity) +$(deriveLift ''WorkerCount) diff --git a/src/Hedgehog/Internal/Discovery.hs b/src/Hedgehog/Internal/Discovery.hs new file mode 100644 index 0000000..ad70a72 --- /dev/null +++ b/src/Hedgehog/Internal/Discovery.hs @@ -0,0 +1,235 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +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 Data.Semigroup (Semigroup(..)) + +import Hedgehog.Internal.Property (PropertyName(..)) +import Hedgehog.Internal.Source (LineNo(..), ColumnNo(..)) + +------------------------------------------------------------------------ +-- Property Extraction + +newtype PropertySource = + PropertySource { + propertySource :: Pos String + } deriving (Eq, Ord, Show) + +readProperties :: MonadIO m => FilePath -> m (Map PropertyName PropertySource) +readProperties path = + findProperties 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 :: FilePath -> String -> Map PropertyName PropertySource +findProperties path = + Map.map PropertySource . + Map.mapKeysMonotonic PropertyName . + Map.filterWithKey (\k _ -> isProperty k) . + findDeclarations path + +findDeclarations :: FilePath -> String -> Map String (Pos String) +findDeclarations path = + declarations . + classified . + positioned path + +isProperty :: String -> Bool +isProperty = + List.isPrefixOf "prop_" + +------------------------------------------------------------------------ +-- 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 diff --git a/src/Hedgehog/Internal/Distributive.hs b/src/Hedgehog/Internal/Distributive.hs new file mode 100644 index 0000000..dac0522 --- /dev/null +++ b/src/Hedgehog/Internal/Distributive.hs @@ -0,0 +1,54 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +module Hedgehog.Internal.Distributive ( + Distributive(..) + ) where + +import Control.Monad (join) +import Control.Monad.Morph (MFunctor(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Except (ExceptT(..), runExceptT) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.Trans.Writer (WriterT(..)) + +import GHC.Exts (Constraint) + + +class Distributive g where + type Transformer + (f :: (* -> *) -> * -> *) + (g :: (* -> *) -> * -> *) + (m :: * -> *) :: Constraint + + type Transformer f g m = ( + Monad m + , Monad (f m) + , Monad (g m) + , Monad (f (g m)) + , MonadTrans f + , MFunctor f + ) + + -- | Distribute one monad transformer over another. + -- + distribute :: Transformer f g m => g (f m) a -> f (g m) a + +instance Distributive MaybeT where + distribute x = + lift . MaybeT . pure =<< hoist lift (runMaybeT x) + +instance Distributive (ExceptT x) where + distribute x = + lift . ExceptT . pure =<< hoist lift (runExceptT x) + +instance Monoid w => Distributive (WriterT w) where + distribute x = + lift . WriterT . pure =<< hoist lift (runWriterT x) + +instance Distributive (ReaderT r) where + distribute x = + join . lift . ReaderT $ \r -> + pure . hoist lift $ runReaderT x r diff --git a/src/Hedgehog/Internal/Exception.hs b/src/Hedgehog/Internal/Exception.hs new file mode 100644 index 0000000..ae1de27 --- /dev/null +++ b/src/Hedgehog/Internal/Exception.hs @@ -0,0 +1,24 @@ +{-# 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)) diff --git a/src/Hedgehog/Internal/Gen.hs b/src/Hedgehog/Internal/Gen.hs new file mode 100644 index 0000000..466beb5 --- /dev/null +++ b/src/Hedgehog/Internal/Gen.hs @@ -0,0 +1,1638 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- MonadBase +module Hedgehog.Internal.Gen ( + -- * Transformer + Gen + , GenT(..) + , MonadGen(..) + + -- * Combinators + , lift + + -- ** Shrinking + , shrink + , prune + + -- ** Size + , small + , scale + , resize + , sized + + -- ** Integral + , integral + , integral_ + + , int + , int8 + , int16 + , int32 + , int64 + + , word + , word8 + , word16 + , word32 + , word64 + + -- ** Floating-point + , realFloat + , realFrac_ + , float + , double + + -- ** Enumeration + , enum + , enumBounded + , bool + , bool_ + + -- ** Characters + , binit + , octit + , digit + , hexit + , lower + , upper + , alpha + , alphaNum + , ascii + , latin1 + , unicode + , unicodeAll + + -- ** Strings + , string + , text + , utf8 + , bytes + + -- ** Choice + , constant + , element + , choice + , frequency + , recursive + + -- ** Conditional + , discard + , ensure + , filter + , just + + -- ** Collections + , maybe + , list + , seq + , nonEmpty + , set + , map + + -- ** Subterms + , freeze + , subterm + , subtermM + , subterm2 + , subtermM2 + , subterm3 + , subtermM3 + + -- ** Combinations & Permutations + , subsequence + , shuffle + + -- * Sampling Generators + , sample + , print + , printTree + , printWith + , printTreeWith + + -- * Internal + -- $internal + + -- ** Transfomer + , runGenT + , mapGenT + , generate + , liftTree + , runDiscardEffect + + -- ** Size + , golden + + -- ** Shrinking + , atLeast + + -- ** Characters + , isSurrogate + , isNoncharacter + + -- ** Subterms + , Vec(..) + , Nat(..) + , subtermMVec + + -- ** Sampling + , renderNodes + ) where + +import Control.Applicative (Alternative(..),liftA2) +import Control.Monad (MonadPlus(..), filterM, replicateM, ap, join) +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) +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 qualified Control.Monad.Trans.Class as Trans +import Control.Monad.Trans.Except (ExceptT(..), mapExceptT) +import Control.Monad.Trans.Identity (IdentityT(..), mapIdentityT) +import Control.Monad.Trans.Maybe (MaybeT(..), mapMaybeT) +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Reader (ReaderT(..), mapReaderT) +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 Data.Bifunctor (first, second) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.Char as Char +import Data.Foldable (for_, toList) +import Data.Functor.Identity (Identity(..)) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import Data.Semigroup (Semigroup) +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 (Distributive(..)) +import Hedgehog.Internal.Seed (Seed) +import qualified Hedgehog.Internal.Seed as Seed +import qualified Hedgehog.Internal.Shrink as Shrink +import Hedgehog.Internal.Tree (Tree(..), Node(..)) +import qualified Hedgehog.Internal.Tree as Tree +import Hedgehog.Range (Size, Range) +import qualified Hedgehog.Range as Range + +import Prelude hiding (filter, print, maybe, map, seq) + + +------------------------------------------------------------------------ +-- 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 { + unGen :: Size -> Seed -> Tree (MaybeT m) a + } + +-- | Runs a generator, producing its shrink tree. +-- +runGenT :: Size -> Seed -> GenT m a -> Tree (MaybeT m) a +runGenT size seed (GenT m) = + m size seed + +-- | Map over a generator's shrink tree. +-- +mapGenT :: (Tree (MaybeT m) a -> Tree (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. +-- +liftTree :: Tree (MaybeT m) a -> GenT m a +liftTree x = + GenT (\_ _ -> x) + +-- | 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. +-- +runDiscardEffect :: Monad m => Tree (MaybeT m) a -> Tree m (Maybe a) +runDiscardEffect = + runMaybeT . distribute + +------------------------------------------------------------------------ +-- MonadGen + +-- | Class of monads which can generate input data for tests. +-- +-- /The functions on this class can, and should, be used without their @Gen@/ +-- /suffix by importing "Hedgehog.Gen" qualified./ +-- +class Monad m => MonadGen m where + -- | See @Gen.@'Hedgehog.Gen.lift' + -- + liftGen :: Gen a -> m a + + -- | See @Gen.@'Hedgehog.Gen.shrink' + -- + shrinkGen :: (a -> [a]) -> m a -> m a + + -- | See @Gen.@'Hedgehog.Gen.prune' + -- + pruneGen :: m a -> m a + + -- | See @Gen.@'Hedgehog.Gen.scale' + -- + scaleGen :: (Size -> Size) -> m a -> m a + + -- | See @Gen.@'Hedgehog.Gen.freeze' + -- + freezeGen :: m a -> m (a, m a) + +instance Monad m => MonadGen (GenT m) where + liftGen gen = + hoist generalize gen + + shrinkGen = + mapGenT . Tree.expand + + pruneGen = + mapGenT Tree.prune + + scaleGen f gen = + GenT $ \size0 seed -> + let + size = + f size0 + in + if size < 0 then + error "Hedgehog.Gen.scale: negative size" + else + runGenT size seed gen + + freezeGen gen = + GenT $ \size seed -> do + mx <- Trans.lift . Trans.lift . runMaybeT . runTree $ runGenT size seed gen + case mx of + Nothing -> + mzero + Just (Node x xs) -> + pure (x, liftTree . Tree.fromNode $ Node x xs) + +instance MonadGen m => MonadGen (IdentityT m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + mapIdentityT (shrink f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen = + mapIdentityT $ + fmap (second Trans.lift) . freeze + +shrinkMaybe :: (a -> [a]) -> Maybe a -> [Maybe a] +shrinkMaybe f = \case + Nothing -> + pure Nothing + Just x -> + fmap Just (f x) + +shrinkEither :: (a -> [a]) -> Either x a -> [Either x a] +shrinkEither f = \case + Left x -> + pure $ Left x + Right x -> + fmap Right (f x) + +shrink2 :: (a -> [a]) -> (a, b) -> [(a, b)] +shrink2 f (x, y) = + fmap (, y) (f x) + +shrink3 :: (a -> [a]) -> (a, b, c) -> [(a, b, c)] +shrink3 f (x, y, z) = + fmap (, y, z) (f x) + +instance MonadGen m => MonadGen (MaybeT m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + mapMaybeT $ + shrink (shrinkMaybe f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen = + mapMaybeT $ \m0 -> do + (mx, m) <- freeze m0 + pure $ fmap (, MaybeT m) mx + +instance MonadGen m => MonadGen (ExceptT x m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + mapExceptT $ + shrink (shrinkEither f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen = + mapExceptT $ \m0 -> do + (mx, m) <- freeze m0 + pure $ fmap (, ExceptT m) mx + +instance MonadGen m => MonadGen (ReaderT r m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + mapReaderT (shrink f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen = + mapReaderT $ + fmap (second Trans.lift) . freeze + +instance MonadGen m => MonadGen (Lazy.StateT s m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + Lazy.mapStateT $ + shrink (shrink2 f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen m0 = + Lazy.StateT $ \s0 -> do + ((x, s), m) <- freeze (Lazy.runStateT m0 s0) + pure ((x, Lazy.StateT (const m)), s) + +instance MonadGen m => MonadGen (Strict.StateT s m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + Strict.mapStateT $ + shrink (shrink2 f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen m0 = + Strict.StateT $ \s0 -> do + ((x, s), m) <- freeze (Strict.runStateT m0 s0) + pure ((x, Strict.StateT (const m)), s) + +instance (MonadGen m, Monoid w) => MonadGen (Lazy.WriterT w m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + Lazy.mapWriterT $ + shrink (shrink2 f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen m0 = + Lazy.WriterT $ do + ((x, w), m) <- freeze (Lazy.runWriterT m0) + pure ((x, Lazy.WriterT m), w) + +instance (MonadGen m, Monoid w) => MonadGen (Strict.WriterT w m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + Strict.mapWriterT $ + shrink (shrink2 f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen m0 = + Strict.WriterT $ do + ((x, w), m) <- freeze (Strict.runWriterT m0) + pure ((x, Strict.WriterT m), w) + +instance (MonadGen m, Monoid w) => MonadGen (Lazy.RWST r w s m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + Lazy.mapRWST $ + shrink (shrink3 f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen m0 = + Lazy.RWST $ \r s0 -> do + ((x, s, w), m) <- freeze (Lazy.runRWST m0 r s0) + pure ((x, Lazy.RWST (\_ _ -> m)), s, w) + +instance (MonadGen m, Monoid w) => MonadGen (Strict.RWST r w s m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + Strict.mapRWST $ + shrink (shrink3 f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen m0 = + Strict.RWST $ \r s0 -> do + ((x, s, w), m) <- freeze (Strict.runRWST m0 r s0) + pure ((x, Strict.RWST (\_ _ -> m)), s, w) + +------------------------------------------------------------------------ +-- 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) + +instance Monad m => Applicative (GenT m) where + pure = + return + (<*>) = + ap + +instance Monad m => Monad (GenT m) where + return = + liftTree . pure + + (>>=) m k = + GenT $ \size seed -> + case Seed.split seed of + (sk, sm) -> + runGenT size sk . k =<< + runGenT size sm m + +instance Monad m => Alternative (GenT m) where + empty = + mzero + (<|>) = + mplus + +instance Monad m => MonadPlus (GenT m) where + mzero = + liftTree 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 = + liftTree . Trans.lift . Trans.lift + +instance MFunctor GenT where + hoist f = + mapGenT (hoist (hoist f)) + +embedMaybe :: + MonadTrans t + => Monad n + => Monad (t (MaybeT n)) + => (forall a. m a -> t (MaybeT n) a) + -> MaybeT m b + -> t (MaybeT n) b +embedMaybe f m = + Trans.lift . MaybeT . pure =<< f (runMaybeT m) + +embedTree :: Monad n => (forall a. m a -> Tree (MaybeT n) a) -> Tree (MaybeT m) b -> Tree (MaybeT n) b +embedTree f tree = + embed (embedMaybe f) tree + +embedGen :: Monad n => (forall a. m a -> GenT n a) -> GenT m b -> GenT n b +embedGen f gen = + GenT $ \size seed -> + case Seed.split seed of + (sf, sg) -> + (runGenT size sf . f) `embedTree` + (runGenT size sg gen) + +instance MMonad GenT where + embed = + embedGen + +distributeGen :: Transformer t GenT m => GenT (t m) a -> t (GenT m) a +distributeGen x = + join . Trans.lift . GenT $ \size seed -> + pure . hoist liftTree . distribute . hoist distribute $ runGenT size seed x + +instance Distributive GenT where + type Transformer t GenT m = ( + Monad (t (GenT m)) + , Transformer t MaybeT m + , Transformer t Tree (MaybeT m) + ) + + distribute = + distributeGen + +instance PrimMonad m => PrimMonad (GenT m) where + type PrimState (GenT m) = + PrimState m + primitive = + Trans.lift . primitive + +instance MonadIO m => MonadIO (GenT m) where + liftIO = + Trans.lift . liftIO + +instance MonadBase b m => MonadBase b (GenT m) where + liftBase = + Trans.lift . liftBase + +instance MonadThrow m => MonadThrow (GenT m) where + throwM = + Trans.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 = + Trans.lift ask + local f m = + mapGenT (local f) m + +instance MonadState s m => MonadState s (GenT m) where + get = + Trans.lift get + put = + Trans.lift . put + state = + Trans.lift . state + +instance MonadWriter w m => MonadWriter w (GenT m) where + writer = + Trans.lift . writer + tell = + Trans.lift . tell + listen = + mapGenT listen + pass = + mapGenT pass + +instance MonadError e m => MonadError e (GenT m) where + throwError = + Trans.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 = + Trans.lift . liftResourceT + +------------------------------------------------------------------------ +-- Combinators + +-- | Lift a vanilla 'Gen' in to a 'MonadGen'. +-- +lift :: MonadGen m => Gen a -> m a +lift = + liftGen + +-- | Generate a value with no shrinks from a 'Size' and a 'Seed'. +-- +generate :: MonadGen m => (Size -> Seed -> a) -> m a +generate f = + liftGen . 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 = + shrinkGen + +-- | Throw away a generator's shrink tree. +-- +prune :: MonadGen m => m a -> m a +prune = + pruneGen + +------------------------------------------------------------------------ +-- 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 = + scaleGen + +-- | Make a generator smaller by scaling its size parameter. +-- +small :: MonadGen m => m a -> m a +small = + scale golden + +-- | Scale a size using the golden ratio. +-- +-- > golden x = x / φ +-- > golden x = x / 1.61803.. +-- +golden :: Size -> Size +golden x = + round (fromIntegral x * 0.61803398875 :: Double) + +------------------------------------------------------------------------ +-- Combinators - Integral + +-- | Generates a random integral number in the given @[inclusive,inclusive]@ range. +-- +-- When the generator tries to shrink, it will shrink towards the +-- 'Range.origin' of the specified 'Range'. +-- +-- For example, the following generator will produce a number between @1970@ +-- and @2100@, but will shrink towards @2000@: +-- +-- @ +-- integral (Range.'Range.constantFrom' 2000 1970 2100) :: 'Gen' 'Int' +-- @ +-- +-- Some sample outputs from this generator might look like: +-- +-- > === Outcome === +-- > 1973 +-- > === Shrinks === +-- > 2000 +-- > 1987 +-- > 1980 +-- > 1976 +-- > 1974 +-- +-- > === Outcome === +-- > 2061 +-- > === Shrinks === +-- > 2000 +-- > 2031 +-- > 2046 +-- > 2054 +-- > 2058 +-- > 2060 +-- +integral :: (MonadGen m, Integral a) => Range a -> m a +integral range = + shrink (Shrink.towards $ Range.origin range) (integral_ range) + +-- | Generates a random integral number in the [inclusive,inclusive] range. +-- +-- /This generator does not shrink./ +-- +integral_ :: (MonadGen m, Integral a) => Range a -> m a +integral_ range = + generate $ \size seed -> + let + (x, y) = + Range.bounds size range + in + fromInteger . fst $ + Seed.nextInteger (toInteger x) (toInteger y) seed + +-- | Generates a random machine integer in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +int :: MonadGen m => Range Int -> m Int +int = + integral + +-- | Generates a random 8-bit integer in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +int8 :: MonadGen m => Range Int8 -> m Int8 +int8 = + integral + +-- | Generates a random 16-bit integer in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +int16 :: MonadGen m => Range Int16 -> m Int16 +int16 = + integral + +-- | Generates a random 32-bit integer in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +int32 :: MonadGen m => Range Int32 -> m Int32 +int32 = + integral + +-- | Generates a random 64-bit integer in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +int64 :: MonadGen m => Range Int64 -> m Int64 +int64 = + integral + +-- | Generates a random machine word in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +word :: MonadGen m => Range Word -> m Word +word = + integral + +-- | Generates a random byte in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +word8 :: MonadGen m => Range Word8 -> m Word8 +word8 = + integral + +-- | Generates a random 16-bit word in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +word16 :: MonadGen m => Range Word16 -> m Word16 +word16 = + integral + +-- | Generates a random 32-bit word in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +word32 :: MonadGen m => Range Word32 -> m Word32 +word32 = + integral + +-- | Generates a random 64-bit word in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +word64 :: MonadGen m => Range Word64 -> m Word64 +word64 = + integral + +------------------------------------------------------------------------ +-- Combinators - Fractional / Floating-Point + +-- | Generates a random floating-point number in the @[inclusive,exclusive)@ range. +-- +-- This generator works the same as 'integral', but for floating point numbers. +-- +realFloat :: (MonadGen m, RealFloat a) => Range a -> m a +realFloat range = + shrink (Shrink.towardsFloat $ Range.origin range) (realFrac_ range) + +-- | Generates a random fractional number in the [inclusive,exclusive) range. +-- +-- /This generator does not shrink./ +-- +realFrac_ :: (MonadGen m, RealFrac a) => Range a -> m a +realFrac_ range = + generate $ \size seed -> + let + (x, y) = + Range.bounds size range + in + realToFrac . fst $ + Seed.nextDouble (realToFrac x) (realToFrac y) seed + +-- | Generates a random floating-point number in the @[inclusive,exclusive)@ range. +-- +-- /This is a specialization of 'realFloat', offered for convenience./ +-- +float :: MonadGen m => Range Float -> m Float +float = + realFloat + +-- | Generates a random floating-point number in the @[inclusive,exclusive)@ range. +-- +-- /This is a specialization of 'realFloat', offered for convenience./ +-- +double :: MonadGen m => Range Double -> m Double +double = + realFloat + +------------------------------------------------------------------------ +-- Combinators - Enumeration + +-- | Generates an element from an enumeration. +-- +-- This generator shrinks towards the first argument. +-- +-- For example: +-- +-- @ +-- enum \'a' \'z' :: 'Gen' 'Char' +-- @ +-- +enum :: (MonadGen m, Enum a) => a -> a -> m a +enum lo hi = + fmap toEnum . integral $ + Range.constant (fromEnum lo) (fromEnum hi) + +-- | Generates a random value from a bounded enumeration. +-- +-- This generator shrinks towards 'minBound'. +-- +-- For example: +-- +-- @ +-- enumBounded :: 'Gen' 'Bool' +-- @ +-- +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')@ +-- +unicode :: MonadGen m => m Char +unicode = + filter (not . isNoncharacter) $ filter (not . isSurrogate) unicodeAll + +-- | Generates a Unicode character, including noncharacters and invalid standalone surrogates: +-- @'\0'..'\1114111'@ +-- +unicodeAll :: MonadGen m => m Char +unicodeAll = + enumBounded + +-- | Check if a character is in the surrogate category. +-- +isSurrogate :: Char -> Bool +isSurrogate x = + x >= '\55296' && x <= '\57343' + +-- | Check if a character is one of the noncharacters '\65534', '\65535'. +-- +isNoncharacter :: Char -> Bool +isNoncharacter x = + x == '\65534' || x == '\65535' + +------------------------------------------------------------------------ +-- Combinators - Strings + +-- | Generates a string using 'Range' to determine the length. +-- +-- /This is a specialization of 'list', offered for convenience./ +-- +string :: MonadGen m => Range Int -> m Char -> m String +string = + list + +-- | Generates a string using 'Range' to determine the length. +-- +text :: MonadGen m => Range Int -> m Char -> m Text +text range = + fmap Text.pack . string range + +-- | Generates a UTF-8 encoded string, using 'Range' to determine the length. +-- +utf8 :: MonadGen m => Range Int -> m Char -> m ByteString +utf8 range = + fmap Text.encodeUtf8 . text range + +-- | Generates a random 'ByteString', using 'Range' to determine the +-- length. +-- +bytes :: MonadGen m => Range Int -> m ByteString +bytes range = + fmap ByteString.pack $ + choice [ + list range . word8 $ + Range.constant + (fromIntegral $ Char.ord 'a') + (fromIntegral $ Char.ord 'z') + + , list range . word8 $ + Range.constant minBound maxBound + ] + +------------------------------------------------------------------------ +-- Combinators - Choice + +-- | Trivial generator that always produces the same element. +-- +-- /This is another name for 'pure' \/ 'return'./ +constant :: MonadGen m => a -> m a +constant = + pure + +-- | Randomly selects one of the elements in the list. +-- +-- This generator shrinks towards the first element in the list. +-- +-- /The input list must be non-empty./ +-- +element :: MonadGen m => [a] -> m a +element = \case + [] -> + error "Hedgehog.Gen.element: used with empty list" + xs -> do + n <- integral $ Range.constant 0 (length xs - 1) + pure $ xs !! n + +-- | Randomly selects one of the generators in the list. +-- +-- This generator shrinks towards the first generator in the list. +-- +-- /The input list must be non-empty./ +-- +choice :: MonadGen m => [m a] -> m a +choice = \case + [] -> + error "Hedgehog.Gen.choice: used with empty list" + xs -> do + n <- integral $ Range.constant 0 (length xs - 1) + xs !! n + +-- | Uses a weighted distribution to randomly select one of the generators in +-- the list. +-- +-- This generator shrinks towards the first generator in the list. +-- +-- /The input list must be non-empty./ +-- +frequency :: MonadGen m => [(Int, m a)] -> m a +frequency = \case + [] -> + error "Hedgehog.Gen.frequency: used with empty list" + xs0 -> do + let + pick n = \case + [] -> + error "Hedgehog.Gen.frequency/pick: used with empty list" + (k, x) : xs -> + if n <= k then + x + else + pick (n - k) xs + + total = + sum (fmap fst xs0) + + n <- integral $ Range.constant 1 total + pick n xs0 + +-- | Modifies combinators which choose from a list of generators, like 'choice' +-- or 'frequency', so that they can be used in recursive scenarios. +-- +-- This combinator modifies its target to select one of the generators in +-- either the non-recursive or the recursive list. When a selection is made +-- from the recursive list, the 'Size' is halved. When the 'Size' gets to one +-- or less, selections are no longer made from the recursive list, this +-- ensures termination. +-- +-- A good example of where this might be useful is abstract syntax trees: +-- +-- @ +-- data Expr = +-- Var String +-- | Lam String Expr +-- | App Expr Expr +-- +-- -- Assuming we have a name generator +-- genName :: 'MonadGen' m => m String +-- +-- -- We can write a generator for expressions +-- genExpr :: 'MonadGen' m => m Expr +-- genExpr = +-- Gen.'recursive' Gen.'choice' [ +-- -- non-recursive generators +-- Var '<$>' genName +-- ] [ +-- -- recursive generators +-- Gen.'subtermM' genExpr (\x -> Lam '<$>' genName '<*>' pure x) +-- , Gen.'subterm2' genExpr genExpr App +-- ] +-- @ +-- +-- If we wrote the above example using only 'choice', it is likely that it +-- would fail to terminate. This is because for every call to @genExpr@, +-- there is a 2 in 3 chance that we will recurse again. +-- +recursive :: MonadGen m => ([m a] -> m a) -> [m a] -> [m a] -> m a +recursive f nonrec rec = + sized $ \n -> + if n <= 1 then + f nonrec + else + f $ nonrec ++ fmap small rec + +------------------------------------------------------------------------ +-- Combinators - Conditional + +-- | Discards the whole generator. +-- +discard :: MonadGen m => m a +discard = + liftGen mzero + +-- | 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 + +-- | 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 => (a -> Bool) -> m a -> m a +filter p gen = + let + try k = + if k > 100 then + discard + else do + x <- scale (2 * k +) gen + if p x then + pure x + else + 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 => 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" + +------------------------------------------------------------------------ +-- 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 a list using a 'Range' to determine the length. +-- +list :: MonadGen m => Range Int -> m a -> m [a] +list range gen = + sized $ \size -> + (traverse snd =<<) . + ensure (atLeast $ Range.lowerBound size range) . + shrink Shrink.list $ do + k <- integral_ range + replicateM k (freeze gen) + +-- | 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 = + freezeGen + +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] +shuffle = \case + [] -> + pure [] + xs0 -> do + n <- integral $ Range.constant 0 (length xs0 - 1) + case splitAt n xs0 of + (xs, y : ys) -> + (y :) <$> shuffle (xs ++ ys) + (_, []) -> + error "Hedgehog.Gen.shuffle: internal error, split generated empty list" + +------------------------------------------------------------------------ +-- 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 runIdentity . runMaybeT . runTree $ runGenT 30 seed gen of + Nothing -> + loop (n - 1) + Just x -> + pure $ nodeValue x + in + loop (100 :: Int) + +-- | 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 + let + Node x ss = + runIdentity . runTree $ renderNodes size seed gen + + putStrLn "=== Outcome ===" + putStrLn x + putStrLn "=== Shrinks ===" + + for_ ss $ \s -> + let + Node y _ = + runIdentity $ runTree s + in + putStrLn y + +-- | 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 . runIdentity . Tree.render $ renderNodes size seed gen + +-- | 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 + +-- | 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 + +-- | Render a generator as a tree of strings. +-- +renderNodes :: (Monad m, Show a) => Size -> Seed -> Gen a -> Tree m String +renderNodes size seed = + fmap (Maybe.maybe "" show) . runDiscardEffect . runGenT size seed . lift + +------------------------------------------------------------------------ +-- 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. diff --git a/src/Hedgehog/Internal/HTraversable.hs b/src/Hedgehog/Internal/HTraversable.hs new file mode 100644 index 0000000..9a98ecb --- /dev/null +++ b/src/Hedgehog/Internal/HTraversable.hs @@ -0,0 +1,13 @@ +{-# 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) diff --git a/src/Hedgehog/Internal/Opaque.hs b/src/Hedgehog/Internal/Opaque.hs new file mode 100644 index 0000000..847bf21 --- /dev/null +++ b/src/Hedgehog/Internal/Opaque.hs @@ -0,0 +1,28 @@ +{-# 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" diff --git a/src/Hedgehog/Internal/Property.hs b/src/Hedgehog/Internal/Property.hs new file mode 100644 index 0000000..36f636a --- /dev/null +++ b/src/Hedgehog/Internal/Property.hs @@ -0,0 +1,806 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Distributive +module Hedgehog.Internal.Property ( + -- * Property + Property(..) + , PropertyT(..) + , PropertyName(..) + , PropertyConfig(..) + , TestLimit(..) + , DiscardLimit(..) + , ShrinkLimit(..) + , ShrinkRetries(..) + , withTests + , withDiscards + , withShrinks + , withRetries + , property + , test + , forAll + , forAllT + , forAllWith + , forAllWithT + , discard + + -- * Group + , Group(..) + , GroupName(..) + + -- * TestT + , MonadTest(..) + , Test + , TestT(..) + , Log(..) + , Failure(..) + , Diff(..) + , annotate + , annotateShow + , footnote + , footnoteShow + , failure + , success + , assert + , (===) + , (/==) + + , eval + , evalM + , evalIO + , evalEither + , evalExceptT + + -- * Internal + -- $internal + , defaultConfig + , mapConfig + , failDiff + , failException + , failWith + , writeLog + + , mkTest + , mkTestT + , runTest + , runTestT + ) where + +import Control.Applicative (Alternative(..)) +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 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.Identity (Identity(..)) +import qualified Data.List as List +import Data.Semigroup (Semigroup) +import Data.String (IsString) +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.Show +import Hedgehog.Internal.Source + +import Language.Haskell.TH.Lift (deriveLift) + +------------------------------------------------------------------------ + +-- | 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 + ) + +-- | 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 [Log] m) a + } deriving ( + Functor + , Applicative + , MonadIO + , MonadBase b + , MonadThrow + , MonadCatch + , MonadReader r + , MonadState s + ) + +-- | The name of a property. +-- +-- Can be constructed using `OverloadedStrings`: +-- +-- @ +-- "apples" :: PropertyName +-- @ +-- +newtype PropertyName = + PropertyName { + unPropertyName :: String + } deriving (Eq, Ord, Show, IsString, Semigroup) + +-- | Configuration for a property test. +-- +data PropertyConfig = + PropertyConfig { + propertyTestLimit :: !TestLimit + , propertyDiscardLimit :: !DiscardLimit + , propertyShrinkLimit :: !ShrinkLimit + , propertyShrinkRetries :: !ShrinkRetries + } deriving (Eq, Ord, Show) + +-- | 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) + +-- | 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) + +-- | 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) + +-- | 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) + +-- | A named collection of property tests. +-- +data Group = + Group { + groupName :: !GroupName + , groupProperties :: ![(PropertyName, Property)] + } + +-- | The name of a group of properties. +-- +-- Can be constructed using `OverloadedStrings`: +-- +-- @ +-- "fruit" :: GroupName +-- @ +-- +newtype GroupName = + GroupName { + unGroupName :: String + } deriving (Eq, Ord, Show, IsString, Semigroup) + +-- +-- 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 create their own diffs anywhere. +-- + +-- | Log messages which are recorded during a test run. +-- +data Log = + Annotation (Maybe Span) String + | Footnote String + deriving (Eq, Show) + +-- | 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) + +------------------------------------------------------------------------ +-- TestT + +instance Monad m => Monad (TestT m) where + return = + TestT . return + + (>>=) m k = + TestT $ + unTest m >>= + unTest . k + + 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 Distributive TestT where + type Transformer t TestT m = ( + Transformer t (Lazy.WriterT [Log]) m + , Transformer t (ExceptT Failure) (Lazy.WriterT [Log] m) + ) + + distribute = + hoist TestT . + distribute . + hoist distribute . + 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, [Log]) + + liftWith f = + mkTestT . fmap (, []) . 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, [Log]) -> TestT m a +mkTestT = + TestT . ExceptT . Lazy.WriterT + +mkTest :: (Either Failure a, [Log]) -> Test a +mkTest = + mkTestT . Identity + +runTestT :: TestT m a -> m (Either Failure a, [Log]) +runTestT = + Lazy.runWriterT . runExceptT . unTest + +runTest :: Test a -> (Either Failure a, [Log]) +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 (), [x]) + +-- | Fail the test with an error message, useful for building other failure +-- combinators. +-- +failWith :: (MonadTest m, HasCallStack) => Maybe Diff -> String -> m a +failWith diff msg = + liftTest $ mkTest (Left $ Failure (getCaller callStack) msg diff, []) + +-- | 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 which 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 [ + "━━━ Not Equal ━━━" + , showPretty x + , showPretty y + ] + Just diff -> + withFrozenCallStack $ + failWith (Just $ Diff "Failed (" "- lhs" "=/=" "+ rhs" ")" diff) "" + +-- | Fails with an error which renders the type of an exception and its error +-- message. +-- +failException :: (MonadTest m, HasCallStack) => SomeException -> m a +failException (SomeException x) = + withFrozenCallStack $ + failWith Nothing $ unlines [ + "━━━ 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 + +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 = do + ok <- withFrozenCallStack $ eval (x == y) + if ok then + success + else + withFrozenCallStack $ failDiff 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 = do + ok <- withFrozenCallStack $ eval (x /= y) + if ok then + success + else + withFrozenCallStack $ + failWith Nothing $ unlines [ + "━━━ Both equal to ━━━" + , showPretty x + ] + +-- | 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 action throws an exception. +-- +-- /The benefit of using this over simply letting the exception bubble up is/ +-- /that the location of the closest 'evalM' will be shown in the output./ +-- +evalM :: (MonadTest m, MonadCatch m, HasCallStack) => m a -> m a +evalM m = + either (withFrozenCallStack failException) pure =<< tryAll m + +-- | Fails the test if the 'IO' action throws an exception. +-- +-- /The benefit of using this over 'liftIO' is that the location of the/ +-- /exception will be shown in the output./ +-- +evalIO :: (MonadTest m, MonadIO m, HasCallStack) => IO a -> m a +evalIO m = + either (withFrozenCallStack failException) pure =<< liftIO (tryAll m) + +-- | Fails the test if the 'Either' is 'Left', otherwise returns the value in +-- the 'Right'. +-- +evalEither :: (MonadTest m, Show x, HasCallStack) => Either x a -> m a +evalEither = \case + Left x -> + withFrozenCallStack $ failWith Nothing $ showPretty x + Right x -> + pure x + +-- | Fails the test if the 'ExceptT' is 'Left', otherwise returns the value in +-- the 'Right'. +-- +evalExceptT :: (MonadTest m, Show x, HasCallStack) => ExceptT x m a -> m a +evalExceptT m = + withFrozenCallStack evalEither =<< runExceptT m + +------------------------------------------------------------------------ +-- PropertyT + +instance MonadTrans PropertyT where + lift = + PropertyT . lift . lift + +instance MFunctor PropertyT where + hoist f = + PropertyT . hoist (hoist f) . unPropertyT + +instance Distributive PropertyT where + type Transformer t PropertyT m = ( + Transformer t GenT m + , Transformer t TestT (GenT m) + ) + + distribute = + hoist PropertyT . + distribute . + hoist distribute . + 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.lift 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.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'. +-- +-- One use case for this is writing tests which use 'ResourceT': +-- +-- @ +-- property $ do +-- n <- forAll $ Gen.int64 Range.linearBounded +-- test . runResourceT $ do +-- -- test with resource usage here +-- @ +-- +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 { + propertyTestLimit = + 100 + , propertyDiscardLimit = + 100 + , propertyShrinkLimit = + 1000 + , propertyShrinkRetries = + 0 + } + +-- | Map a config modification function over a property. +-- +mapConfig :: (PropertyConfig -> PropertyConfig) -> Property -> Property +mapConfig f (Property cfg t) = + Property (f cfg) t + +-- | 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 = + mapConfig $ \config -> config { propertyTestLimit = n } + +-- | 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) + +------------------------------------------------------------------------ +-- FIXME Replace with DeriveLift when we drop 7.10 support. + +$(deriveLift ''GroupName) +$(deriveLift ''PropertyName) +$(deriveLift ''PropertyConfig) +$(deriveLift ''TestLimit) +$(deriveLift ''DiscardLimit) +$(deriveLift ''ShrinkLimit) +$(deriveLift ''ShrinkRetries) + +------------------------------------------------------------------------ +-- 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. diff --git a/src/Hedgehog/Internal/Queue.hs b/src/Hedgehog/Internal/Queue.hs new file mode 100644 index 0000000..8a03783 --- /dev/null +++ b/src/Hedgehog/Internal/Queue.hs @@ -0,0 +1,118 @@ +{-# 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) diff --git a/src/Hedgehog/Internal/Range.hs b/src/Hedgehog/Internal/Range.hs new file mode 100644 index 0000000..8aed6a1 --- /dev/null +++ b/src/Hedgehog/Internal/Range.hs @@ -0,0 +1,478 @@ +{-# 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 which depends on the particular generator used. +-- +newtype Size = + Size { + unSize :: Int + } deriving (Eq, Ord, Num, Real, Enum, Integral) + +instance Show Size where + showsPrec p (Size x) = + showParen (p > 10) $ + showString "Size " . + showsPrec 11 x + +instance Read Size where + readsPrec p = + readParen (p > 10) $ \r0 -> do + ("Size", r1) <- lex r0 + (s, r2) <- readsPrec 11 r1 + pure (Size s, r2) + +-- | A range describes the bounds of a number to generate, which may or may not +-- be dependent on a 'Size'. +-- +-- The constructor takes an origin between the lower and upper bound, and a +-- function from 'Size' to bounds. As the size goes towards @0@, the values +-- go towards the origin. +-- +data Range a = + Range !a (Size -> (a, a)) + +instance Functor Range where + fmap f (Range z g) = + Range (f z) $ \sz -> + bimap f f (g sz) + +-- | Get the origin of a range. This might be the mid-point or the lower bound, +-- depending on what the range represents. +-- +-- The 'bounds' of a range are scaled around this value when using the +-- 'linear' family of combinators. +-- +-- When using a 'Range' to generate numbers, the shrinking function will +-- shrink towards the origin. +-- +origin :: Range a -> a +origin (Range z _) = + z + +-- | Get the extents of a range, for a given size. +-- +bounds :: Size -> Range a -> (a, a) +bounds sz (Range _ f) = + f sz + +-- | Get the lower bound of a range for the given size. +-- +lowerBound :: Ord a => Size -> Range a -> a +lowerBound sz range = + let + (x, y) = + bounds sz range + in + min x y + +-- | Get the upper bound of a range for the given size. +-- +upperBound :: Ord a => Size -> Range a -> a +upperBound sz range = + let + (x, y) = + bounds sz range + in + max x y + +-- | Construct a range which represents a constant single value. +-- +-- >>> bounds x $ singleton 5 +-- (5,5) +-- +-- >>> origin $ singleton 5 +-- 5 +-- +singleton :: a -> Range a +singleton x = + Range x $ \_ -> (x, x) + +-- | Construct a range which is unaffected by the size parameter. +-- +-- A range from @0@ to @10@, with the origin at @0@: +-- +-- >>> bounds x $ constant 0 10 +-- (0,10) +-- +-- >>> origin $ constant 0 10 +-- 0 +-- +constant :: a -> a -> Range a +constant x y = + constantFrom x x y + +-- | Construct a range which is unaffected by the size parameter with a origin +-- point which may differ from the bounds. +-- +-- A range from @-10@ to @10@, with the origin at @0@: +-- +-- >>> bounds x $ constantFrom 0 (-10) 10 +-- (-10,10) +-- +-- >>> origin $ constantFrom 0 (-10) 10 +-- 0 +-- +-- A range from @1970@ to @2100@, with the origin at @2000@: +-- +-- >>> bounds x $ constantFrom 2000 1970 2100 +-- (1970,2100) +-- +-- >>> origin $ constantFrom 2000 1970 2100 +-- 2000 +-- +constantFrom :: + a -- ^ Origin (the value produced when the size parameter is 0). + -> a -- ^ Lower bound (the bottom of the range when the size parameter is 99). + -> a -- ^ Upper bound (the top of the range when the size parameter is 99). + -> Range a +constantFrom z x y = + Range z $ \_ -> (x, y) + +-- | Construct a range which is unaffected by the size parameter using the full +-- range of a data type. +-- +-- A range from @-128@ to @127@, with the origin at @0@: +-- +-- >>> bounds x (constantBounded :: Range Int8) +-- (-128,127) +-- +-- >>> origin (constantBounded :: Range Int8) +-- 0 +-- +constantBounded :: (Bounded a, Num a) => Range a +constantBounded = + constantFrom 0 minBound maxBound + +-- | Construct a range which scales the second bound relative to the size +-- parameter. +-- +-- >>> bounds 0 $ linear 0 10 +-- (0,0) +-- +-- >>> bounds 50 $ linear 0 10 +-- (0,5) +-- +-- >>> bounds 99 $ linear 0 10 +-- (0,10) +-- +linear :: Integral a => a -> a -> Range a +linear x y = + linearFrom x x y + +-- | Construct a range which scales the bounds relative to the size parameter. +-- +-- >>> bounds 0 $ linearFrom 0 (-10) 10 +-- (0,0) +-- +-- >>> bounds 50 $ linearFrom 0 (-10) 20 +-- (-5,10) +-- +-- >>> bounds 99 $ linearFrom 0 (-10) 20 +-- (-10,20) +-- +linearFrom :: Integral a + => a -- ^ Origin (the value produced when the size parameter is 0). + -> a -- ^ Lower bound (the bottom of the range when the size parameter is 99). + -> a -- ^ Upper bound (the top of the range when the size parameter is 99). + -> Range a +linearFrom z x y = + Range z $ \sz -> + let + x_sized = + clamp x y $ scaleLinear sz z x + + y_sized = + clamp x y $ scaleLinear sz z y + in + (x_sized, y_sized) + +-- | Construct a range which is scaled relative to the size parameter and uses +-- the full range of a data type. +-- +-- >>> bounds 0 (linearBounded :: Range Int8) +-- (0,0) +-- +-- >>> bounds 50 (linearBounded :: Range Int8) +-- (-64,64) +-- +-- >>> bounds 99 (linearBounded :: Range Int8) +-- (-128,127) +-- +linearBounded :: (Bounded a, Integral a) => Range a +linearBounded = + linearFrom 0 minBound maxBound + +-- | Construct a range which scales the second bound relative to the size +-- parameter. +-- +-- This works the same as 'linear', but for fractional values. +-- +linearFrac :: (Fractional a, Ord a) => a -> a -> Range a +linearFrac x y = + linearFracFrom x x y + +-- | Construct a range which scales the bounds relative to the size parameter. +-- +-- This works the same as 'linearFrom', but for fractional values. +-- +linearFracFrom :: (Fractional a, Ord a) => a -> a -> a -> Range a +linearFracFrom z x y = + Range z $ \sz -> + let + x_sized = + clamp x y $ scaleLinearFrac sz z x + + y_sized = + clamp x y $ scaleLinearFrac sz z y + in + (x_sized, y_sized) + +-- | Truncate a value so it stays within some range. +-- +-- >>> clamp 5 10 15 +-- 10 +-- +-- >>> clamp 5 10 0 +-- 5 +-- +clamp :: Ord a => a -> a -> a -> a +clamp x y n = + if x > y then + min x (max y n) + else + min y (max x n) + +-- | Scale an integral linearly with the size parameter. +-- +scaleLinear :: Integral a => Size -> a -> a -> a +scaleLinear sz0 z0 n0 = + let + sz = + max 0 (min 99 sz0) + + z = + toInteger z0 + + n = + toInteger n0 + + diff = + ((n - z) * fromIntegral sz) `quot` 99 + in + fromInteger $ z + diff + +-- | Scale a fractional number linearly with the size parameter. +-- +scaleLinearFrac :: Fractional a => Size -> a -> a -> a +scaleLinearFrac sz0 z n = + let + sz = + max 0 (min 99 sz0) + + diff = + (n - z) * (fromIntegral sz / 99) + in + z + diff + +-- | Construct a range which scales the second bound exponentially relative to +-- the size parameter. +-- +-- >>> bounds 0 $ exponential 1 512 +-- (1,1) +-- +-- >>> bounds 11 $ exponential 1 512 +-- (1,2) +-- +-- >>> bounds 22 $ exponential 1 512 +-- (1,4) +-- +-- >>> bounds 77 $ exponential 1 512 +-- (1,128) +-- +-- >>> bounds 88 $ exponential 1 512 +-- (1,256) +-- +-- >>> bounds 99 $ exponential 1 512 +-- (1,512) +-- +exponential :: Integral a => a -> a -> Range a +exponential x y = + exponentialFrom x x y + +-- | Construct a range which scales the bounds exponentially relative to the +-- size parameter. +-- +-- >>> bounds 0 $ exponentialFrom 0 (-128) 512 +-- (0,0) +-- +-- >>> bounds 25 $ exponentialFrom 0 (-128) 512 +-- (-2,4) +-- +-- >>> bounds 50 $ exponentialFrom 0 (-128) 512 +-- (-11,22) +-- +-- >>> bounds 75 $ exponentialFrom 0 (-128) 512 +-- (-39,112) +-- +-- >>> bounds 99 $ exponentialFrom x (-128) 512 +-- (-128,512) +-- +exponentialFrom :: Integral a + => a -- ^ Origin (the value produced when the size parameter is 0). + -> a -- ^ Lower bound (the bottom of the range when the size parameter is 99). + -> a -- ^ Upper bound (the top of the range when the size parameter is 99). + -> Range a +exponentialFrom z x y = + Range z $ \sz -> + let + sized_x = + clamp x y $ scaleExponential sz z x + + sized_y = + clamp x y $ scaleExponential sz z y + in + (sized_x, sized_y) + +-- | Construct a range which is scaled exponentially relative to the size +-- parameter and uses the full range of a data type. +-- +-- >>> bounds 0 (exponentialBounded :: Range Int8) +-- (0,0) +-- +-- >>> bounds 50 (exponentialBounded :: Range Int8) +-- (-11,11) +-- +-- >>> bounds 99 (exponentialBounded :: Range Int8) +-- (-128,127) +-- +exponentialBounded :: (Bounded a, Integral a) => Range a +exponentialBounded = + exponentialFrom 0 minBound maxBound + +-- | Construct a range which scales the second bound exponentially relative to +-- the size parameter. +-- +-- This works the same as 'exponential', but for floating-point values. +-- +-- >>> bounds 0 $ exponentialFloat 0 10 +-- (0.0,0.0) +-- +-- >>> bounds 50 $ exponentialFloat 0 10 +-- (0.0,2.357035250656098) +-- +-- >>> bounds 99 $ exponentialFloat 0 10 +-- (0.0,10.0) +-- +exponentialFloat :: (Floating a, Ord a) => a -> a -> Range a +exponentialFloat x y = + exponentialFloatFrom x x y + +-- | Construct a range which scales the bounds exponentially relative to the +-- size parameter. +-- +-- This works the same as 'exponentialFrom', but for floating-point values. +-- +-- >>> bounds 0 $ exponentialFloatFrom 0 (-10) 20 +-- (0.0,0.0) +-- +-- >>> bounds 50 $ exponentialFloatFrom 0 (-10) 20 +-- (-2.357035250656098,3.6535836249197002) +-- +-- >>> bounds 99 $ exponentialFloatFrom x (-10) 20 +-- (-10.0,20.0) +-- +exponentialFloatFrom :: (Floating a, Ord a) => a -> a -> a -> Range a +exponentialFloatFrom z x y = + Range z $ \sz -> + let + sized_x = + clamp x y $ scaleExponentialFloat sz z x + + sized_y = + clamp x y $ scaleExponentialFloat sz z y + in + (sized_x, sized_y) + +-- | Scale an integral exponentially with the size parameter. +-- +scaleExponential :: Integral a => Size -> a -> a -> a +scaleExponential sz z0 n0 = + let + z = + fromIntegral z0 + + n = + fromIntegral n0 + in + round (scaleExponentialFloat sz z n :: Double) + +-- | Scale a floating-point number exponentially with the size parameter. +-- +scaleExponentialFloat :: Floating a => Size -> a -> a -> a +scaleExponentialFloat sz0 z n = + let + sz = + clamp 0 99 sz0 + + diff = + (((abs (n - z) + 1) ** (realToFrac sz / 99)) - 1) * signum (n - z) + in + z + diff + + +------------------------------------------------------------------------ +-- Internal + +-- $internal +-- +-- These functions are exported in case you need them in a pinch, but are not +-- part of the public API and may change at any time, even as part of a minor +-- update. diff --git a/src/Hedgehog/Internal/Region.hs b/src/Hedgehog/Internal/Region.hs new file mode 100644 index 0000000..139a4f3 --- /dev/null +++ b/src/Hedgehog/Internal/Region.hs @@ -0,0 +1,128 @@ +{-# 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 () diff --git a/src/Hedgehog/Internal/Report.hs b/src/Hedgehog/Internal/Report.hs new file mode 100644 index 0000000..ca44ef7 --- /dev/null +++ b/src/Hedgehog/Internal/Report.hs @@ -0,0 +1,903 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +module Hedgehog.Internal.Report ( + -- * Report + Summary(..) + , Report(..) + , Progress(..) + , Result(..) + , FailureReport(..) + , FailedAnnotation(..) + + , ShrinkCount(..) + , TestCount(..) + , DiscardCount(..) + , PropertyCount(..) + + , 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.Semigroup (Semigroup(..)) + +import Hedgehog.Internal.Config +import Hedgehog.Internal.Discovery (Pos(..), Position(..)) +import qualified Hedgehog.Internal.Discovery as Discovery +import Hedgehog.Internal.Property (PropertyName(..), Log(..), Diff(..)) +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) + +import Text.PrettyPrint.Annotated.WL (Doc, (<+>)) +import qualified Text.PrettyPrint.Annotated.WL as WL +import Text.Printf (printf) + +------------------------------------------------------------------------ +-- Data + +-- | 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 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 properties in a group. +-- +newtype PropertyCount = + PropertyCount Int + deriving (Eq, Ord, Show, Num, Enum, Real, Integral) + +data FailedAnnotation = + FailedAnnotation { + failedSpan :: !(Maybe Span) + , failedValue :: !String + } deriving (Eq, Show) + +data FailureReport = + FailureReport { + failureSize :: !Size + , failureSeed :: !Seed + , failureShrinks :: !ShrinkCount + , 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 + , 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 + | FailedHeader + | GaveUpIcon + | GaveUpHeader + | SuccessIcon + | SuccessHeader + | 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 Span + -> String + -> Maybe Diff + -> [Log] + -> FailureReport +mkFailure size seed shrinks location message diff logs = + let + inputs = + mapMaybe takeAnnotation logs + + footnotes = + mapMaybe takeFootnote logs + in + FailureReport size seed shrinks 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 + => String + -> Maybe Diff + -> Span + -> m (Maybe (Declaration (Style, [(Style, Doc Markup)]))) +ppFailureLocation msg 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 . WL.text) (List.lines msg) + + diffDocs = + case mdiff of + Nothing -> + [] + Just diff -> + fmap ((StyleFailure, ) . ppFailure) (ppDiff diff) + + docs = + [(StyleFailure, arrowDoc)] ++ msgDocs ++ diffDocs + + startLine = + spanStartLine sloc + + endLine = + spanEndLine sloc + + styleFailure kvs = + foldr (Map.adjust . fmap . first $ const StyleFailure) kvs [startLine..endLine] + + insertDoc = + Map.adjust (fmap . second $ const docs) endLine + + pure $ + mapSource (styleFailure . insertDoc) decl + +ppDeclaration :: Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup +ppDeclaration decl = + case Map.maxView $ declarationSource decl of + Nothing -> + mempty + Just (lastLine, _) -> + let + ppLocation = + WL.indent (digits + 1) $ + markup (StyledBorder StyleDefault) "┏━━" <+> + markup DeclarationLocation (WL.text (declarationFile decl)) <+> + markup (StyledBorder StyleDefault) "━━━" + + digits = + length . show . unLineNo $ lineNumber lastLine + + ppLineNo = + WL.text . printf ("%" <> show digits <> "d") . unLineNo + + ppEmptyNo = + WL.text $ replicate digits ' ' + + ppSource style n src = + markup (StyledLineNo style) (ppLineNo n) <+> + markup (StyledBorder style) "┃" <+> + markup (StyledSource style) (WL.text src) + + ppAnnot (style, doc) = + markup (StyledLineNo style) ppEmptyNo <+> + markup (StyledBorder style) "┃" <+> + doc + + ppLines = do + Line (style, xs) n src <- Map.elems $ declarationSource decl + ppSource style n src : fmap ppAnnot xs + in + WL.vsep (ppLocation : ppLines) + +ppReproduce :: Maybe PropertyName -> Size -> Seed -> Doc Markup +ppReproduce name size seed = + WL.vsep [ + markup ReproduceHeader + "This failure can be reproduced by running:" + , gutter ReproduceGutter . markup ReproduceSource $ + "recheck" <+> + WL.text (showsPrec 11 size "") <+> + WL.text (showsPrec 11 seed "") <+> + maybe "" (WL.text . unPropertyName) name + ] + +mergeLine :: Semigroup a => Line a -> Line a -> Line a +mergeLine (Line x no src) (Line y _ _) = + Line (x <> y) no src + +mergeDeclaration :: Semigroup a => Declaration a -> Declaration a -> Declaration a +mergeDeclaration (Declaration file line name src0) (Declaration _ _ _ src1) = + Declaration file line name $ + Map.unionWith mergeLine src0 src1 + +mergeDeclarations :: Semigroup a => [Declaration a] -> [Declaration a] +mergeDeclarations = + Map.elems . + Map.fromListWith mergeDeclaration . + fmap (\d -> ((declarationFile d, declarationLine d), d)) + +ppTextLines :: String -> [Doc Markup] +ppTextLines = + fmap WL.text . List.lines + +ppFailureReport :: MonadIO m => Maybe PropertyName -> FailureReport -> m (Doc Markup) +ppFailureReport name (FailureReport size seed _ inputs0 mlocation0 msg mdiff msgs0) = do + (msgs, mlocation) <- + case mlocation0 of + Nothing -> + -- Move the failure message to the end section if we have + -- no source location. + let + msgs1 = + msgs0 ++ + (if null msg then [] else [msg]) + + docs = + concatMap ppTextLines msgs1 ++ + maybe [] ppDiff mdiff + in + pure (docs, Nothing) + + Just location0 -> + (concatMap ppTextLines msgs0,) + <$> ppFailureLocation msg mdiff location0 + + (args, idecls) <- partitionEithers <$> zipWithM ppFailedInput [0..] inputs0 + + let + decls = + mergeDeclarations . + catMaybes $ + mlocation : fmap pure idecls + + with xs f = + if null xs then + [] + else + [f xs] + + pure . WL.indent 2 . WL.vsep . WL.punctuate WL.line $ concat [ + with args $ + WL.vsep . WL.punctuate WL.line + , with decls $ + WL.vsep . WL.punctuate WL.line . fmap ppDeclaration + , with msgs $ + WL.vsep + , [ppReproduce name size seed] + ] + +ppName :: Maybe PropertyName -> Doc a +ppName = \case + Nothing -> + "" + Just (PropertyName name) -> + WL.text name + +ppProgress :: MonadIO m => Maybe PropertyName -> Report Progress -> m (Doc Markup) +ppProgress name (Report tests discards status) = + case status of + Running -> + pure . icon RunningIcon '●' . WL.annotate RunningHeader $ + ppName name <+> + "passed" <+> + ppTestCount tests <> + ppWithDiscardCount discards <+> + "(running)" + + Shrinking failure -> + pure . icon ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $ + ppName name <+> + "failed after" <+> + ppTestCount tests <> + ppShrinkDiscard (failureShrinks failure) discards <+> + "(shrinking)" + +ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup) +ppResult name (Report tests discards result) = + case result of + Failed failure -> do + pfailure <- ppFailureReport name failure + pure . WL.vsep $ [ + icon FailedIcon '✗' . WL.annotate FailedHeader $ + ppName name <+> + "failed after" <+> + ppTestCount tests <> + ppShrinkDiscard (failureShrinks failure) discards <> + "." + , mempty + , pfailure + , mempty + ] + + GaveUp -> + pure . icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader $ + ppName name <+> + "gave up after" <+> + ppDiscardCount discards <> + ", passed" <+> + ppTestCount tests <> + "." + + OK -> + pure . icon SuccessIcon '✓' . WL.annotate SuccessHeader $ + ppName name <+> + "passed" <+> + ppTestCount tests <> + "." + +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 FailedHeader + else if summaryGaveUp summary > 0 then + icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader + else if summaryWaiting summary > 0 || summaryRunning summary > 0 then + icon WaitingIcon '○' . WL.annotate WaitingHeader + else + icon SuccessIcon '✓' . WL.annotate SuccessHeader + +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 => Maybe UseColor -> Doc Markup -> m String +renderDoc mcolor 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] + FailedHeader -> + setSGRCode [vivid Red] + GaveUpIcon -> + setSGRCode [dull Yellow] + GaveUpHeader -> + setSGRCode [dull Yellow] + SuccessIcon -> + setSGRCode [dull Green] + SuccessHeader -> + setSGRCode [dull Green] + + 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] + + color <- resolveColor mcolor + + let + display = + case color of + EnableColor -> + WL.displayDecorated start end id + DisableColor -> + WL.display + + pure . + display . + WL.renderSmart 100 $ + WL.indent 2 doc + +renderProgress :: MonadIO m => Maybe UseColor -> Maybe PropertyName -> Report Progress -> m String +renderProgress mcolor name x = + renderDoc mcolor =<< ppProgress name x + +renderResult :: MonadIO m => Maybe UseColor -> Maybe PropertyName -> Report Result -> m String +renderResult mcolor name x = + renderDoc mcolor =<< ppResult name x + +renderSummary :: MonadIO m => Maybe UseColor -> Summary -> m String +renderSummary mcolor x = + renderDoc mcolor =<< ppSummary x diff --git a/src/Hedgehog/Internal/Runner.hs b/src/Hedgehog/Internal/Runner.hs new file mode 100644 index 0000000..174bf46 --- /dev/null +++ b/src/Hedgehog/Internal/Runner.hs @@ -0,0 +1,400 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# 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 Data.Semigroup ((<>)) + +import Hedgehog.Internal.Config +import Hedgehog.Internal.Gen (runGenT, runDiscardEffect) +import Hedgehog.Internal.Property (Group(..), GroupName(..)) +import Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..)) +import Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withTests) +import Hedgehog.Internal.Property (PropertyT(..), Log(..), Failure(..), runTestT) +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 (Tree(..), Node(..)) +import Hedgehog.Range (Size) + +import Language.Haskell.TH.Lift (deriveLift) + + +-- | 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) + +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 :: Node m (Maybe (Either x a, b)) -> Bool +isFailure = \case + Node (Just (Left _, _)) _ -> + True + _ -> + False + +isSuccess :: Node m (Maybe (Either x a, b)) -> Bool +isSuccess = + not . isFailure + +runTreeN :: + Monad m + => ShrinkRetries + -> Tree m (Maybe (Either x a, b)) + -> m (Node m (Maybe (Either x a, b))) +runTreeN n m = do + o <- runTree m + if n > 0 && isSuccess o then + runTreeN (n - 1) m + else + pure o + +takeSmallest :: + MonadIO m + => Size + -> Seed + -> ShrinkCount + -> ShrinkLimit + -> ShrinkRetries + -> (Progress -> m ()) + -> Node m (Maybe (Either Failure (), [Log])) + -> m Result +takeSmallest size seed shrinks slimit retries updateUI = \case + Node Nothing _ -> + pure GaveUp + + Node (Just (x, w)) xs -> + case x of + Left (Failure loc err mdiff) -> do + let + failure = + mkFailure size seed shrinks loc err mdiff (reverse w) + + 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) + + loop :: TestCount -> DiscardCount -> Size -> Seed -> m (Report Result) + loop !tests !discards !size !seed = do + updateUI $ Report tests discards Running + + if size > 99 then + -- size has reached limit, reset to 0 + loop tests discards 0 seed + + else if tests >= fromIntegral (propertyTestLimit cfg) then + -- we've hit the test limit, test was successful + pure $ Report tests discards OK + + else if discards >= fromIntegral (propertyDiscardLimit cfg) then + -- we've hit the discard limit, give up + pure $ Report tests discards GaveUp + + else + case Seed.split seed of + (s0, s1) -> do + node@(Node x _) <- + runTree . runDiscardEffect $ runGenT size s0 . runTestT $ unPropertyT test + case x of + Nothing -> + loop tests (discards + 1) (size + 1) s1 + + Just (Left _, _) -> + let + mkReport = + Report (tests + 1) discards + in + fmap mkReport $ + takeSmallest + size + seed + 0 + (propertyShrinkLimit cfg) + (propertyShrinkRetries cfg) + (updateUI . mkReport) + node + + Just (Right (), _) -> + loop (tests + 1) discards (size + 1) s1 + in + loop 0 0 size0 seed0 + +checkRegion :: + MonadIO m + => Region + -> Maybe UseColor + -> Maybe PropertyName + -> Size + -> Seed + -> Property + -> m (Report Result) +checkRegion region mcolor name size seed prop = + liftIO $ do + result <- + checkReport (propertyConfig prop) size seed (propertyTest prop) $ \progress -> do + ppprogress <- renderProgress mcolor name progress + case reportStatus progress of + Running -> + setRegion region ppprogress + Shrinking _ -> + openRegion region ppprogress + + ppresult <- renderResult mcolor name result + case reportStatus result of + Failed _ -> + openRegion region ppresult + GaveUp -> + openRegion region ppresult + OK -> + setRegion region ppresult + + pure result + +checkNamed :: + MonadIO m + => Region + -> Maybe UseColor + -> Maybe PropertyName + -> Property + -> m (Report Result) +checkNamed region mcolor name prop = do + seed <- liftIO Seed.random + checkRegion region mcolor name 0 seed prop + +-- | Check a property. +-- +check :: MonadIO m => Property -> m Bool +check prop = + liftIO . displayRegion $ \region -> + (== OK) . reportStatus <$> checkNamed region Nothing Nothing prop + +-- | Check a property using a specific size and seed. +-- +recheck :: MonadIO m => Size -> Seed -> Property -> m () +recheck size seed prop0 = do + let prop = withTests 1 prop0 + _ <- liftIO . displayRegion $ \region -> + checkRegion region Nothing 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) + + putStrLn $ "━━━ " ++ unGroupName group ++ " ━━━" + + verbosity <- resolveVerbosity (runnerVerbosity config) + summary <- checkGroupWith n verbosity (runnerColor config) props + + pure $ + summaryFailed summary == 0 && + summaryGaveUp summary == 0 + +updateSummary :: Region -> TVar Summary -> Maybe UseColor -> (Summary -> Summary) -> IO () +updateSummary sregion svar mcolor f = do + summary <- atomically (TVar.modifyTVar' svar f >> TVar.readTVar svar) + setRegion sregion =<< renderSummary mcolor summary + +checkGroupWith :: + WorkerCount + -> Verbosity + -> Maybe UseColor + -> [(PropertyName, Property)] + -> IO Summary +checkGroupWith n verbosity mcolor 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 mcolor $ \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 mcolor $ \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 mcolor (Just name) prop + updateSummary sregion svar mcolor + (<> fromResult (reportStatus result)) + pure result + + updateSummary sregion svar mcolor (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 + } + +------------------------------------------------------------------------ +-- FIXME Replace with DeriveLift when we drop 7.10 support. + +$(deriveLift ''RunnerConfig) diff --git a/src/Hedgehog/Internal/Seed.hs b/src/Hedgehog/Internal/Seed.hs new file mode 100644 index 0000000..61cacb2 --- /dev/null +++ b/src/Hedgehog/Internal/Seed.hs @@ -0,0 +1,230 @@ +{-# 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 +-- +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) +import Data.Int (Int32, Int64) +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 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 + +#include "MachDeps.h" + +#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. diff --git a/src/Hedgehog/Internal/Show.hs b/src/Hedgehog/Internal/Show.hs new file mode 100644 index 0000000..4894026 --- /dev/null +++ b/src/Hedgehog/Internal/Show.hs @@ -0,0 +1,275 @@ +{-# 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 diff --git a/src/Hedgehog/Internal/Shrink.hs b/src/Hedgehog/Internal/Shrink.hs new file mode 100644 index 0000000..3d193d6 --- /dev/null +++ b/src/Hedgehog/Internal/Shrink.hs @@ -0,0 +1,129 @@ +{-# OPTIONS_HADDOCK not-home #-} +module Hedgehog.Internal.Shrink ( + towards + , towardsFloat + , list + + , halves + , removes + , consNub + ) where + + +-- | Shrink an integral number by edging towards a destination. +-- +-- >>> towards 0 100 +-- [0,50,75,88,94,97,99] +-- +-- >>> towards 500 1000 +-- [500,750,875,938,969,985,993,997,999] +-- +-- >>> towards (-50) (-26) +-- [-50,-38,-32,-29,-27] +-- +-- /Note we always try the destination first, as that is the optimal shrink./ +-- +towards :: Integral a => a -> a -> [a] +towards destination x = + if destination == x then + [] + else + let + -- Halve the operands before subtracting them so they don't overflow. + -- Consider 'minBound' and 'maxBound' for a fixed sized type like 'Int64'. + diff = + (x `quot` 2) - (destination `quot` 2) + in + destination `consNub` fmap (x -) (halves diff) + +-- | Shrink a floating-point number by edging towards a destination. +-- +-- >>> take 7 (towardsFloat 0.0 100) +-- [0.0,50.0,75.0,87.5,93.75,96.875,98.4375] +-- +-- >>> take 7 (towardsFloat 1.0 0.5) +-- [1.0,0.75,0.625,0.5625,0.53125,0.515625,0.5078125] +-- +-- /Note we always try the destination first, as that is the optimal shrink./ +-- +towardsFloat :: RealFloat a => a -> a -> [a] +towardsFloat destination x = + if destination == x then + [] + else + let + diff = + x - destination + + ok y = + y /= x && not (isNaN y) && not (isInfinite y) + in + takeWhile ok . + fmap (x -) $ + iterate (/ 2) diff + +-- | Shrink a list by edging towards the empty list. +-- +-- >>> list [1,2,3] +-- [[],[2,3],[1,3],[1,2]] +-- +-- >>> list "abcd" +-- ["","cd","ab","bcd","acd","abd","abc"] +-- +-- /Note we always try the empty list first, as that is the optimal shrink./ +-- +list :: [a] -> [[a]] +list xs = + concatMap + (\k -> removes k xs) + (halves $ length xs) + +-- | Produce all permutations of removing 'k' elements from a list. +-- +-- >>> removes 2 "abcdef" +-- ["cdef","abef","abcd"] +-- +removes :: Int -> [a] -> [[a]] +removes k0 xs0 = + let + loop k n xs = + let + (hd, tl) = + splitAt k xs + in + if k > n then + [] + else if null tl then + [[]] + else + tl : fmap (hd ++) (loop k (n - k) tl) + in + loop k0 (length xs0) xs0 + +-- | Produce a list containing the progressive halving of an integral. +-- +-- >>> halves 15 +-- [15,7,3,1] +-- +-- >>> halves 100 +-- [100,50,25,12,6,3,1] +-- +-- >>> halves (-26) +-- [-26,-13,-6,-3,-1] +-- +halves :: Integral a => a -> [a] +halves = + takeWhile (/= 0) . iterate (`quot` 2) + +-- | Cons an element on to the front of a list unless it is already there. +-- +consNub :: Eq a => a -> [a] -> [a] +consNub x ys0 = + case ys0 of + [] -> + x : [] + y : ys -> + if x == y then + y : ys + else + x : y : ys diff --git a/src/Hedgehog/Internal/Source.hs b/src/Hedgehog/Internal/Source.hs new file mode 100644 index 0000000..7c60392 --- /dev/null +++ b/src/Hedgehog/Internal/Source.hs @@ -0,0 +1,109 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# 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 + +#if MIN_VERSION_base(4,9,0) +import GHC.Stack (CallStack, HasCallStack, SrcLoc(..)) +import GHC.Stack (callStack, getCallStack, withFrozenCallStack) +#else +import GHC.Exts (Constraint) +#endif + +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) + +#if !MIN_VERSION_base(4,9,0) +type family HasCallStack :: Constraint where + HasCallStack = () + +data CallStack = + CallStack + deriving (Show) + +callStack :: HasCallStack => CallStack +callStack = + CallStack + +withFrozenCallStack :: HasCallStack => (HasCallStack => a) -> a +withFrozenCallStack x = + x +#endif + +getCaller :: CallStack -> Maybe Span +#if MIN_VERSION_base(4,9,0) +getCaller stack = + case getCallStack stack of + [] -> + Nothing + (_, x) : _ -> + Just $ Span + (srcLocFile x) + (fromIntegral $ srcLocStartLine x) + (fromIntegral $ srcLocStartCol x) + (fromIntegral $ srcLocEndLine x) + (fromIntegral $ srcLocEndCol x) +#else +getCaller _ = + Nothing +#endif + +------------------------------------------------------------------------ +-- 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 diff --git a/src/Hedgehog/Internal/State.hs b/src/Hedgehog/Internal/State.hs new file mode 100644 index 0000000..2a3aa07 --- /dev/null +++ b/src/Hedgehog/Internal/State.hs @@ -0,0 +1,804 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE CPP #-} +{-# 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.Trans.Class (lift) +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.State (State, runState, execState) +import Control.Monad.Trans.State (StateT(..), evalStateT) + +import Data.Dynamic (Dynamic, toDyn, fromDynamic, dynTypeRep) +import Data.Foldable (traverse_) +import Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..)) +#if MIN_VERSION_transformers(0,5,0) +import Data.Functor.Classes (eq1, compare1, showsPrec1) +#endif +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.Gen (MonadGen) +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) +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. +-- +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 + +#if MIN_VERSION_transformers(0,5,0) +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 +#else +instance Show1 Symbolic where + showsPrec1 p (Symbolic x) = + showsPrec p x + +instance Eq1 Symbolic where + eq1 (Symbolic x) (Symbolic y) = + x == y + +instance Ord1 Symbolic where + compare1 (Symbolic x) (Symbolic y) = + compare x y +#endif + +-- | Concrete values. +-- +newtype Concrete a where + Concrete :: a -> Concrete a + deriving (Eq, Ord, Functor, Foldable, Traversable) + +instance Show a => Show (Concrete a) where + showsPrec = + showsPrec1 + +#if MIN_VERSION_transformers(0,5,0) +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 +#else +instance Show1 Concrete where + showsPrec1 p (Concrete x) = + showsPrec p x + +instance Eq1 Concrete where + eq1 (Concrete x) (Concrete y) = + x == y + +instance Ord1 Concrete where + compare1 (Concrete x) (Concrete y) = + compare x y +#endif + +------------------------------------------------------------------------ + +-- | 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. +-- +data 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 + +-- | 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'. +-- +data Command n m (state :: (* -> *) -> *) = + forall input output. + (HTraversable input, Show (input Symbolic), 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 (n (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 n m state -> state Symbolic -> Bool +commandGenOK (Command inputGen _ _) state = + Maybe.isJust (inputGen state) + +-- | An instantiation of a 'Command' which can be executed, and its effect +-- evaluated. +-- +data Action m (state :: (* -> *) -> *) = + forall input output. + (HTraversable input, Show (input Symbolic)) => + 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 n, MonadTest m) + => [Command n m state] + -> StateT (Context state) n (Action m state) +action commands = + Gen.just $ 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 g -> + lift g + + 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 n, MonadTest m) + => Range Int + -> [Command n m state] + -> Context state + -> n ([Action m state], Context state) +genActions range commands ctx = do + xs <- Gen.list range (action commands) `evalStateT` ctx + pure $ + dropInvalid xs `runState` ctx + +-- | A sequence of actions to execute. +-- +data Sequential m state = + Sequential { + -- | The sequence of actions. + sequentialActions :: [Action m state] + } + +renderAction :: Action m state -> [String] +renderAction (Action input (Symbolic (Name output)) _ _ _ _) = + let + prefix0 = + "Var " ++ show output ++ " = " + + prefix = + replicate (length prefix0) ' ' + in + case lines (showPretty input) of + [] -> + [prefix0 ++ "?"] + x : xs -> + (prefix0 ++ x) : + fmap (prefix ++) xs + +-- 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 n, MonadTest m) + => Range Int + -> (forall v. state v) + -> [Command n m state] + -> n (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 (Parallel pre xs ys) = + unlines $ concat [ + ["━━━ Prefix ━━━"] + , (concatMap renderAction pre) + , ["", "━━━ Branch 1 ━━━"] + , (concatMap renderAction xs) + , ["", "━━━ Branch 2 ━━━"] + , (concatMap renderAction 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 n, MonadTest m) + => Range Int + -> Range Int + -> (forall v. state v) + -> [Command n m state] + -> n (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 (Parallel prefix branch1 branch2) = + withFrozenCallStack $ evalM $ do + (s0, env0) <- foldM executeUpdateEnsure (initial, emptyEnvironment) prefix + + (xs, ys) <- + Async.concurrently + (evalStateT (traverse execute branch1) env0) + (evalStateT (traverse execute branch2) env0) + + linearize s0 xs ys diff --git a/src/Hedgehog/Internal/TH.hs b/src/Hedgehog/Internal/TH.hs new file mode 100644 index 0000000..b0d31ae --- /dev/null +++ b/src/Hedgehog/Internal/TH.hs @@ -0,0 +1,64 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} +module Hedgehog.Internal.TH ( + TExpQ + , discover + ) where + +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Ord as Ord + +import Hedgehog.Internal.Discovery +import Hedgehog.Internal.Property + +import Language.Haskell.TH (Exp(..), Q, TExp, location, runIO) +import Language.Haskell.TH.Syntax (Loc(..), mkName, unTypeQ, unsafeTExpCoerce) + +type TExpQ a = + Q (TExp a) + +-- | Discover all the properties in a module. +-- +-- Functions starting with `prop_` are assumed to be properties. +-- +discover :: TExpQ Group +discover = do + file <- getCurrentFile + properties <- Map.toList <$> runIO (readProperties file) + + let + startLine = + Ord.comparing $ + posLine . + posPostion . + propertySource . + snd + + names = + fmap (mkNamedProperty . fst) $ + List.sortBy startLine properties + + [|| Group $$(moduleName) $$(listTE names) ||] + +mkNamedProperty :: PropertyName -> TExpQ (PropertyName, Property) +mkNamedProperty name = do + [|| (name, $$(unsafeProperty name)) ||] + +unsafeProperty :: PropertyName -> TExpQ Property +unsafeProperty = + unsafeTExpCoerce . pure . VarE . mkName . unPropertyName + +listTE :: [TExpQ a] -> TExpQ [a] +listTE xs = do + unsafeTExpCoerce . pure . ListE =<< traverse unTypeQ xs + +moduleName :: TExpQ GroupName +moduleName = do + loc <- GroupName . loc_module <$> location + [|| loc ||] + +getCurrentFile :: Q FilePath +getCurrentFile = + loc_filename <$> location diff --git a/src/Hedgehog/Internal/Tree.hs b/src/Hedgehog/Internal/Tree.hs new file mode 100644 index 0000000..5aacee4 --- /dev/null +++ b/src/Hedgehog/Internal/Tree.hs @@ -0,0 +1,390 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- MonadBase +module Hedgehog.Internal.Tree ( + Tree(..) + , Node(..) + + , fromNode + + , unfold + , unfoldForest + + , expand + , prune + + , render + ) where + +import Control.Applicative (Alternative(..)) +import Control.Monad (MonadPlus(..), ap, join) +import Control.Monad.Base (MonadBase(..)) +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(..)) +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.Resource (MonadResource(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) + +#if MIN_VERSION_base(4,9,0) +import Data.Functor.Classes (Show1(..), showsPrec1) +import Data.Functor.Classes (showsUnaryWith, showsBinaryWith) +#endif + +import Hedgehog.Internal.Distributive + +------------------------------------------------------------------------ + +-- | An effectful tree, each node in the tree can have an effect before it is +-- produced. +-- +newtype Tree m a = + Tree { + runTree :: m (Node m a) + } + +-- | A node in an effectful tree, as well as its unevaluated children. +-- +data Node m a = + Node { + nodeValue :: a + , nodeChildren :: [Tree m a] + } + +-- | Create a 'Tree' from a 'Node' +-- +fromNode :: Applicative m => Node m a -> Tree m a +fromNode = + Tree . pure + +-- | Create a tree from a value and an unfolding function. +-- +unfold :: Monad m => (a -> [a]) -> a -> Tree m a +unfold f x = + Tree . pure $ + Node x (unfoldForest f x) + +-- | Create a forest from a value and an unfolding function. +-- +unfoldForest :: Monad m => (a -> [a]) -> a -> [Tree m a] +unfoldForest f = + fmap (unfold f) . f + +-- | Expand a tree using an unfolding function. +-- +expand :: Monad m => (a -> [a]) -> Tree m a -> Tree m a +expand f m = + Tree $ do + Node x xs <- runTree m + pure . Node x $ + fmap (expand f) xs ++ unfoldForest f x + +-- | Throw away a tree's children. +-- +prune :: Monad m => Tree m a -> Tree m a +prune m = + Tree $ do + Node x _ <- runTree m + pure $ Node x [] + +------------------------------------------------------------------------ +-- Node/Tree instances + +instance Functor m => Functor (Node m) where + fmap f (Node x xs) = + Node (f x) (fmap (fmap f) xs) + +instance Functor m => Functor (Tree m) where + fmap f = + Tree . fmap (fmap f) . runTree + +instance Monad m => Applicative (Node m) where + pure = + return + (<*>) = + ap + +instance Monad m => Applicative (Tree m) where + pure = + return + (<*>) = + ap + +instance Monad m => Monad (Node m) where + return x = + Node x [] + + (>>=) (Node x xs) k = + case k x of + Node y ys -> + Node y $ + fmap (Tree . fmap (>>= k) . runTree) xs ++ ys + +instance Monad m => Monad (Tree m) where + return x = + Tree . pure $ Node x [] + + (>>=) m k = + Tree $ do + Node x xs <- runTree m + Node y ys <- runTree (k x) + pure . Node y $ + fmap (>>= k) xs ++ ys + +instance MonadPlus m => Alternative (Tree m) where + empty = + mzero + (<|>) = + mplus + +instance MonadPlus m => MonadPlus (Tree m) where + mzero = + Tree mzero + mplus x y = + Tree (runTree x `mplus` runTree y) + +instance MonadTrans Tree where + lift m = + Tree $ do + x <- m + pure (Node x []) + +instance MFunctor Node where + hoist f (Node x xs) = + Node x (fmap (hoist f) xs) + +instance MFunctor Tree where + hoist f (Tree m) = + Tree . f $ fmap (hoist f) m + +embedNode :: Monad m => (t (Node t b) -> Tree m (Node t b)) -> Node t b -> Node m b +embedNode f (Node x xs) = + Node x (fmap (embedTree f) xs) + +embedTree :: Monad m => (t (Node t b) -> Tree m (Node t b)) -> Tree t b -> Tree m b +embedTree f (Tree m) = + Tree . pure . embedNode f =<< f m + +instance MMonad Tree where + embed f m = + embedTree f m + +distributeNode :: Transformer t Tree m => Node (t m) a -> t (Tree m) a +distributeNode (Node x xs) = + join . lift . fromNode . Node (pure x) $ + fmap (pure . distributeTree) xs + +distributeTree :: Transformer t Tree m => Tree (t m) a -> t (Tree m) a +distributeTree x = + distributeNode =<< hoist lift (runTree x) + +instance Distributive Tree where + distribute = + distributeTree + +instance PrimMonad m => PrimMonad (Tree m) where + type PrimState (Tree m) = + PrimState m + primitive = + lift . primitive + +instance MonadIO m => MonadIO (Tree m) where + liftIO = + lift . liftIO + +instance MonadBase b m => MonadBase b (Tree m) where + liftBase = + lift . liftBase + +instance MonadThrow m => MonadThrow (Tree m) where + throwM = + lift . throwM + +handleNode :: (Exception e, MonadCatch m) => (e -> Tree m a) -> Node m a -> Node m a +handleNode onErr (Node x xs) = + Node x $ + fmap (handleTree onErr) xs + +handleTree :: (Exception e, MonadCatch m) => (e -> Tree m a) -> Tree m a -> Tree m a +handleTree onErr m = + Tree . fmap (handleNode onErr) $ + catch (runTree m) (runTree . onErr) + +instance MonadCatch m => MonadCatch (Tree m) where + catch = + flip handleTree + +localNode :: MonadReader r m => (r -> r) -> Node m a -> Node m a +localNode f (Node x xs) = + Node x $ + fmap (localTree f) xs + +localTree :: MonadReader r m => (r -> r) -> Tree m a -> Tree m a +localTree f (Tree m) = + Tree $ + pure . localNode f =<< local f m + +instance MonadReader r m => MonadReader r (Tree m) where + ask = + lift ask + local = + localTree + +instance MonadState s m => MonadState s (Tree m) where + get = + lift get + put = + lift . put + state = + lift . state + +listenNode :: MonadWriter w m => w -> Node m a -> Node m (a, w) +listenNode w (Node x xs) = + Node (x, w) $ + fmap (listenTree w) xs + +listenTree :: MonadWriter w m => w -> Tree m a -> Tree m (a, w) +listenTree w0 (Tree m) = + Tree $ do + (x, w) <- listen m + pure $ listenNode (mappend w0 w) x + +-- FIXME This just throws away the writer modification function. +passNode :: MonadWriter w m => Node m (a, w -> w) -> Node m a +passNode (Node (x, _) xs) = + Node x $ + fmap passTree xs + +passTree :: MonadWriter w m => Tree m (a, w -> w) -> Tree m a +passTree (Tree m) = + Tree $ + pure . passNode =<< m + +instance MonadWriter w m => MonadWriter w (Tree m) where + writer = + lift . writer + tell = + lift . tell + listen = + listenTree mempty + pass = + passTree + +handleErrorNode :: MonadError e m => (e -> Tree m a) -> Node m a -> Node m a +handleErrorNode onErr (Node x xs) = + Node x $ + fmap (handleErrorTree onErr) xs + +handleErrorTree :: MonadError e m => (e -> Tree m a) -> Tree m a -> Tree m a +handleErrorTree onErr m = + Tree . fmap (handleErrorNode onErr) $ + catchError (runTree m) (runTree . onErr) + +instance MonadError e m => MonadError e (Tree m) where + throwError = + lift . throwError + catchError = + flip handleErrorTree + +instance MonadResource m => MonadResource (Tree m) where + liftResourceT = + lift . liftResourceT + +------------------------------------------------------------------------ +-- Show/Show1 instances + +#if MIN_VERSION_base(4,9,0) +instance (Show1 m, Show a) => Show (Node m a) where + showsPrec = + showsPrec1 + +instance (Show1 m, Show a) => Show (Tree m a) where + showsPrec = + showsPrec1 + +instance Show1 m => Show1 (Node m) where + liftShowsPrec sp sl d (Node x xs) = + let + sp1 = + liftShowsPrec sp sl + + sl1 = + liftShowList sp sl + + sp2 = + liftShowsPrec sp1 sl1 + in + showsBinaryWith sp sp2 "Node" d x xs + +instance Show1 m => Show1 (Tree m) where + liftShowsPrec sp sl d (Tree m) = + let + sp1 = + liftShowsPrec sp sl + + sl1 = + liftShowList sp sl + + sp2 = + liftShowsPrec sp1 sl1 + in + showsUnaryWith sp2 "Tree" d m +#endif + +------------------------------------------------------------------------ +-- Pretty Printing + +-- +-- Rendering implementation based on the one from containers/Data.Tree +-- + +renderTreeLines :: Monad m => Tree m String -> m [String] +renderTreeLines (Tree m) = do + Node x xs0 <- m + xs <- renderForestLines xs0 + pure $ + lines (renderNode x) ++ xs + +renderNode :: String -> String +renderNode xs = + case xs of + [_] -> + ' ' : xs + _ -> + xs + +renderForestLines :: Monad m => [Tree m String] -> m [String] +renderForestLines xs0 = + let + shift hd other = + zipWith (++) (hd : repeat other) + in + case xs0 of + [] -> + pure [] + + [x] -> do + s <- renderTreeLines x + pure $ + shift " └╼" " " s + + x : xs -> do + s <- renderTreeLines x + ss <- renderForestLines xs + pure $ + shift " ├╼" " │ " s ++ ss + +-- | Render a tree of strings, note that this forces all the delayed effects in +-- the tree. +render :: Monad m => Tree m String -> m String +render = + fmap unlines . renderTreeLines diff --git a/src/Hedgehog/Internal/Tripping.hs b/src/Hedgehog/Internal/Tripping.hs new file mode 100644 index 0000000..ee0a4a3 --- /dev/null +++ b/src/Hedgehog/Internal/Tripping.hs @@ -0,0 +1,52 @@ +{-# OPTIONS_HADDOCK not-home #-} +module Hedgehog.Internal.Tripping ( + tripping + ) where + +import Hedgehog.Internal.Property +import Hedgehog.Internal.Show +import Hedgehog.Internal.Source + + +-- | Test that a pair of encode / decode functions are compatible. +-- +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 + ] diff --git a/src/Hedgehog/Range.hs b/src/Hedgehog/Range.hs new file mode 100644 index 0000000..3592603 --- /dev/null +++ b/src/Hedgehog/Range.hs @@ -0,0 +1,34 @@ +{-# 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 diff --git a/test/Test/Hedgehog/Text.hs b/test/Test/Hedgehog/Text.hs new file mode 100644 index 0000000..0a11e91 --- /dev/null +++ b/test/Test/Hedgehog/Text.hs @@ -0,0 +1,76 @@ +{-# 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) diff --git a/test/test.hs b/test/test.hs new file mode 100644 index 0000000..00abf97 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,18 @@ +import Control.Monad (unless) +import System.IO (BufferMode(..), hSetBuffering, stdout, stderr) +import System.Exit (exitFailure) + +import qualified Test.Hedgehog.Text + + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + + results <- sequence [ + Test.Hedgehog.Text.tests + ] + + unless (and results) $ + exitFailure -- 2.30.2