--- /dev/null
+## Version 0.6.1 (2018-09-22)
+
+- Set stdout/stderr encoding to UTF-8 on Windows ([#218][218], [@moodmosaic][moodmosaic])
+
+## Version 0.6 (2018-05-14)
+
+- Pass [Dieharder][Dieharder] statistical/randomness tests ([#185][185], [@moodmosaic][moodmosaic])
+- Catch `readFile` exceptions on the repl ([#184][184], [@thumphries][thumphries])
+
+## Version 0.5.3 (2018-03-12)
+
+- Add `Semigroup` and `Monoid` instances for `GenT` that lift the inner `Monoid` ([#156][156], [@andrewthad][andrewthad])
+- `Gen.unicode` no longer generates non-characters ([#154][154], [@johnchandlerburnham][johnchandlerburnham])
+- Documentation improvements ([#162][162], [@fisx][fisx])
+- Documentation fixes ([#157][157], [@dredozubov][dredozubov])
+
+## Version 0.5.2 (2018-02-05)
+
+- Add doc explaining use of `withTests 1` ([#134][134], [@chris-martin][chris-martin])
+- Explicitly define `Semigroup` instance for `Summary` ([#142][142], [@gwils][gwils])
+- Depend on `semigroups` ([#140][140], [@LightAndLight][LightAndLight])
+- Support `transformers-0.4` ([#150][150], [@gwils][gwils])
+
+## Version 0.5.1 (2017-12-06)
+
+- Only invoke `setNumCapabilities` when using the `-threaded` runtime ([#130][130], [@ekmett][ekmett])
+- Correct `mixGamma` oddness check ([#124][124], [@markhibberd][markhibberd])
+
+## Version 0.5 (2017-07-16)
+
+- Parallel state machine testing, allows detection of commands which are not-atomic ([#98][98], [@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
--- /dev/null
+Copyright 2017-2018, Jacob Stanley
+All Rights Reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ 3. Neither the name of the copyright holder nor the names of
+ its contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--- /dev/null
+hedgehog [![Hackage][hackage-shield]][hackage] [![Travis][travis-shield]][travis]
+========
+
+> Hedgehog will eat all your bugs.
+
+<img src="https://github.com/hedgehogqa/haskell-hedgehog/raw/master/img/hedgehog-logo.png" width="307" align="right"/>
+
+[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
--- /dev/null
+import Distribution.Simple
+main = defaultMain
--- /dev/null
+version: 0.6.1
+
+name:
+ hedgehog
+author:
+ Jacob Stanley
+maintainer:
+ Jacob Stanley <jacob@stanley.io>
+homepage:
+ https://hedgehog.qa
+bug-reports:
+ https://github.com/hedgehogqa/haskell-hedgehog/issues
+synopsis:
+ 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:
+ <https://github.com/hedgehogqa/haskell-hedgehog/tree/master/hedgehog-example>
+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
+ , GHC == 8.4.2
+ , GHC == 8.4.3
+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.7
+ , 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.10
+ , 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.Seed
+ Test.Hedgehog.Text
+
+ build-depends:
+ hedgehog
+ , base >= 3 && < 5
+ , containers >= 0.4 && < 0.7
+ , pretty-show >= 1.6 && < 1.8
+ , semigroups >= 0.16 && < 0.19
+ , text >= 1.1 && < 1.3
+ , transformers >= 0.3 && < 0.6
--- /dev/null
+-- |
+-- This module includes almost everything you need to get started writing
+-- property tests with Hedgehog.
+--
+-- It is designed to be used alongside "Hedgehog.Gen" and "Hedgehog.Range",
+-- which should be imported qualified. You also need to enable Template Haskell
+-- so the Hedgehog test runner can find your properties.
+--
+-- > {-# LANGUAGE TemplateHaskell #-}
+-- >
+-- > import Hedgehog
+-- > import qualified Hedgehog.Gen as Gen
+-- > import qualified Hedgehog.Range as Range
+--
+-- Once you have your imports set up, you can write a simple property:
+--
+-- > prop_reverse :: Property
+-- > prop_reverse =
+-- > property $ do
+-- > xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha
+-- > reverse (reverse xs) === xs
+--
+-- And add the Template Haskell splice which will discover your properties:
+--
+-- > tests :: IO Bool
+-- > tests =
+-- > checkParallel $$(discover)
+--
+-- If you prefer to avoid macros, you can specify the group of properties to
+-- run manually instead:
+--
+-- > {-# LANGUAGE OverloadedStrings #-}
+-- >
+-- > tests :: IO Bool
+-- > tests =
+-- > checkParallel $ Group "Test.Example" [
+-- > ("prop_reverse", prop_reverse)
+-- > ]
+--
+-- You can then load the module in GHCi, and run it:
+--
+-- > λ tests
+-- > ━━━ Test.Example ━━━
+-- > ✓ prop_reverse passed 100 tests.
+--
+module Hedgehog (
+ -- * Properties
+ Property
+ , PropertyT
+ , Group(..)
+ , PropertyName
+ , GroupName
+
+ , property
+ , test
+
+ , forAll
+ , forAllWith
+ , discard
+
+ , check
+ , recheck
+
+ , discover
+ , 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)
--- /dev/null
+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)
--- /dev/null
+{-# 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)
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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
--- /dev/null
+{-# OPTIONS_HADDOCK not-home #-}
+module Hedgehog.Internal.Exception (
+ tryAll
+ , tryEvaluate
+ ) where
+
+import Control.Exception (Exception(..), AsyncException, SomeException(..), evaluate)
+import Control.Monad.Catch (MonadCatch(..), throwM)
+
+import System.IO.Unsafe (unsafePerformIO)
+
+
+tryAll :: MonadCatch m => m a -> m (Either SomeException a)
+tryAll m =
+ catch (fmap Right m) $ \exception ->
+ case fromException exception :: Maybe AsyncException of
+ Nothing ->
+ pure $ Left exception
+ Just async ->
+ throwM async
+
+tryEvaluate :: a -> Either SomeException a
+tryEvaluate x =
+ unsafePerformIO (tryAll (evaluate x))
--- /dev/null
+{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE 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 "<discard>" 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.
--- /dev/null
+{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE RankNTypes #-}
+module Hedgehog.Internal.HTraversable (
+ HTraversable(..)
+ ) where
+
+
+-- | Higher-order traversable functors.
+--
+-- This is used internally to make symbolic variables concrete given an 'Environment'.
+--
+class HTraversable t where
+ htraverse :: Applicative f => (forall a. g a -> f (h a)) -> t g -> f (t h)
--- /dev/null
+{-# OPTIONS_HADDOCK not-home #-}
+module Hedgehog.Internal.Opaque (
+ Opaque(..)
+ ) where
+
+
+-- | Opaque values.
+--
+-- Useful if you want to put something without a 'Show' instance inside
+-- something which you'd like to be able to display.
+--
+-- For example:
+--
+-- @
+-- data State v =
+-- State {
+-- stateRefs :: [Var (Opaque (IORef Int)) v]
+-- } deriving (Eq, Show)
+-- @
+--
+newtype Opaque a =
+ Opaque {
+ unOpaque :: a
+ } deriving (Eq, Ord)
+
+instance Show (Opaque a) where
+ showsPrec _ (Opaque _) =
+ showString "Opaque"
--- /dev/null
+{-# OPTIONS_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.
--- /dev/null
+{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+module Hedgehog.Internal.Queue (
+ TaskIndex(..)
+ , TasksRemaining(..)
+
+ , runTasks
+ , finalizeTask
+
+ , runActiveFinalizers
+ , dequeueMVar
+
+ , updateNumCapabilities
+ ) where
+
+import Control.Concurrent (rtsSupportsBoundThreads)
+import Control.Concurrent.Async (forConcurrently)
+import Control.Concurrent.MVar (MVar)
+import qualified Control.Concurrent.MVar as MVar
+import Control.Monad (when)
+import Control.Monad.IO.Class (MonadIO(..))
+
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+
+import qualified GHC.Conc as Conc
+
+import Hedgehog.Internal.Config
+
+
+newtype TaskIndex =
+ TaskIndex Int
+ deriving (Eq, Ord, Enum, Num)
+
+newtype TasksRemaining =
+ TasksRemaining Int
+
+dequeueMVar ::
+ MVar [(TaskIndex, a)]
+ -> (TasksRemaining -> TaskIndex -> a -> IO b)
+ -> IO (Maybe (TaskIndex, b))
+dequeueMVar mvar start =
+ MVar.modifyMVar mvar $ \case
+ [] ->
+ pure ([], Nothing)
+ (ix, x) : xs -> do
+ y <- start (TasksRemaining $ length xs) ix x
+ pure (xs, Just (ix, y))
+
+runTasks ::
+ WorkerCount
+ -> [a]
+ -> (TasksRemaining -> TaskIndex -> a -> IO b)
+ -> (b -> IO ())
+ -> (b -> IO ())
+ -> (b -> IO c)
+ -> IO [c]
+runTasks n tasks start finish finalize runTask = do
+ qvar <- MVar.newMVar (zip [0..] tasks)
+ fvar <- MVar.newMVar (-1, Map.empty)
+
+ let
+ worker rs = do
+ mx <- dequeueMVar qvar start
+ case mx of
+ Nothing ->
+ pure rs
+ Just (ix, x) -> do
+ r <- runTask x
+ finish x
+ finalizeTask fvar ix (finalize x)
+ worker (r : rs)
+
+ -- FIXME ensure all workers have finished running
+ fmap concat . forConcurrently [1..max 1 n] $ \_ix ->
+ worker []
+
+runActiveFinalizers ::
+ MonadIO m
+ => MVar (TaskIndex, Map TaskIndex (IO ()))
+ -> m ()
+runActiveFinalizers mvar =
+ liftIO $ do
+ again <-
+ MVar.modifyMVar mvar $ \original@(minIx, finalizers0) ->
+ case Map.minViewWithKey finalizers0 of
+ Nothing ->
+ pure (original, False)
+
+ Just ((ix, finalize), finalizers) ->
+ if ix == minIx + 1 then do
+ finalize
+ pure ((ix, finalizers), True)
+ else
+ pure (original, False)
+
+ when again $
+ runActiveFinalizers mvar
+
+finalizeTask ::
+ MonadIO m
+ => MVar (TaskIndex, Map TaskIndex (IO ()))
+ -> TaskIndex
+ -> IO ()
+ -> m ()
+finalizeTask mvar ix finalize = do
+ liftIO . MVar.modifyMVar_ mvar $ \(minIx, finalizers) ->
+ pure (minIx, Map.insert ix finalize finalizers)
+ runActiveFinalizers mvar
+
+-- | Update the number of capabilities but never set it lower than it already
+-- is.
+--
+updateNumCapabilities :: WorkerCount -> IO ()
+updateNumCapabilities (WorkerCount n) = when rtsSupportsBoundThreads $ do
+ ncaps <- Conc.getNumCapabilities
+ Conc.setNumCapabilities (max n ncaps)
--- /dev/null
+{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Hedgehog.Internal.Range (
+ -- * Size
+ Size(..)
+
+ -- * Range
+ , Range(..)
+ , origin
+ , bounds
+ , lowerBound
+ , upperBound
+
+ -- * Constant
+ , singleton
+ , constant
+ , constantFrom
+ , constantBounded
+
+ -- * Linear
+ , linear
+ , linearFrom
+ , linearFrac
+ , linearFracFrom
+ , linearBounded
+
+ -- * Exponential
+ , exponential
+ , exponentialFrom
+ , exponentialBounded
+ , exponentialFloat
+ , exponentialFloatFrom
+
+ -- * Internal
+ -- $internal
+ , clamp
+ , scaleLinear
+ , scaleLinearFrac
+ , scaleExponential
+ , scaleExponentialFloat
+ ) where
+
+import Data.Bifunctor (bimap)
+
+import Prelude hiding (minimum, maximum)
+
+-- $setup
+-- >>> import Data.Int (Int8)
+-- >>> let x = 3
+
+-- | Tests are parameterized by the size of the randomly-generated data, the
+-- meaning of 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.
--- /dev/null
+{-# OPTIONS_HADDOCK not-home #-}
+module Hedgehog.Internal.Region (
+ Region(..)
+ , newEmptyRegion
+ , newOpenRegion
+ , openRegion
+ , setRegion
+ , displayRegions
+ , displayRegion
+ , moveToBottom
+ , finishRegion
+ ) where
+
+import Control.Concurrent.STM (STM, TVar)
+import qualified Control.Concurrent.STM.TMVar as TMVar
+import qualified Control.Concurrent.STM.TVar as TVar
+import Control.Monad.Catch (MonadMask(..), bracket)
+import Control.Monad.IO.Class (MonadIO(..))
+
+import System.Console.Regions (ConsoleRegion, RegionLayout(..), LiftRegion(..))
+import qualified System.Console.Regions as Console
+
+
+data Body =
+ Empty
+ | Open ConsoleRegion
+ | Closed
+
+newtype Region =
+ Region {
+ unRegion :: TVar Body
+ }
+
+newEmptyRegion :: LiftRegion m => m Region
+newEmptyRegion =
+ liftRegion $ do
+ ref <- TVar.newTVar Empty
+ pure $ Region ref
+
+newOpenRegion :: LiftRegion m => m Region
+newOpenRegion =
+ liftRegion $ do
+ region <- Console.openConsoleRegion Linear
+ ref <- TVar.newTVar $ Open region
+ pure $ Region ref
+
+openRegion :: LiftRegion m => Region -> String -> m ()
+openRegion (Region var) content =
+ liftRegion $ do
+ body <- TVar.readTVar var
+ case body of
+ Empty -> do
+ region <- Console.openConsoleRegion Linear
+ TVar.writeTVar var $ Open region
+ Console.setConsoleRegion region content
+
+ Open region ->
+ Console.setConsoleRegion region content
+
+ Closed ->
+ pure ()
+
+setRegion :: LiftRegion m => Region -> String -> m ()
+setRegion (Region var) content =
+ liftRegion $ do
+ body <- TVar.readTVar var
+ case body of
+ Empty ->
+ pure ()
+
+ Open region ->
+ Console.setConsoleRegion region content
+
+ Closed ->
+ pure ()
+
+displayRegions :: (MonadIO m, MonadMask m) => m a -> m a
+displayRegions io =
+ Console.displayConsoleRegions io
+
+displayRegion ::
+ MonadIO m
+ => MonadMask m
+ => LiftRegion m
+ => (Region -> m a)
+ -> m a
+displayRegion =
+ displayRegions . bracket newOpenRegion finishRegion
+
+moveToBottom :: Region -> STM ()
+moveToBottom (Region var) =
+ liftRegion $ do
+ body <- TVar.readTVar var
+ case body of
+ Empty ->
+ pure ()
+
+ Open region -> do
+ mxs <- TMVar.tryTakeTMVar Console.regionList
+ case mxs of
+ Nothing ->
+ pure ()
+
+ Just xs0 ->
+ let
+ xs1 =
+ filter (/= region) xs0
+ in
+ TMVar.putTMVar Console.regionList (region : xs1)
+
+ Closed ->
+ pure ()
+
+finishRegion :: LiftRegion m => Region -> m ()
+finishRegion (Region var) =
+ liftRegion $ do
+ body <- TVar.readTVar var
+ case body of
+ Empty -> do
+ TVar.writeTVar var Closed
+
+ Open region -> do
+ content <- Console.getConsoleRegion region
+ Console.finishConsoleRegion region content
+ TVar.writeTVar var Closed
+
+ Closed ->
+ pure ()
--- /dev/null
+{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE 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)
+#if mingw32_HOST_OS
+import System.IO (hSetEncoding, stdout, stderr, utf8)
+#endif
+
+import Text.PrettyPrint.Annotated.WL (Doc, (<+>))
+import qualified Text.PrettyPrint.Annotated.WL as WL
+import Text.Printf (printf)
+
+------------------------------------------------------------------------
+-- Data
+
+-- | 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 "<property>" (WL.text . unPropertyName) name
+ ]
+
+mergeLine :: Semigroup a => Line a -> Line a -> Line a
+mergeLine (Line x no src) (Line y _ _) =
+ Line (x <> y) no src
+
+mergeDeclaration :: Semigroup a => Declaration a -> Declaration a -> Declaration a
+mergeDeclaration (Declaration file line name src0) (Declaration _ _ _ src1) =
+ Declaration file line name $
+ Map.unionWith mergeLine src0 src1
+
+mergeDeclarations :: Semigroup a => [Declaration a] -> [Declaration a]
+mergeDeclarations =
+ Map.elems .
+ Map.fromListWith mergeDeclaration .
+ fmap (\d -> ((declarationFile d, declarationLine d), d))
+
+ppTextLines :: String -> [Doc Markup]
+ppTextLines =
+ fmap WL.text . List.lines
+
+ppFailureReport :: MonadIO m => Maybe PropertyName -> 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 ->
+ "<interactive>"
+ 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
+
+#if mingw32_HOST_OS
+ liftIO $ do
+ hSetEncoding stdout utf8
+ hSetEncoding stderr utf8
+#endif
+ pure .
+ display .
+ WL.renderSmart 100 $
+ WL.indent 2 doc
+
+renderProgress :: MonadIO m => 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
--- /dev/null
+{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# 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)
+
+#if mingw32_HOST_OS
+import System.IO (hSetEncoding, stdout, stderr, utf8)
+#endif
+
+-- | Configuration for a property test run.
+--
+data RunnerConfig =
+ RunnerConfig {
+ -- | The number of property tests to run concurrently. 'Nothing' means
+ -- use one worker per processor.
+ runnerWorkers :: !(Maybe WorkerCount)
+
+ -- | Whether to use colored output or not. 'Nothing' means detect from
+ -- the environment.
+ , runnerColor :: !(Maybe UseColor)
+
+ -- | How verbose to be in the runner output. 'Nothing' means detect from
+ -- the environment.
+ , runnerVerbosity :: !(Maybe Verbosity)
+ } deriving (Eq, Ord, Show)
+
+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)
+
+#if mingw32_HOST_OS
+ hSetEncoding stdout utf8
+ hSetEncoding stderr utf8
+#endif
+ 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)
--- /dev/null
+{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE CPP #-}
+-- |
+-- This is a port of "Fast Splittable Pseudorandom Number Generators" by Steele
+-- et. al. [1].
+--
+-- The paper's algorithm provides decent randomness for most purposes but
+-- sacrifices cryptographic-quality randomness in favor of speed. The original
+-- implementation is tested with DieHarder and BigCrush; see the paper for
+-- details.
+--
+-- This implementation, originally from [2], is a port from the paper.
+--
+-- It also takes in to account the SplittableRandom.java source code in OpenJDK
+-- v8u40-b25 as well as splittable_random.ml in Jane Street's standard library
+-- overlay (kernel) v113.33.03, and Random.fs in FsCheck v3.
+--
+-- Other than the choice of initial seed for 'from' this port should be
+-- faithful.
+--
+-- 1. Guy L. Steele, Jr., Doug Lea, Christine H. Flood
+-- Fast splittable pseudorandom number generators
+-- Comm ACM, 49(10), Oct 2014, pp453-472.
+--
+-- 2. Nikos Baxevanis
+-- https://github.com/moodmosaic/SplitMix/blob/master/SplitMix.hs
+--
+
+#include "MachDeps.h"
+
+module Hedgehog.Internal.Seed (
+ Seed(..)
+ , random
+ , from
+ , split
+ , nextInteger
+ , nextDouble
+
+ -- * Internal
+ -- $internal
+ , goldenGamma
+ , nextWord64
+ , nextWord32
+ , mix64
+ , mix64variant13
+ , mix32
+ , mixGamma
+ ) where
+
+import Control.Monad.IO.Class (MonadIO(..))
+
+import Data.Bifunctor (first)
+import Data.Bits ((.|.), xor, shiftR, popCount)
+#if (SIZEOF_HSINT == 8)
+import Data.Int (Int64)
+#else
+import Data.Int (Int32)
+#endif
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import Data.IORef (IORef)
+import qualified Data.IORef as IORef
+import Data.Word (Word32, Word64)
+
+import System.IO.Unsafe (unsafePerformIO)
+import System.Random (RandomGen)
+import qualified System.Random as Random
+
+-- | A splittable random number generator.
+--
+data Seed =
+ Seed {
+ seedValue :: !Word64
+ , seedGamma :: !Word64 -- ^ must be an odd number
+ } deriving (Eq, Ord)
+
+instance Show Seed where
+ showsPrec p (Seed v g) =
+ showParen (p > 10) $
+ showString "Seed " .
+ showsPrec 11 v .
+ showChar ' ' .
+ showsPrec 11 g
+
+instance Read Seed where
+ readsPrec p =
+ readParen (p > 10) $ \r0 -> do
+ ("Seed", r1) <- lex r0
+ (v, r2) <- readsPrec 11 r1
+ (g, r3) <- readsPrec 11 r2
+ pure (Seed v g, r3)
+
+global :: IORef Seed
+global =
+ unsafePerformIO $ do
+ -- FIXME use /dev/urandom on posix
+ seconds <- getPOSIXTime
+ IORef.newIORef $ from (round (seconds * 1000))
+{-# NOINLINE global #-}
+
+-- | Create a random 'Seed' using an effectful source of randomness.
+--
+random :: MonadIO m => m Seed
+random =
+ liftIO $ IORef.atomicModifyIORef' global split
+
+-- | Create a 'Seed' using a 'Word64'.
+--
+from :: Word64 -> Seed
+from x =
+ Seed (mix64 x) (mixGamma (x + goldenGamma))
+
+-- | A predefined gamma value's needed for initializing the "root" instances of
+-- 'Seed'. That is, instances not produced by splitting an already existing
+-- instance.
+--
+-- We choose: the odd integer closest to @2^64/φ@, where @φ = (1 + √5)/2@ is
+-- the golden ratio.
+--
+goldenGamma :: Word64
+goldenGamma =
+ 0x9e3779b97f4a7c15
+
+-- | Get the next value in the SplitMix sequence.
+--
+next :: Seed -> (Word64, Seed)
+next (Seed v0 g) =
+ let
+ v = v0 + g
+ in
+ (v, Seed v g)
+
+-- | Splits a random number generator in to two.
+--
+split :: Seed -> (Seed, Seed)
+split s0 =
+ let
+ (v0, s1) = next s0
+ (g0, s2) = next s1
+ in
+ (s2, Seed (mix64 v0) (mixGamma g0))
+
+-- | Generate a random 'Word64'.
+--
+nextWord64 :: Seed -> (Word64, Seed)
+nextWord64 s0 =
+ let
+ (v0, s1) = next s0
+ in
+ (mix64 v0, s1)
+
+-- | Generate a random 'Word32'.
+--
+nextWord32 :: Seed -> (Word32, Seed)
+nextWord32 s0 =
+ let
+ (v0, s1) = next s0
+ in
+ (mix32 v0, s1)
+
+-- | Generate a random 'Integer' in the [inclusive,inclusive] range.
+--
+nextInteger :: Integer -> Integer -> Seed -> (Integer, Seed)
+nextInteger lo hi =
+ Random.randomR (lo, hi)
+
+-- | Generate a random 'Double' in the [inclusive,exclusive) range.
+--
+nextDouble :: Double -> Double -> Seed -> (Double, Seed)
+nextDouble lo hi =
+ Random.randomR (lo, hi)
+
+mix64 :: Word64 -> Word64
+mix64 x =
+ let
+ y = (x `xor` (x `shiftR` 33)) * 0xff51afd7ed558ccd
+ z = (y `xor` (y `shiftR` 33)) * 0xc4ceb9fe1a85ec53
+ in
+ z `xor` (z `shiftR` 33)
+
+mix32 :: Word64 -> Word32
+mix32 x =
+ let
+ y = (x `xor` (x `shiftR` 33)) * 0xff51afd7ed558ccd
+ z = (y `xor` (y `shiftR` 33)) * 0xc4ceb9fe1a85ec53
+ in
+ fromIntegral (z `shiftR` 32)
+
+mix64variant13 :: Word64 -> Word64
+mix64variant13 x =
+ let
+ y = (x `xor` (x `shiftR` 30)) * 0xbf58476d1ce4e5b9
+ z = (y `xor` (y `shiftR` 27)) * 0x94d049bb133111eb
+ in
+ z `xor` (z `shiftR` 31)
+
+mixGamma :: Word64 -> Word64
+mixGamma x =
+ let
+ y = mix64variant13 x .|. 1
+ n = popCount $ y `xor` (y `shiftR` 1)
+ in
+ if n < 24 then
+ y `xor` 0xaaaaaaaaaaaaaaaa
+ else
+ y
+
+------------------------------------------------------------------------
+-- RandomGen instances
+
+#if (SIZEOF_HSINT == 8)
+instance RandomGen Seed where
+ next =
+ first fromIntegral . nextWord64
+ genRange _ =
+ (fromIntegral (minBound :: Int64), fromIntegral (maxBound :: Int64))
+ split =
+ split
+#else
+instance RandomGen Seed where
+ next =
+ first fromIntegral . nextWord32
+ genRange _ =
+ (fromIntegral (minBound :: Int32), fromIntegral (maxBound :: Int32))
+ split =
+ split
+#endif
+
+------------------------------------------------------------------------
+-- Internal
+
+-- $internal
+--
+-- These functions are exported in case you need them in a pinch, but are not
+-- part of the public API and may change at any time, even as part of a minor
+-- update.
--- /dev/null
+{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternGuards #-}
+module Hedgehog.Internal.Show (
+ Name
+ , Value(..)
+ , ValueDiff(..)
+ , LineDiff(..)
+
+ , mkValue
+ , showPretty
+
+ , valueDiff
+ , lineDiff
+ , toLineDiff
+
+ , renderValue
+ , renderValueDiff
+ , renderLineDiff
+
+ , takeLeft
+ , takeRight
+ ) where
+
+import Data.Bifunctor (second)
+
+import Text.Show.Pretty (Value(..), Name, reify, valToStr, ppShow)
+
+
+data ValueDiff =
+ ValueCon Name [ValueDiff]
+ | ValueRec Name [(Name, ValueDiff)]
+ | ValueTuple [ValueDiff]
+ | ValueList [ValueDiff]
+ | ValueSame Value
+ | ValueDiff Value Value
+ deriving (Eq, Show)
+
+data LineDiff =
+ LineSame String
+ | LineRemoved String
+ | LineAdded String
+ deriving (Eq, Show)
+
+data DocDiff =
+ DocSame Int String
+ | DocRemoved Int String
+ | DocAdded Int String
+ | DocOpen Int String
+ | DocItem Int String [DocDiff]
+ | DocClose Int String
+ deriving (Eq, Show)
+
+renderValue :: Value -> String
+renderValue =
+ valToStr
+
+renderValueDiff :: ValueDiff -> String
+renderValueDiff =
+ unlines .
+ fmap renderLineDiff .
+ toLineDiff
+
+renderLineDiff :: LineDiff -> String
+renderLineDiff = \case
+ LineSame x ->
+ " " ++ x
+ LineRemoved x ->
+ "- " ++ x
+ LineAdded x ->
+ "+ " ++ x
+
+mkValue :: Show a => a -> Maybe Value
+mkValue =
+ reify
+
+showPretty :: Show a => a -> String
+showPretty =
+ ppShow
+
+lineDiff :: Value -> Value -> [LineDiff]
+lineDiff x y =
+ toLineDiff $ valueDiff x y
+
+toLineDiff :: ValueDiff -> [LineDiff]
+toLineDiff =
+ concatMap (mkLineDiff 0 "") .
+ collapseOpen .
+ dropLeadingSep .
+ mkDocDiff 0
+
+valueDiff :: Value -> Value -> ValueDiff
+valueDiff x y =
+ if x == y then
+ ValueSame x
+ else
+ case (x, y) of
+ (Con nx xs, Con ny ys)
+ | nx == ny
+ , length xs == length ys
+ ->
+ ValueCon nx (zipWith valueDiff xs ys)
+
+ (Rec nx nxs, Rec ny nys)
+ | nx == ny
+ , fmap fst nxs == fmap fst nys
+ , ns <- fmap fst nxs
+ , xs <- fmap snd nxs
+ , ys <- fmap snd nys
+ ->
+ ValueRec nx (zip ns (zipWith valueDiff xs ys))
+
+ (Tuple xs, Tuple ys)
+ | length xs == length ys
+ ->
+ ValueTuple (zipWith valueDiff xs ys)
+
+ (List xs, List ys)
+ | length xs == length ys
+ ->
+ ValueList (zipWith valueDiff xs ys)
+
+ _ ->
+ ValueDiff x y
+
+takeLeft :: ValueDiff -> Value
+takeLeft = \case
+ ValueCon n xs ->
+ Con n (fmap takeLeft xs)
+ ValueRec n nxs ->
+ Rec n (fmap (second takeLeft) nxs)
+ ValueTuple xs ->
+ Tuple (fmap takeLeft xs)
+ ValueList xs ->
+ List (fmap takeLeft xs)
+ ValueSame x ->
+ x
+ ValueDiff x _ ->
+ x
+
+takeRight :: ValueDiff -> Value
+takeRight = \case
+ ValueCon n xs ->
+ Con n (fmap takeRight xs)
+ ValueRec n nxs ->
+ Rec n (fmap (second takeRight) nxs)
+ ValueTuple xs ->
+ Tuple (fmap takeRight xs)
+ ValueList xs ->
+ List (fmap takeRight xs)
+ ValueSame x ->
+ x
+ ValueDiff _ x ->
+ x
+
+mkLineDiff :: Int -> String -> DocDiff -> [LineDiff]
+mkLineDiff indent0 prefix0 diff =
+ let
+ mkLinePrefix indent =
+ spaces indent0 ++ prefix0 ++ spaces indent
+
+ mkLineIndent indent =
+ indent0 + length prefix0 + indent
+ in
+ case diff of
+ DocSame indent x ->
+ [LineSame $ mkLinePrefix indent ++ x]
+
+ DocRemoved indent x ->
+ [LineRemoved $ mkLinePrefix indent ++ x]
+
+ DocAdded indent x ->
+ [LineAdded $ mkLinePrefix indent ++ x]
+
+ DocOpen indent x ->
+ [LineSame $ mkLinePrefix indent ++ x]
+
+ DocItem _ _ [] ->
+ []
+
+ DocItem indent prefix (x@DocRemoved{} : y@DocAdded{} : xs) ->
+ mkLineDiff (mkLineIndent indent) prefix x ++
+ mkLineDiff (mkLineIndent indent) prefix y ++
+ concatMap (mkLineDiff (mkLineIndent (indent + length prefix)) "") xs
+
+ DocItem indent prefix (x : xs) ->
+ mkLineDiff (mkLineIndent indent) prefix x ++
+ concatMap (mkLineDiff (mkLineIndent (indent + length prefix)) "") xs
+
+ DocClose indent x ->
+ [LineSame $ spaces (mkLineIndent indent) ++ x]
+
+spaces :: Int -> String
+spaces indent =
+ replicate indent ' '
+
+collapseOpen :: [DocDiff] -> [DocDiff]
+collapseOpen = \case
+ DocSame indent line : DocOpen _ bra : xs ->
+ DocSame indent (line ++ " " ++ bra) : collapseOpen xs
+ DocItem indent prefix xs : ys ->
+ DocItem indent prefix (collapseOpen xs) : collapseOpen ys
+ x : xs ->
+ x : collapseOpen xs
+ [] ->
+ []
+
+dropLeadingSep :: [DocDiff] -> [DocDiff]
+dropLeadingSep = \case
+ DocOpen oindent bra : DocItem indent prefix xs : ys ->
+ DocOpen oindent bra : DocItem (indent + length prefix) "" (dropLeadingSep xs) : dropLeadingSep ys
+ DocItem indent prefix xs : ys ->
+ DocItem indent prefix (dropLeadingSep xs) : dropLeadingSep ys
+ x : xs ->
+ x : dropLeadingSep xs
+ [] ->
+ []
+
+mkDocDiff :: Int -> ValueDiff -> [DocDiff]
+mkDocDiff indent = \case
+ ValueSame x ->
+ same indent (renderValue x)
+
+ diff
+ | x <- takeLeft diff
+ , y <- takeRight diff
+ , oneLiner x
+ , oneLiner y
+ ->
+ removed indent (renderValue x) ++
+ added indent (renderValue y)
+
+ ValueCon n xs ->
+ same indent n ++
+ concatMap (mkDocDiff (indent + 2)) xs
+
+ ValueRec n nxs ->
+ same indent n ++
+ [DocOpen indent "{"] ++
+ fmap (\(name, x) -> DocItem (indent + 2) ", " (same 0 (name ++ " =") ++ mkDocDiff 2 x)) nxs ++
+ [DocClose (indent + 2) "}"]
+
+ ValueTuple xs ->
+ [DocOpen indent "("] ++
+ fmap (DocItem indent ", " . mkDocDiff 0) xs ++
+ [DocClose indent ")"]
+
+ ValueList xs ->
+ [DocOpen indent "["] ++
+ fmap (DocItem indent ", " . mkDocDiff 0) xs ++
+ [DocClose indent "]"]
+
+ ValueDiff x y ->
+ removed indent (renderValue x) ++
+ added indent (renderValue y)
+
+oneLiner :: Value -> Bool
+oneLiner x =
+ case lines (renderValue x) of
+ _ : _ : _ ->
+ False
+ _ ->
+ True
+
+same :: Int -> String -> [DocDiff]
+same indent =
+ fmap (DocSame indent) . lines
+
+removed :: Int -> String -> [DocDiff]
+removed indent =
+ fmap (DocRemoved indent) . lines
+
+added :: Int -> String -> [DocDiff]
+added indent =
+ fmap (DocAdded indent) . lines
--- /dev/null
+{-# OPTIONS_HADDOCK not-home #-}
+module Hedgehog.Internal.Shrink (
+ towards
+ , towardsFloat
+ , list
+
+ , halves
+ , removes
+ , consNub
+ ) where
+
+
+-- | Shrink an integral number by edging towards a destination.
+--
+-- >>> towards 0 100
+-- [0,50,75,88,94,97,99]
+--
+-- >>> towards 500 1000
+-- [500,750,875,938,969,985,993,997,999]
+--
+-- >>> towards (-50) (-26)
+-- [-50,-38,-32,-29,-27]
+--
+-- /Note we always try the destination first, as that is the optimal shrink./
+--
+towards :: Integral a => a -> a -> [a]
+towards destination x =
+ if destination == x then
+ []
+ else
+ let
+ -- Halve the operands before subtracting them so they don't overflow.
+ -- Consider 'minBound' and 'maxBound' for a fixed sized type like 'Int64'.
+ diff =
+ (x `quot` 2) - (destination `quot` 2)
+ in
+ destination `consNub` fmap (x -) (halves diff)
+
+-- | Shrink a floating-point number by edging towards a destination.
+--
+-- >>> take 7 (towardsFloat 0.0 100)
+-- [0.0,50.0,75.0,87.5,93.75,96.875,98.4375]
+--
+-- >>> take 7 (towardsFloat 1.0 0.5)
+-- [1.0,0.75,0.625,0.5625,0.53125,0.515625,0.5078125]
+--
+-- /Note we always try the destination first, as that is the optimal shrink./
+--
+towardsFloat :: RealFloat a => a -> a -> [a]
+towardsFloat destination x =
+ if destination == x then
+ []
+ else
+ let
+ diff =
+ x - destination
+
+ ok y =
+ y /= x && not (isNaN y) && not (isInfinite y)
+ in
+ takeWhile ok .
+ fmap (x -) $
+ iterate (/ 2) diff
+
+-- | Shrink a list by edging towards the empty list.
+--
+-- >>> list [1,2,3]
+-- [[],[2,3],[1,3],[1,2]]
+--
+-- >>> list "abcd"
+-- ["","cd","ab","bcd","acd","abd","abc"]
+--
+-- /Note we always try the empty list first, as that is the optimal shrink./
+--
+list :: [a] -> [[a]]
+list xs =
+ concatMap
+ (\k -> removes k xs)
+ (halves $ length xs)
+
+-- | Produce all permutations of removing 'k' elements from a list.
+--
+-- >>> removes 2 "abcdef"
+-- ["cdef","abef","abcd"]
+--
+removes :: Int -> [a] -> [[a]]
+removes k0 xs0 =
+ let
+ loop k n xs =
+ let
+ (hd, tl) =
+ splitAt k xs
+ in
+ if k > n then
+ []
+ else if null tl then
+ [[]]
+ else
+ tl : fmap (hd ++) (loop k (n - k) tl)
+ in
+ loop k0 (length xs0) xs0
+
+-- | Produce a list containing the progressive halving of an integral.
+--
+-- >>> halves 15
+-- [15,7,3,1]
+--
+-- >>> halves 100
+-- [100,50,25,12,6,3,1]
+--
+-- >>> halves (-26)
+-- [-26,-13,-6,-3,-1]
+--
+halves :: Integral a => a -> [a]
+halves =
+ takeWhile (/= 0) . iterate (`quot` 2)
+
+-- | Cons an element on to the front of a list unless it is already there.
+--
+consNub :: Eq a => a -> [a] -> [a]
+consNub x ys0 =
+ case ys0 of
+ [] ->
+ x : []
+ y : ys ->
+ if x == y then
+ y : ys
+ else
+ x : y : ys
--- /dev/null
+{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE 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
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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
+ ]
--- /dev/null
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Hedgehog.Range (
+ -- * Size
+ Size(..)
+
+ -- * Range
+ , Range
+ , origin
+ , bounds
+ , lowerBound
+ , upperBound
+
+ -- * Constant
+ , singleton
+ , constant
+ , constantFrom
+ , constantBounded
+
+ -- * Linear
+ , linear
+ , linearFrom
+ , linearFrac
+ , linearFracFrom
+ , linearBounded
+
+ -- * Exponential
+ , exponential
+ , exponentialFrom
+ , exponentialBounded
+ , exponentialFloat
+ , exponentialFloatFrom
+ ) where
+
+import Hedgehog.Internal.Range
--- /dev/null
+{-# LANGUAGE TemplateHaskell #-}
+module Test.Hedgehog.Seed (
+ tests
+ ) where
+
+import Data.Foldable (for_)
+
+import Hedgehog
+import qualified Hedgehog.Internal.Seed as Seed
+
+data Assert =
+ Assert {
+ expected :: !Seed
+ , actual :: !Seed
+ } deriving (Show)
+
+-- | Verify that SplitMix avoids pathological γ-values, as discussed by
+-- Melissa E. O'Neill in the post with title Bugs in SplitMix(es), at
+-- http://www.pcg-random.org/posts/bugs-in-splitmix.html
+--
+-- See also:
+-- https://github.com/hedgehogqa/haskell-hedgehog/issues/191
+--
+prop_avoid_pathological_gamma_values :: Property
+prop_avoid_pathological_gamma_values =
+ withTests 1 . property $ do
+ for_ asserts $ \a ->
+ expected a === actual a
+
+asserts :: [Assert]
+asserts = [
+ Assert
+ (Seed 15210016002011668638 12297829382473034411)
+ (Seed.from 0x61c8864680b583eb)
+ , Assert
+ (Seed 11409286845259996466 12297829382473034411)
+ (Seed.from 0xf8364607e9c949bd)
+ , Assert
+ (Seed 1931727433621677744 12297829382473034411)
+ (Seed.from 0x88e48f4fcc823718)
+ , Assert
+ (Seed 307741759840609752 12297829382473034411)
+ (Seed.from 0x7f83ab8da2e71dd1)
+ , Assert
+ (Seed 8606169619657412120 12297829382473034413)
+ (Seed.from 0x7957d809e827ff4c)
+ , Assert
+ (Seed 13651108307767328632 12297829382473034413)
+ (Seed.from 0xf8d059aee4c53639)
+ , Assert
+ (Seed 125750466559701114 12297829382473034413)
+ (Seed.from 0x9cd9f015db4e58b7)
+ , Assert
+ (Seed 6781260234005250507 12297829382473034413)
+ (Seed.from 0xf4077b0dbebc73c0)
+ , Assert
+ (Seed 15306535823716590088 12297829382473034405)
+ (Seed.from 0x305cb877109d0686)
+ , Assert
+ (Seed 7344074043290227165 12297829382473034405)
+ (Seed.from 0x359e58eeafebd527)
+ , Assert
+ (Seed 9920554987610416076 12297829382473034405)
+ (Seed.from 0xbeb721c511b0da6d)
+ , Assert
+ (Seed 3341781972484278810 12297829382473034405)
+ (Seed.from 0x86466fd0fcc363a6)
+ , Assert
+ (Seed 12360157267739240775 12297829382473034421)
+ (Seed.from 0xefee3e7b93db3075)
+ , Assert
+ (Seed 600595566262245170 12297829382473034421)
+ (Seed.from 0x79629ee76aa83059)
+ , Assert
+ (Seed 1471112649570176389 12297829382473034421)
+ (Seed.from 0x05d507d05e785673)
+ , Assert
+ (Seed 8100917074368564322 12297829382473034421)
+ (Seed.from 0x76442b62dddf926c)
+ ]
+
+tests :: IO Bool
+tests =
+ checkParallel $$(discover)
--- /dev/null
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Test.Hedgehog.Text where
+
+import Data.Int (Int64)
+import Data.Typeable (Typeable)
+
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+
+import Text.Read (readEither)
+
+
+genSize :: Gen Size
+genSize =
+ Size <$> Gen.enumBounded
+
+genOdd :: Gen Int64
+genOdd =
+ let
+ mkOdd x =
+ if odd x then
+ x
+ else
+ pred x
+ in
+ mkOdd <$> Gen.int64 (Range.constant 1 maxBound)
+
+genSeed :: Gen Seed
+genSeed =
+ Seed <$> Gen.word64 Range.constantBounded <*> fmap fromIntegral genOdd
+
+genPrecedence :: Gen Int
+genPrecedence =
+ Gen.int (Range.constant 0 11)
+
+genString :: Gen String
+genString =
+ Gen.string (Range.constant 0 100) Gen.alpha
+
+checkShowAppend :: (Typeable a, Show a) => Gen a -> Property
+checkShowAppend gen =
+ property $ do
+ prec <- forAll genPrecedence
+ x <- forAll gen
+ xsuffix <- forAll genString
+ ysuffix <- forAll genString
+ showsPrec prec x xsuffix ++ ysuffix === showsPrec prec x (xsuffix ++ ysuffix)
+
+trippingReadShow :: (Eq a, Typeable a, Show a, Read a) => Gen a -> Property
+trippingReadShow gen =
+ property $ do
+ prec <- forAll genPrecedence
+ x <- forAll gen
+ tripping x (\z -> showsPrec prec z "") readEither
+
+prop_show_append_size :: Property
+prop_show_append_size =
+ checkShowAppend genSize
+
+prop_tripping_append_size :: Property
+prop_tripping_append_size =
+ trippingReadShow genSize
+
+prop_show_append_seed :: Property
+prop_show_append_seed =
+ checkShowAppend genSeed
+
+prop_tripping_append_seed :: Property
+prop_tripping_append_seed =
+ trippingReadShow genSeed
+
+tests :: IO Bool
+tests =
+ checkParallel $$(discover)
--- /dev/null
+import Control.Monad (unless)
+import System.IO (BufferMode(..), hSetBuffering, stdout, stderr)
+import System.Exit (exitFailure)
+
+import qualified Test.Hedgehog.Seed
+import qualified Test.Hedgehog.Text
+
+
+main :: IO ()
+main = do
+ hSetBuffering stdout LineBuffering
+ hSetBuffering stderr LineBuffering
+
+ results <- sequence [
+ Test.Hedgehog.Text.tests
+ , Test.Hedgehog.Seed.tests
+ ]
+
+ unless (and results) $
+ exitFailure
projects / haskell-hedgehog.git / commitdiff