hedgehog-0.6.1/ 0000755 0000000 0000000 00000000000 13351371600 011455 5 ustar 00 0000000 0000000 hedgehog-0.6.1/Setup.hs 0000644 0000000 0000000 00000000056 13351371600 013112 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
hedgehog-0.6.1/LICENSE 0000644 0000000 0000000 00000002754 13351371600 012472 0 ustar 00 0000000 0000000 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.
hedgehog-0.6.1/CHANGELOG.md 0000644 0000000 0000000 00000015544 13351371600 013277 0 ustar 00 0000000 0000000 ## 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
hedgehog-0.6.1/README.md 0000644 0000000 0000000 00000005220 13351371600 012733 0 ustar 00 0000000 0000000 hedgehog [![Hackage][hackage-shield]][hackage] [![Travis][travis-shield]][travis]
========
> Hedgehog will eat all your bugs.
[Hedgehog](http://hedgehog.qa/) is a modern property-based testing
system, in the spirit of QuickCheck. Hedgehog uses integrated shrinking,
so shrinks obey the invariants of generated values by construction.
## Features
- Integrated shrinking, shrinks obey invariants by construction.
- Abstract state machine testing.
- Generators allow monadic effects.
- Range combinators for full control over the scope of generated numbers and collections.
- Equality and roundtrip assertions show a diff instead of the two inequal values.
- Template Haskell test runner which executes properties concurrently.
## Example
The main module, [Hedgehog][haddock-hedgehog], includes almost
everything you need to get started writing property tests with Hedgehog.
It is designed to be used alongside [Hedgehog.Gen][haddock-hedgehog-gen]
and [Hedgehog.Range][haddock-hedgehog-range] which should be imported
qualified. You also need to enable Template Haskell so the Hedgehog test
runner can find your properties.
```hs
{-# LANGUAGE TemplateHaskell #-}
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
```
Once you have your imports set up, you can write a simple property:
```hs
prop_reverse :: Property
prop_reverse =
property $ do
xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha
reverse (reverse xs) === xs
```
And add the Template Haskell splice which will discover your properties:
```hs
tests :: IO Bool
tests =
checkParallel $$(discover)
```
If you prefer to avoid macros, you can specify the group of properties
to run manually instead:
```hs
{-# LANGUAGE OverloadedStrings #-}
tests :: IO Bool
tests =
checkParallel $ Group "Test.Example" [
("prop_reverse", prop_reverse)
]
```
You can then load the module in GHCi, and run it:
```
λ tests
━━━ Test.Example ━━━
✓ prop_reverse passed 100 tests.
```
[hackage]: http://hackage.haskell.org/package/hedgehog
[hackage-shield]: https://img.shields.io/badge/hackage-v0.5-blue.svg
[travis]: https://travis-ci.org/hedgehogqa/haskell-hedgehog
[travis-shield]: https://travis-ci.org/hedgehogqa/haskell-hedgehog.svg?branch=master
[haddock-hedgehog]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog.html
[haddock-hedgehog-gen]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog-Gen.html
[haddock-hedgehog-range]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog-Range.html
hedgehog-0.6.1/hedgehog.cabal 0000644 0000000 0000000 00000007632 13351371600 014223 0 ustar 00 0000000 0000000 version: 0.6.1
name:
hedgehog
author:
Jacob Stanley
maintainer:
Jacob Stanley
homepage:
https://hedgehog.qa
bug-reports:
https://github.com/hedgehogqa/haskell-hedgehog/issues
synopsis:
Hedgehog will eat all your bugs.
description:
Hedgehog is a modern property-based testing system, in the spirit of
QuickCheck. Hedgehog uses integrated shrinking, so shrinks obey the
invariants of generated values by construction.
.
To get started quickly, see the examples:
category:
Testing
license:
BSD3
license-file:
LICENSE
cabal-version:
>= 1.8
build-type:
Simple
tested-with:
GHC == 7.10.2
, GHC == 7.10.3
, GHC == 8.0.1
, GHC == 8.0.2
, GHC == 8.2.1
, GHC == 8.2.2
, GHC == 8.4.1
, 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
hedgehog-0.6.1/test/ 0000755 0000000 0000000 00000000000 13351371600 012434 5 ustar 00 0000000 0000000 hedgehog-0.6.1/test/test.hs 0000644 0000000 0000000 00000000722 13351371600 013750 0 ustar 00 0000000 0000000 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
hedgehog-0.6.1/test/Test/ 0000755 0000000 0000000 00000000000 13351371600 013353 5 ustar 00 0000000 0000000 hedgehog-0.6.1/test/Test/Hedgehog/ 0000755 0000000 0000000 00000000000 13351371600 015065 5 ustar 00 0000000 0000000 hedgehog-0.6.1/test/Test/Hedgehog/Text.hs 0000644 0000000 0000000 00000003320 13351371600 016343 0 ustar 00 0000000 0000000 {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Hedgehog.Text where
import Data.Int (Int64)
import Data.Typeable (Typeable)
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Text.Read (readEither)
genSize :: Gen Size
genSize =
Size <$> Gen.enumBounded
genOdd :: Gen Int64
genOdd =
let
mkOdd x =
if odd x then
x
else
pred x
in
mkOdd <$> Gen.int64 (Range.constant 1 maxBound)
genSeed :: Gen Seed
genSeed =
Seed <$> Gen.word64 Range.constantBounded <*> fmap fromIntegral genOdd
genPrecedence :: Gen Int
genPrecedence =
Gen.int (Range.constant 0 11)
genString :: Gen String
genString =
Gen.string (Range.constant 0 100) Gen.alpha
checkShowAppend :: (Typeable a, Show a) => Gen a -> Property
checkShowAppend gen =
property $ do
prec <- forAll genPrecedence
x <- forAll gen
xsuffix <- forAll genString
ysuffix <- forAll genString
showsPrec prec x xsuffix ++ ysuffix === showsPrec prec x (xsuffix ++ ysuffix)
trippingReadShow :: (Eq a, Typeable a, Show a, Read a) => Gen a -> Property
trippingReadShow gen =
property $ do
prec <- forAll genPrecedence
x <- forAll gen
tripping x (\z -> showsPrec prec z "") readEither
prop_show_append_size :: Property
prop_show_append_size =
checkShowAppend genSize
prop_tripping_append_size :: Property
prop_tripping_append_size =
trippingReadShow genSize
prop_show_append_seed :: Property
prop_show_append_seed =
checkShowAppend genSeed
prop_tripping_append_seed :: Property
prop_tripping_append_seed =
trippingReadShow genSeed
tests :: IO Bool
tests =
checkParallel $$(discover)
hedgehog-0.6.1/test/Test/Hedgehog/Seed.hs 0000644 0000000 0000000 00000004657 13351371600 016315 0 ustar 00 0000000 0000000 {-# LANGUAGE TemplateHaskell #-}
module Test.Hedgehog.Seed (
tests
) where
import Data.Foldable (for_)
import Hedgehog
import qualified Hedgehog.Internal.Seed as Seed
data Assert =
Assert {
expected :: !Seed
, actual :: !Seed
} deriving (Show)
-- | Verify that SplitMix avoids pathological γ-values, as discussed by
-- Melissa E. O'Neill in the post with title Bugs in SplitMix(es), at
-- http://www.pcg-random.org/posts/bugs-in-splitmix.html
--
-- See also:
-- https://github.com/hedgehogqa/haskell-hedgehog/issues/191
--
prop_avoid_pathological_gamma_values :: Property
prop_avoid_pathological_gamma_values =
withTests 1 . property $ do
for_ asserts $ \a ->
expected a === actual a
asserts :: [Assert]
asserts = [
Assert
(Seed 15210016002011668638 12297829382473034411)
(Seed.from 0x61c8864680b583eb)
, Assert
(Seed 11409286845259996466 12297829382473034411)
(Seed.from 0xf8364607e9c949bd)
, Assert
(Seed 1931727433621677744 12297829382473034411)
(Seed.from 0x88e48f4fcc823718)
, Assert
(Seed 307741759840609752 12297829382473034411)
(Seed.from 0x7f83ab8da2e71dd1)
, Assert
(Seed 8606169619657412120 12297829382473034413)
(Seed.from 0x7957d809e827ff4c)
, Assert
(Seed 13651108307767328632 12297829382473034413)
(Seed.from 0xf8d059aee4c53639)
, Assert
(Seed 125750466559701114 12297829382473034413)
(Seed.from 0x9cd9f015db4e58b7)
, Assert
(Seed 6781260234005250507 12297829382473034413)
(Seed.from 0xf4077b0dbebc73c0)
, Assert
(Seed 15306535823716590088 12297829382473034405)
(Seed.from 0x305cb877109d0686)
, Assert
(Seed 7344074043290227165 12297829382473034405)
(Seed.from 0x359e58eeafebd527)
, Assert
(Seed 9920554987610416076 12297829382473034405)
(Seed.from 0xbeb721c511b0da6d)
, Assert
(Seed 3341781972484278810 12297829382473034405)
(Seed.from 0x86466fd0fcc363a6)
, Assert
(Seed 12360157267739240775 12297829382473034421)
(Seed.from 0xefee3e7b93db3075)
, Assert
(Seed 600595566262245170 12297829382473034421)
(Seed.from 0x79629ee76aa83059)
, Assert
(Seed 1471112649570176389 12297829382473034421)
(Seed.from 0x05d507d05e785673)
, Assert
(Seed 8100917074368564322 12297829382473034421)
(Seed.from 0x76442b62dddf926c)
]
tests :: IO Bool
tests =
checkParallel $$(discover)
hedgehog-0.6.1/src/ 0000755 0000000 0000000 00000000000 13351371600 012244 5 ustar 00 0000000 0000000 hedgehog-0.6.1/src/Hedgehog.hs 0000644 0000000 0000000 00000010535 13351371600 014316 0 ustar 00 0000000 0000000 -- |
-- 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)
hedgehog-0.6.1/src/Hedgehog/ 0000755 0000000 0000000 00000000000 13351371600 013756 5 ustar 00 0000000 0000000 hedgehog-0.6.1/src/Hedgehog/Gen.hs 0000644 0000000 0000000 00000002512 13351371600 015023 0 ustar 00 0000000 0000000 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)
hedgehog-0.6.1/src/Hedgehog/Range.hs 0000644 0000000 0000000 00000001010 13351371600 015336 0 ustar 00 0000000 0000000 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Hedgehog.Range (
-- * Size
Size(..)
-- * Range
, Range
, origin
, bounds
, lowerBound
, upperBound
-- * Constant
, singleton
, constant
, constantFrom
, constantBounded
-- * Linear
, linear
, linearFrom
, linearFrac
, linearFracFrom
, linearBounded
-- * Exponential
, exponential
, exponentialFrom
, exponentialBounded
, exponentialFloat
, exponentialFloatFrom
) where
import Hedgehog.Internal.Range
hedgehog-0.6.1/src/Hedgehog/Internal/ 0000755 0000000 0000000 00000000000 13351371600 015532 5 ustar 00 0000000 0000000 hedgehog-0.6.1/src/Hedgehog/Internal/Seed.hs 0000644 0000000 0000000 00000013204 13351371600 016746 0 ustar 00 0000000 0000000 {-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
-- |
-- This is a port of "Fast Splittable Pseudorandom Number Generators" by Steele
-- et. al. [1].
--
-- The paper's algorithm provides decent randomness for most purposes but
-- sacrifices cryptographic-quality randomness in favor of speed. The original
-- implementation is tested with DieHarder and BigCrush; see the paper for
-- details.
--
-- This implementation, originally from [2], is a port from the paper.
--
-- It also takes in to account the SplittableRandom.java source code in OpenJDK
-- v8u40-b25 as well as splittable_random.ml in Jane Street's standard library
-- overlay (kernel) v113.33.03, and Random.fs in FsCheck v3.
--
-- Other than the choice of initial seed for 'from' this port should be
-- faithful.
--
-- 1. Guy L. Steele, Jr., Doug Lea, Christine H. Flood
-- Fast splittable pseudorandom number generators
-- Comm ACM, 49(10), Oct 2014, pp453-472.
--
-- 2. Nikos Baxevanis
-- https://github.com/moodmosaic/SplitMix/blob/master/SplitMix.hs
--
#include "MachDeps.h"
module Hedgehog.Internal.Seed (
Seed(..)
, random
, from
, split
, nextInteger
, nextDouble
-- * Internal
-- $internal
, goldenGamma
, nextWord64
, nextWord32
, mix64
, mix64variant13
, mix32
, mixGamma
) where
import Control.Monad.IO.Class (MonadIO(..))
import Data.Bifunctor (first)
import Data.Bits ((.|.), xor, shiftR, popCount)
#if (SIZEOF_HSINT == 8)
import Data.Int (Int64)
#else
import Data.Int (Int32)
#endif
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.IORef (IORef)
import qualified Data.IORef as IORef
import Data.Word (Word32, Word64)
import System.IO.Unsafe (unsafePerformIO)
import System.Random (RandomGen)
import qualified System.Random as Random
-- | A splittable random number generator.
--
data Seed =
Seed {
seedValue :: !Word64
, seedGamma :: !Word64 -- ^ must be an odd number
} deriving (Eq, Ord)
instance Show Seed where
showsPrec p (Seed v g) =
showParen (p > 10) $
showString "Seed " .
showsPrec 11 v .
showChar ' ' .
showsPrec 11 g
instance Read Seed where
readsPrec p =
readParen (p > 10) $ \r0 -> do
("Seed", r1) <- lex r0
(v, r2) <- readsPrec 11 r1
(g, r3) <- readsPrec 11 r2
pure (Seed v g, r3)
global :: IORef Seed
global =
unsafePerformIO $ do
-- FIXME use /dev/urandom on posix
seconds <- getPOSIXTime
IORef.newIORef $ from (round (seconds * 1000))
{-# NOINLINE global #-}
-- | Create a random 'Seed' using an effectful source of randomness.
--
random :: MonadIO m => m Seed
random =
liftIO $ IORef.atomicModifyIORef' global split
-- | Create a 'Seed' using a 'Word64'.
--
from :: Word64 -> Seed
from x =
Seed (mix64 x) (mixGamma (x + goldenGamma))
-- | A predefined gamma value's needed for initializing the "root" instances of
-- 'Seed'. That is, instances not produced by splitting an already existing
-- instance.
--
-- We choose: the odd integer closest to @2^64/φ@, where @φ = (1 + √5)/2@ is
-- the golden ratio.
--
goldenGamma :: Word64
goldenGamma =
0x9e3779b97f4a7c15
-- | Get the next value in the SplitMix sequence.
--
next :: Seed -> (Word64, Seed)
next (Seed v0 g) =
let
v = v0 + g
in
(v, Seed v g)
-- | Splits a random number generator in to two.
--
split :: Seed -> (Seed, Seed)
split s0 =
let
(v0, s1) = next s0
(g0, s2) = next s1
in
(s2, Seed (mix64 v0) (mixGamma g0))
-- | Generate a random 'Word64'.
--
nextWord64 :: Seed -> (Word64, Seed)
nextWord64 s0 =
let
(v0, s1) = next s0
in
(mix64 v0, s1)
-- | Generate a random 'Word32'.
--
nextWord32 :: Seed -> (Word32, Seed)
nextWord32 s0 =
let
(v0, s1) = next s0
in
(mix32 v0, s1)
-- | Generate a random 'Integer' in the [inclusive,inclusive] range.
--
nextInteger :: Integer -> Integer -> Seed -> (Integer, Seed)
nextInteger lo hi =
Random.randomR (lo, hi)
-- | Generate a random 'Double' in the [inclusive,exclusive) range.
--
nextDouble :: Double -> Double -> Seed -> (Double, Seed)
nextDouble lo hi =
Random.randomR (lo, hi)
mix64 :: Word64 -> Word64
mix64 x =
let
y = (x `xor` (x `shiftR` 33)) * 0xff51afd7ed558ccd
z = (y `xor` (y `shiftR` 33)) * 0xc4ceb9fe1a85ec53
in
z `xor` (z `shiftR` 33)
mix32 :: Word64 -> Word32
mix32 x =
let
y = (x `xor` (x `shiftR` 33)) * 0xff51afd7ed558ccd
z = (y `xor` (y `shiftR` 33)) * 0xc4ceb9fe1a85ec53
in
fromIntegral (z `shiftR` 32)
mix64variant13 :: Word64 -> Word64
mix64variant13 x =
let
y = (x `xor` (x `shiftR` 30)) * 0xbf58476d1ce4e5b9
z = (y `xor` (y `shiftR` 27)) * 0x94d049bb133111eb
in
z `xor` (z `shiftR` 31)
mixGamma :: Word64 -> Word64
mixGamma x =
let
y = mix64variant13 x .|. 1
n = popCount $ y `xor` (y `shiftR` 1)
in
if n < 24 then
y `xor` 0xaaaaaaaaaaaaaaaa
else
y
------------------------------------------------------------------------
-- RandomGen instances
#if (SIZEOF_HSINT == 8)
instance RandomGen Seed where
next =
first fromIntegral . nextWord64
genRange _ =
(fromIntegral (minBound :: Int64), fromIntegral (maxBound :: Int64))
split =
split
#else
instance RandomGen Seed where
next =
first fromIntegral . nextWord32
genRange _ =
(fromIntegral (minBound :: Int32), fromIntegral (maxBound :: Int32))
split =
split
#endif
------------------------------------------------------------------------
-- Internal
-- $internal
--
-- These functions are exported in case you need them in a pinch, but are not
-- part of the public API and may change at any time, even as part of a minor
-- update.
hedgehog-0.6.1/src/Hedgehog/Internal/State.hs 0000644 0000000 0000000 00000052442 13351371600 017155 0 ustar 00 0000000 0000000 {-# 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
hedgehog-0.6.1/src/Hedgehog/Internal/Report.hs 0000644 0000000 0000000 00000055367 13351371600 017361 0 ustar 00 0000000 0000000 {-# 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 "" (WL.text . unPropertyName) name
]
mergeLine :: Semigroup a => Line a -> Line a -> Line a
mergeLine (Line x no src) (Line y _ _) =
Line (x <> y) no src
mergeDeclaration :: Semigroup a => Declaration a -> Declaration a -> Declaration a
mergeDeclaration (Declaration file line name src0) (Declaration _ _ _ src1) =
Declaration file line name $
Map.unionWith mergeLine src0 src1
mergeDeclarations :: Semigroup a => [Declaration a] -> [Declaration a]
mergeDeclarations =
Map.elems .
Map.fromListWith mergeDeclaration .
fmap (\d -> ((declarationFile d, declarationLine d), d))
ppTextLines :: String -> [Doc Markup]
ppTextLines =
fmap WL.text . List.lines
ppFailureReport :: MonadIO m => Maybe PropertyName -> FailureReport -> m (Doc Markup)
ppFailureReport name (FailureReport size seed _ inputs0 mlocation0 msg mdiff msgs0) = do
(msgs, mlocation) <-
case mlocation0 of
Nothing ->
-- Move the failure message to the end section if we have
-- no source location.
let
msgs1 =
msgs0 ++
(if null msg then [] else [msg])
docs =
concatMap ppTextLines msgs1 ++
maybe [] ppDiff mdiff
in
pure (docs, Nothing)
Just location0 ->
(concatMap ppTextLines msgs0,)
<$> ppFailureLocation msg mdiff location0
(args, idecls) <- partitionEithers <$> zipWithM ppFailedInput [0..] inputs0
let
decls =
mergeDeclarations .
catMaybes $
mlocation : fmap pure idecls
with xs f =
if null xs then
[]
else
[f xs]
pure . WL.indent 2 . WL.vsep . WL.punctuate WL.line $ concat [
with args $
WL.vsep . WL.punctuate WL.line
, with decls $
WL.vsep . WL.punctuate WL.line . fmap ppDeclaration
, with msgs $
WL.vsep
, [ppReproduce name size seed]
]
ppName :: Maybe PropertyName -> Doc a
ppName = \case
Nothing ->
""
Just (PropertyName name) ->
WL.text name
ppProgress :: MonadIO m => Maybe PropertyName -> Report Progress -> m (Doc Markup)
ppProgress name (Report tests discards status) =
case status of
Running ->
pure . icon RunningIcon '●' . WL.annotate RunningHeader $
ppName name <+>
"passed" <+>
ppTestCount tests <>
ppWithDiscardCount discards <+>
"(running)"
Shrinking failure ->
pure . icon ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $
ppName name <+>
"failed after" <+>
ppTestCount tests <>
ppShrinkDiscard (failureShrinks failure) discards <+>
"(shrinking)"
ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup)
ppResult name (Report tests discards result) =
case result of
Failed failure -> do
pfailure <- ppFailureReport name failure
pure . WL.vsep $ [
icon FailedIcon '✗' . WL.annotate FailedHeader $
ppName name <+>
"failed after" <+>
ppTestCount tests <>
ppShrinkDiscard (failureShrinks failure) discards <>
"."
, mempty
, pfailure
, mempty
]
GaveUp ->
pure . icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader $
ppName name <+>
"gave up after" <+>
ppDiscardCount discards <>
", passed" <+>
ppTestCount tests <>
"."
OK ->
pure . icon SuccessIcon '✓' . WL.annotate SuccessHeader $
ppName name <+>
"passed" <+>
ppTestCount tests <>
"."
ppWhenNonZero :: Doc a -> PropertyCount -> Maybe (Doc a)
ppWhenNonZero suffix n =
if n <= 0 then
Nothing
else
Just $ ppRawPropertyCount n <+> suffix
annotateSummary :: Summary -> Doc Markup -> Doc Markup
annotateSummary summary =
if summaryFailed summary > 0 then
icon FailedIcon '✗' . WL.annotate FailedHeader
else if summaryGaveUp summary > 0 then
icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader
else if summaryWaiting summary > 0 || summaryRunning summary > 0 then
icon WaitingIcon '○' . WL.annotate WaitingHeader
else
icon SuccessIcon '✓' . WL.annotate SuccessHeader
ppSummary :: MonadIO m => Summary -> m (Doc Markup)
ppSummary summary =
let
complete =
summaryCompleted summary == summaryTotal summary
prefix end =
if complete then
mempty
else
ppRawPropertyCount (summaryCompleted summary) <>
"/" <>
ppRawPropertyCount (summaryTotal summary) <+>
"complete" <> end
addPrefix xs =
if null xs then
prefix mempty : []
else
prefix ": " : xs
suffix =
if complete then
"."
else
" (running)"
in
pure .
annotateSummary summary .
(<> suffix) .
WL.hcat .
addPrefix .
WL.punctuate ", " $
catMaybes [
ppWhenNonZero "failed" (summaryFailed summary)
, ppWhenNonZero "gave up" (summaryGaveUp summary)
, if complete then
ppWhenNonZero "succeeded" (summaryOK summary)
else
Nothing
]
renderDoc :: MonadIO m => Maybe UseColor -> Doc Markup -> m String
renderDoc mcolor doc = do
let
dull =
SetColor Foreground Dull
vivid =
SetColor Foreground Vivid
bold =
SetConsoleIntensity BoldIntensity
start = \case
WaitingIcon ->
setSGRCode []
WaitingHeader ->
setSGRCode []
RunningIcon ->
setSGRCode []
RunningHeader ->
setSGRCode []
ShrinkingIcon ->
setSGRCode [vivid Red]
ShrinkingHeader ->
setSGRCode [vivid Red]
FailedIcon ->
setSGRCode [vivid Red]
FailedHeader ->
setSGRCode [vivid Red]
GaveUpIcon ->
setSGRCode [dull Yellow]
GaveUpHeader ->
setSGRCode [dull Yellow]
SuccessIcon ->
setSGRCode [dull Green]
SuccessHeader ->
setSGRCode [dull Green]
DeclarationLocation ->
setSGRCode []
StyledLineNo StyleDefault ->
setSGRCode []
StyledSource StyleDefault ->
setSGRCode []
StyledBorder StyleDefault ->
setSGRCode []
StyledLineNo StyleAnnotation ->
setSGRCode [dull Magenta]
StyledSource StyleAnnotation ->
setSGRCode []
StyledBorder StyleAnnotation ->
setSGRCode []
AnnotationGutter ->
setSGRCode [dull Magenta]
AnnotationValue ->
setSGRCode [dull Magenta]
StyledLineNo StyleFailure ->
setSGRCode [vivid Red]
StyledSource StyleFailure ->
setSGRCode [vivid Red, bold]
StyledBorder StyleFailure ->
setSGRCode []
FailureArrows ->
setSGRCode [vivid Red]
FailureMessage ->
setSGRCode []
FailureGutter ->
setSGRCode []
DiffPrefix ->
setSGRCode []
DiffInfix ->
setSGRCode []
DiffSuffix ->
setSGRCode []
DiffSame ->
setSGRCode []
DiffRemoved ->
setSGRCode [dull Red]
DiffAdded ->
setSGRCode [dull Green]
ReproduceHeader ->
setSGRCode []
ReproduceGutter ->
setSGRCode []
ReproduceSource ->
setSGRCode []
end _ =
setSGRCode [Reset]
color <- resolveColor mcolor
let
display =
case color of
EnableColor ->
WL.displayDecorated start end id
DisableColor ->
WL.display
#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
hedgehog-0.6.1/src/Hedgehog/Internal/Distributive.hs 0000644 0000000 0000000 00000002770 13351371600 020551 0 ustar 00 0000000 0000000 {-# 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
hedgehog-0.6.1/src/Hedgehog/Internal/Source.hs 0000644 0000000 0000000 00000004564 13351371600 017337 0 ustar 00 0000000 0000000 {-# 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
hedgehog-0.6.1/src/Hedgehog/Internal/HTraversable.hs 0000644 0000000 0000000 00000000563 13351371600 020454 0 ustar 00 0000000 0000000 {-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE RankNTypes #-}
module Hedgehog.Internal.HTraversable (
HTraversable(..)
) where
-- | Higher-order traversable functors.
--
-- This is used internally to make symbolic variables concrete given an 'Environment'.
--
class HTraversable t where
htraverse :: Applicative f => (forall a. g a -> f (h a)) -> t g -> f (t h)
hedgehog-0.6.1/src/Hedgehog/Internal/Discovery.hs 0000644 0000000 0000000 00000013253 13351371600 020041 0 ustar 00 0000000 0000000 {-# 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
hedgehog-0.6.1/src/Hedgehog/Internal/Property.hs 0000644 0000000 0000000 00000052277 13351371600 017727 0 ustar 00 0000000 0000000 {-# 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.
hedgehog-0.6.1/src/Hedgehog/Internal/Tripping.hs 0000644 0000000 0000000 00000002367 13351371600 017672 0 ustar 00 0000000 0000000 {-# 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
]
hedgehog-0.6.1/src/Hedgehog/Internal/Gen.hs 0000644 0000000 0000000 00000116153 13351371600 016606 0 ustar 00 0000000 0000000 {-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- MonadBase
module Hedgehog.Internal.Gen (
-- * Transformer
Gen
, GenT(..)
, MonadGen(..)
-- * Combinators
, lift
-- ** Shrinking
, shrink
, prune
-- ** Size
, small
, scale
, resize
, sized
-- ** Integral
, integral
, integral_
, int
, int8
, int16
, int32
, int64
, word
, word8
, word16
, word32
, word64
-- ** Floating-point
, realFloat
, realFrac_
, float
, double
-- ** Enumeration
, enum
, enumBounded
, bool
, bool_
-- ** Characters
, binit
, octit
, digit
, hexit
, lower
, upper
, alpha
, alphaNum
, ascii
, latin1
, unicode
, unicodeAll
-- ** Strings
, string
, text
, utf8
, bytes
-- ** Choice
, constant
, element
, choice
, frequency
, recursive
-- ** Conditional
, discard
, ensure
, filter
, just
-- ** Collections
, maybe
, list
, seq
, nonEmpty
, set
, map
-- ** Subterms
, freeze
, subterm
, subtermM
, subterm2
, subtermM2
, subterm3
, subtermM3
-- ** Combinations & Permutations
, subsequence
, shuffle
-- * Sampling Generators
, sample
, print
, printTree
, printWith
, printTreeWith
-- * Internal
-- $internal
-- ** Transfomer
, runGenT
, mapGenT
, generate
, liftTree
, runDiscardEffect
-- ** Size
, golden
-- ** Shrinking
, atLeast
-- ** Characters
, isSurrogate
, isNoncharacter
-- ** Subterms
, Vec(..)
, Nat(..)
, subtermMVec
-- ** Sampling
, renderNodes
) where
import Control.Applicative (Alternative(..),liftA2)
import Control.Monad (MonadPlus(..), filterM, replicateM, ap, join)
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Morph (MFunctor(..), MMonad(..), generalize)
import Control.Monad.Primitive (PrimMonad(..))
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.State.Class (MonadState(..))
import Control.Monad.Trans.Class (MonadTrans)
import qualified Control.Monad.Trans.Class as Trans
import Control.Monad.Trans.Except (ExceptT(..), mapExceptT)
import Control.Monad.Trans.Identity (IdentityT(..), mapIdentityT)
import Control.Monad.Trans.Maybe (MaybeT(..), mapMaybeT)
import qualified Control.Monad.Trans.RWS.Lazy as Lazy
import qualified Control.Monad.Trans.RWS.Strict as Strict
import Control.Monad.Trans.Reader (ReaderT(..), mapReaderT)
import Control.Monad.Trans.Resource (MonadResource(..))
import qualified Control.Monad.Trans.State.Lazy as Lazy
import qualified Control.Monad.Trans.State.Strict as Strict
import qualified Control.Monad.Trans.Writer.Lazy as Lazy
import qualified Control.Monad.Trans.Writer.Strict as Strict
import Control.Monad.Writer.Class (MonadWriter(..))
import Data.Bifunctor (first, second)
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.Char as Char
import Data.Foldable (for_, toList)
import Data.Functor.Identity (Identity(..))
import Data.Int (Int8, Int16, Int32, Int64)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import Data.Semigroup (Semigroup)
import qualified Data.Semigroup as Semigroup
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Set (Set)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Word (Word8, Word16, Word32, Word64)
import Hedgehog.Internal.Distributive (Distributive(..))
import Hedgehog.Internal.Seed (Seed)
import qualified Hedgehog.Internal.Seed as Seed
import qualified Hedgehog.Internal.Shrink as Shrink
import Hedgehog.Internal.Tree (Tree(..), Node(..))
import qualified Hedgehog.Internal.Tree as Tree
import Hedgehog.Range (Size, Range)
import qualified Hedgehog.Range as Range
import Prelude hiding (filter, print, maybe, map, seq)
------------------------------------------------------------------------
-- Generator transformer
-- | Generator for random values of @a@.
--
type Gen =
GenT Identity
-- | Monad transformer which can generate random values of @a@.
--
newtype GenT m a =
GenT {
unGen :: Size -> Seed -> Tree (MaybeT m) a
}
-- | Runs a generator, producing its shrink tree.
--
runGenT :: Size -> Seed -> GenT m a -> Tree (MaybeT m) a
runGenT size seed (GenT m) =
m size seed
-- | Map over a generator's shrink tree.
--
mapGenT :: (Tree (MaybeT m) a -> Tree (MaybeT n) b) -> GenT m a -> GenT n b
mapGenT f gen =
GenT $ \size seed ->
f (runGenT size seed gen)
-- | Lift a predefined shrink tree in to a generator, ignoring the seed and the
-- size.
--
liftTree :: Tree (MaybeT m) a -> GenT m a
liftTree x =
GenT (\_ _ -> x)
-- | Run the discard effects through the tree and reify them as 'Maybe' values
-- at the nodes. 'Nothing' means discarded, 'Just' means we have a value.
--
runDiscardEffect :: Monad m => Tree (MaybeT m) a -> Tree m (Maybe a)
runDiscardEffect =
runMaybeT . distribute
------------------------------------------------------------------------
-- MonadGen
-- | Class of monads which can generate input data for tests.
--
-- /The functions on this class can, and should, be used without their @Gen@/
-- /suffix by importing "Hedgehog.Gen" qualified./
--
class Monad m => MonadGen m where
-- | See @Gen.@'Hedgehog.Gen.lift'
--
liftGen :: Gen a -> m a
-- | See @Gen.@'Hedgehog.Gen.shrink'
--
shrinkGen :: (a -> [a]) -> m a -> m a
-- | See @Gen.@'Hedgehog.Gen.prune'
--
pruneGen :: m a -> m a
-- | See @Gen.@'Hedgehog.Gen.scale'
--
scaleGen :: (Size -> Size) -> m a -> m a
-- | See @Gen.@'Hedgehog.Gen.freeze'
--
freezeGen :: m a -> m (a, m a)
instance Monad m => MonadGen (GenT m) where
liftGen gen =
hoist generalize gen
shrinkGen =
mapGenT . Tree.expand
pruneGen =
mapGenT Tree.prune
scaleGen f gen =
GenT $ \size0 seed ->
let
size =
f size0
in
if size < 0 then
error "Hedgehog.Gen.scale: negative size"
else
runGenT size seed gen
freezeGen gen =
GenT $ \size seed -> do
mx <- Trans.lift . Trans.lift . runMaybeT . runTree $ runGenT size seed gen
case mx of
Nothing ->
mzero
Just (Node x xs) ->
pure (x, liftTree . Tree.fromNode $ Node x xs)
instance MonadGen m => MonadGen (IdentityT m) where
liftGen =
Trans.lift . liftGen
shrinkGen f =
mapIdentityT (shrink f)
pruneGen =
hoist prune
scaleGen f =
hoist (scale f)
freezeGen =
mapIdentityT $
fmap (second Trans.lift) . freeze
shrinkMaybe :: (a -> [a]) -> Maybe a -> [Maybe a]
shrinkMaybe f = \case
Nothing ->
pure Nothing
Just x ->
fmap Just (f x)
shrinkEither :: (a -> [a]) -> Either x a -> [Either x a]
shrinkEither f = \case
Left x ->
pure $ Left x
Right x ->
fmap Right (f x)
shrink2 :: (a -> [a]) -> (a, b) -> [(a, b)]
shrink2 f (x, y) =
fmap (, y) (f x)
shrink3 :: (a -> [a]) -> (a, b, c) -> [(a, b, c)]
shrink3 f (x, y, z) =
fmap (, y, z) (f x)
instance MonadGen m => MonadGen (MaybeT m) where
liftGen =
Trans.lift . liftGen
shrinkGen f =
mapMaybeT $
shrink (shrinkMaybe f)
pruneGen =
hoist prune
scaleGen f =
hoist (scale f)
freezeGen =
mapMaybeT $ \m0 -> do
(mx, m) <- freeze m0
pure $ fmap (, MaybeT m) mx
instance MonadGen m => MonadGen (ExceptT x m) where
liftGen =
Trans.lift . liftGen
shrinkGen f =
mapExceptT $
shrink (shrinkEither f)
pruneGen =
hoist prune
scaleGen f =
hoist (scale f)
freezeGen =
mapExceptT $ \m0 -> do
(mx, m) <- freeze m0
pure $ fmap (, ExceptT m) mx
instance MonadGen m => MonadGen (ReaderT r m) where
liftGen =
Trans.lift . liftGen
shrinkGen f =
mapReaderT (shrink f)
pruneGen =
hoist prune
scaleGen f =
hoist (scale f)
freezeGen =
mapReaderT $
fmap (second Trans.lift) . freeze
instance MonadGen m => MonadGen (Lazy.StateT s m) where
liftGen =
Trans.lift . liftGen
shrinkGen f =
Lazy.mapStateT $
shrink (shrink2 f)
pruneGen =
hoist prune
scaleGen f =
hoist (scale f)
freezeGen m0 =
Lazy.StateT $ \s0 -> do
((x, s), m) <- freeze (Lazy.runStateT m0 s0)
pure ((x, Lazy.StateT (const m)), s)
instance MonadGen m => MonadGen (Strict.StateT s m) where
liftGen =
Trans.lift . liftGen
shrinkGen f =
Strict.mapStateT $
shrink (shrink2 f)
pruneGen =
hoist prune
scaleGen f =
hoist (scale f)
freezeGen m0 =
Strict.StateT $ \s0 -> do
((x, s), m) <- freeze (Strict.runStateT m0 s0)
pure ((x, Strict.StateT (const m)), s)
instance (MonadGen m, Monoid w) => MonadGen (Lazy.WriterT w m) where
liftGen =
Trans.lift . liftGen
shrinkGen f =
Lazy.mapWriterT $
shrink (shrink2 f)
pruneGen =
hoist prune
scaleGen f =
hoist (scale f)
freezeGen m0 =
Lazy.WriterT $ do
((x, w), m) <- freeze (Lazy.runWriterT m0)
pure ((x, Lazy.WriterT m), w)
instance (MonadGen m, Monoid w) => MonadGen (Strict.WriterT w m) where
liftGen =
Trans.lift . liftGen
shrinkGen f =
Strict.mapWriterT $
shrink (shrink2 f)
pruneGen =
hoist prune
scaleGen f =
hoist (scale f)
freezeGen m0 =
Strict.WriterT $ do
((x, w), m) <- freeze (Strict.runWriterT m0)
pure ((x, Strict.WriterT m), w)
instance (MonadGen m, Monoid w) => MonadGen (Lazy.RWST r w s m) where
liftGen =
Trans.lift . liftGen
shrinkGen f =
Lazy.mapRWST $
shrink (shrink3 f)
pruneGen =
hoist prune
scaleGen f =
hoist (scale f)
freezeGen m0 =
Lazy.RWST $ \r s0 -> do
((x, s, w), m) <- freeze (Lazy.runRWST m0 r s0)
pure ((x, Lazy.RWST (\_ _ -> m)), s, w)
instance (MonadGen m, Monoid w) => MonadGen (Strict.RWST r w s m) where
liftGen =
Trans.lift . liftGen
shrinkGen f =
Strict.mapRWST $
shrink (shrink3 f)
pruneGen =
hoist prune
scaleGen f =
hoist (scale f)
freezeGen m0 =
Strict.RWST $ \r s0 -> do
((x, s, w), m) <- freeze (Strict.runRWST m0 r s0)
pure ((x, Strict.RWST (\_ _ -> m)), s, w)
------------------------------------------------------------------------
-- GenT instances
instance (Monad m, Semigroup a) => Semigroup (GenT m a) where
(<>) = liftA2 (Semigroup.<>)
instance (Monad m, Monoid a) => Monoid (GenT m a) where
mappend = liftA2 mappend
mempty = return mempty
instance Functor m => Functor (GenT m) where
fmap f gen =
GenT $ \seed size ->
fmap f (runGenT seed size gen)
instance Monad m => Applicative (GenT m) where
pure =
return
(<*>) =
ap
instance Monad m => Monad (GenT m) where
return =
liftTree . pure
(>>=) m k =
GenT $ \size seed ->
case Seed.split seed of
(sk, sm) ->
runGenT size sk . k =<<
runGenT size sm m
instance Monad m => Alternative (GenT m) where
empty =
mzero
(<|>) =
mplus
instance Monad m => MonadPlus (GenT m) where
mzero =
liftTree mzero
mplus x y =
GenT $ \size seed ->
case Seed.split seed of
(sx, sy) ->
runGenT size sx x `mplus`
runGenT size sy y
instance MonadTrans GenT where
lift =
liftTree . Trans.lift . Trans.lift
instance MFunctor GenT where
hoist f =
mapGenT (hoist (hoist f))
embedMaybe ::
MonadTrans t
=> Monad n
=> Monad (t (MaybeT n))
=> (forall a. m a -> t (MaybeT n) a)
-> MaybeT m b
-> t (MaybeT n) b
embedMaybe f m =
Trans.lift . MaybeT . pure =<< f (runMaybeT m)
embedTree :: Monad n => (forall a. m a -> Tree (MaybeT n) a) -> Tree (MaybeT m) b -> Tree (MaybeT n) b
embedTree f tree =
embed (embedMaybe f) tree
embedGen :: Monad n => (forall a. m a -> GenT n a) -> GenT m b -> GenT n b
embedGen f gen =
GenT $ \size seed ->
case Seed.split seed of
(sf, sg) ->
(runGenT size sf . f) `embedTree`
(runGenT size sg gen)
instance MMonad GenT where
embed =
embedGen
distributeGen :: Transformer t GenT m => GenT (t m) a -> t (GenT m) a
distributeGen x =
join . Trans.lift . GenT $ \size seed ->
pure . hoist liftTree . distribute . hoist distribute $ runGenT size seed x
instance Distributive GenT where
type Transformer t GenT m = (
Monad (t (GenT m))
, Transformer t MaybeT m
, Transformer t Tree (MaybeT m)
)
distribute =
distributeGen
instance PrimMonad m => PrimMonad (GenT m) where
type PrimState (GenT m) =
PrimState m
primitive =
Trans.lift . primitive
instance MonadIO m => MonadIO (GenT m) where
liftIO =
Trans.lift . liftIO
instance MonadBase b m => MonadBase b (GenT m) where
liftBase =
Trans.lift . liftBase
instance MonadThrow m => MonadThrow (GenT m) where
throwM =
Trans.lift . throwM
instance MonadCatch m => MonadCatch (GenT m) where
catch m onErr =
GenT $ \size seed ->
case Seed.split seed of
(sm, se) ->
(runGenT size sm m) `catch`
(runGenT size se . onErr)
instance MonadReader r m => MonadReader r (GenT m) where
ask =
Trans.lift ask
local f m =
mapGenT (local f) m
instance MonadState s m => MonadState s (GenT m) where
get =
Trans.lift get
put =
Trans.lift . put
state =
Trans.lift . state
instance MonadWriter w m => MonadWriter w (GenT m) where
writer =
Trans.lift . writer
tell =
Trans.lift . tell
listen =
mapGenT listen
pass =
mapGenT pass
instance MonadError e m => MonadError e (GenT m) where
throwError =
Trans.lift . throwError
catchError m onErr =
GenT $ \size seed ->
case Seed.split seed of
(sm, se) ->
(runGenT size sm m) `catchError`
(runGenT size se . onErr)
instance MonadResource m => MonadResource (GenT m) where
liftResourceT =
Trans.lift . liftResourceT
------------------------------------------------------------------------
-- Combinators
-- | Lift a vanilla 'Gen' in to a 'MonadGen'.
--
lift :: MonadGen m => Gen a -> m a
lift =
liftGen
-- | Generate a value with no shrinks from a 'Size' and a 'Seed'.
--
generate :: MonadGen m => (Size -> Seed -> a) -> m a
generate f =
liftGen . GenT $ \size seed ->
pure (f size seed)
------------------------------------------------------------------------
-- Combinators - Shrinking
-- | Apply a shrinking function to a generator.
--
-- This will give the generator additional shrinking options, while keeping
-- the existing shrinks intact.
--
shrink :: MonadGen m => (a -> [a]) -> m a -> m a
shrink =
shrinkGen
-- | Throw away a generator's shrink tree.
--
prune :: MonadGen m => m a -> m a
prune =
pruneGen
------------------------------------------------------------------------
-- Combinators - Size
-- | Construct a generator that depends on the size parameter.
--
sized :: MonadGen m => (Size -> m a) -> m a
sized f = do
f =<< generate (\size _ -> size)
-- | Override the size parameter. Returns a generator which uses the given size
-- instead of the runtime-size parameter.
--
resize :: MonadGen m => Size -> m a -> m a
resize size gen =
scale (const size) gen
-- | Adjust the size parameter by transforming it with the given function.
--
scale :: MonadGen m => (Size -> Size) -> m a -> m a
scale =
scaleGen
-- | Make a generator smaller by scaling its size parameter.
--
small :: MonadGen m => m a -> m a
small =
scale golden
-- | Scale a size using the golden ratio.
--
-- > golden x = x / φ
-- > golden x = x / 1.61803..
--
golden :: Size -> Size
golden x =
round (fromIntegral x * 0.61803398875 :: Double)
------------------------------------------------------------------------
-- Combinators - Integral
-- | Generates a random integral number in the given @[inclusive,inclusive]@ range.
--
-- When the generator tries to shrink, it will shrink towards the
-- 'Range.origin' of the specified 'Range'.
--
-- For example, the following generator will produce a number between @1970@
-- and @2100@, but will shrink towards @2000@:
--
-- @
-- integral (Range.'Range.constantFrom' 2000 1970 2100) :: 'Gen' 'Int'
-- @
--
-- Some sample outputs from this generator might look like:
--
-- > === Outcome ===
-- > 1973
-- > === Shrinks ===
-- > 2000
-- > 1987
-- > 1980
-- > 1976
-- > 1974
--
-- > === Outcome ===
-- > 2061
-- > === Shrinks ===
-- > 2000
-- > 2031
-- > 2046
-- > 2054
-- > 2058
-- > 2060
--
integral :: (MonadGen m, Integral a) => Range a -> m a
integral range =
shrink (Shrink.towards $ Range.origin range) (integral_ range)
-- | Generates a random integral number in the [inclusive,inclusive] range.
--
-- /This generator does not shrink./
--
integral_ :: (MonadGen m, Integral a) => Range a -> m a
integral_ range =
generate $ \size seed ->
let
(x, y) =
Range.bounds size range
in
fromInteger . fst $
Seed.nextInteger (toInteger x) (toInteger y) seed
-- | Generates a random machine integer in the given @[inclusive,inclusive]@ range.
--
-- /This is a specialization of 'integral', offered for convenience./
--
int :: MonadGen m => Range Int -> m Int
int =
integral
-- | Generates a random 8-bit integer in the given @[inclusive,inclusive]@ range.
--
-- /This is a specialization of 'integral', offered for convenience./
--
int8 :: MonadGen m => Range Int8 -> m Int8
int8 =
integral
-- | Generates a random 16-bit integer in the given @[inclusive,inclusive]@ range.
--
-- /This is a specialization of 'integral', offered for convenience./
--
int16 :: MonadGen m => Range Int16 -> m Int16
int16 =
integral
-- | Generates a random 32-bit integer in the given @[inclusive,inclusive]@ range.
--
-- /This is a specialization of 'integral', offered for convenience./
--
int32 :: MonadGen m => Range Int32 -> m Int32
int32 =
integral
-- | Generates a random 64-bit integer in the given @[inclusive,inclusive]@ range.
--
-- /This is a specialization of 'integral', offered for convenience./
--
int64 :: MonadGen m => Range Int64 -> m Int64
int64 =
integral
-- | Generates a random machine word in the given @[inclusive,inclusive]@ range.
--
-- /This is a specialization of 'integral', offered for convenience./
--
word :: MonadGen m => Range Word -> m Word
word =
integral
-- | Generates a random byte in the given @[inclusive,inclusive]@ range.
--
-- /This is a specialization of 'integral', offered for convenience./
--
word8 :: MonadGen m => Range Word8 -> m Word8
word8 =
integral
-- | Generates a random 16-bit word in the given @[inclusive,inclusive]@ range.
--
-- /This is a specialization of 'integral', offered for convenience./
--
word16 :: MonadGen m => Range Word16 -> m Word16
word16 =
integral
-- | Generates a random 32-bit word in the given @[inclusive,inclusive]@ range.
--
-- /This is a specialization of 'integral', offered for convenience./
--
word32 :: MonadGen m => Range Word32 -> m Word32
word32 =
integral
-- | Generates a random 64-bit word in the given @[inclusive,inclusive]@ range.
--
-- /This is a specialization of 'integral', offered for convenience./
--
word64 :: MonadGen m => Range Word64 -> m Word64
word64 =
integral
------------------------------------------------------------------------
-- Combinators - Fractional / Floating-Point
-- | Generates a random floating-point number in the @[inclusive,exclusive)@ range.
--
-- This generator works the same as 'integral', but for floating point numbers.
--
realFloat :: (MonadGen m, RealFloat a) => Range a -> m a
realFloat range =
shrink (Shrink.towardsFloat $ Range.origin range) (realFrac_ range)
-- | Generates a random fractional number in the [inclusive,exclusive) range.
--
-- /This generator does not shrink./
--
realFrac_ :: (MonadGen m, RealFrac a) => Range a -> m a
realFrac_ range =
generate $ \size seed ->
let
(x, y) =
Range.bounds size range
in
realToFrac . fst $
Seed.nextDouble (realToFrac x) (realToFrac y) seed
-- | Generates a random floating-point number in the @[inclusive,exclusive)@ range.
--
-- /This is a specialization of 'realFloat', offered for convenience./
--
float :: MonadGen m => Range Float -> m Float
float =
realFloat
-- | Generates a random floating-point number in the @[inclusive,exclusive)@ range.
--
-- /This is a specialization of 'realFloat', offered for convenience./
--
double :: MonadGen m => Range Double -> m Double
double =
realFloat
------------------------------------------------------------------------
-- Combinators - Enumeration
-- | Generates an element from an enumeration.
--
-- This generator shrinks towards the first argument.
--
-- For example:
--
-- @
-- enum \'a' \'z' :: 'Gen' 'Char'
-- @
--
enum :: (MonadGen m, Enum a) => a -> a -> m a
enum lo hi =
fmap toEnum . integral $
Range.constant (fromEnum lo) (fromEnum hi)
-- | Generates a random value from a bounded enumeration.
--
-- This generator shrinks towards 'minBound'.
--
-- For example:
--
-- @
-- enumBounded :: 'Gen' 'Bool'
-- @
--
enumBounded :: (MonadGen m, Enum a, Bounded a) => m a
enumBounded =
enum minBound maxBound
-- | Generates a random boolean.
--
-- This generator shrinks to 'False'.
--
-- /This is a specialization of 'enumBounded', offered for convenience./
--
bool :: MonadGen m => m Bool
bool =
enumBounded
-- | Generates a random boolean.
--
-- /This generator does not shrink./
--
bool_ :: MonadGen m => m Bool
bool_ =
generate $ \_ seed ->
(/= 0) . fst $ Seed.nextInteger 0 1 seed
------------------------------------------------------------------------
-- Combinators - Characters
-- | Generates an ASCII binit: @'0'..'1'@
--
binit :: MonadGen m => m Char
binit =
enum '0' '1'
-- | Generates an ASCII octit: @'0'..'7'@
--
octit :: MonadGen m => m Char
octit =
enum '0' '7'
-- | Generates an ASCII digit: @'0'..'9'@
--
digit :: MonadGen m => m Char
digit =
enum '0' '9'
-- | Generates an ASCII hexit: @'0'..'9', \'a\'..\'f\', \'A\'..\'F\'@
--
hexit :: MonadGen m => m Char
hexit =
-- FIXME optimize lookup, use a SmallArray or something.
element "0123456789aAbBcCdDeEfF"
-- | Generates an ASCII lowercase letter: @\'a\'..\'z\'@
--
lower :: MonadGen m => m Char
lower =
enum 'a' 'z'
-- | Generates an ASCII uppercase letter: @\'A\'..\'Z\'@
--
upper :: MonadGen m => m Char
upper =
enum 'A' 'Z'
-- | Generates an ASCII letter: @\'a\'..\'z\', \'A\'..\'Z\'@
--
alpha :: MonadGen m => m Char
alpha =
-- FIXME optimize lookup, use a SmallArray or something.
element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
-- | Generates an ASCII letter or digit: @\'a\'..\'z\', \'A\'..\'Z\', \'0\'..\'9\'@
--
alphaNum :: MonadGen m => m Char
alphaNum =
-- FIXME optimize lookup, use a SmallArray or something.
element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
-- | Generates an ASCII character: @'\0'..'\127'@
--
ascii :: MonadGen m => m Char
ascii =
enum '\0' '\127'
-- | Generates a Latin-1 character: @'\0'..'\255'@
--
latin1 :: MonadGen m => m Char
latin1 =
enum '\0' '\255'
-- | Generates a Unicode character, excluding noncharacters and invalid standalone surrogates:
-- @'\0'..'\1114111' (excluding '\55296'..'\57343')@
--
unicode :: MonadGen m => m Char
unicode =
filter (not . isNoncharacter) $ filter (not . isSurrogate) unicodeAll
-- | Generates a Unicode character, including noncharacters and invalid standalone surrogates:
-- @'\0'..'\1114111'@
--
unicodeAll :: MonadGen m => m Char
unicodeAll =
enumBounded
-- | Check if a character is in the surrogate category.
--
isSurrogate :: Char -> Bool
isSurrogate x =
x >= '\55296' && x <= '\57343'
-- | Check if a character is one of the noncharacters '\65534', '\65535'.
--
isNoncharacter :: Char -> Bool
isNoncharacter x =
x == '\65534' || x == '\65535'
------------------------------------------------------------------------
-- Combinators - Strings
-- | Generates a string using 'Range' to determine the length.
--
-- /This is a specialization of 'list', offered for convenience./
--
string :: MonadGen m => Range Int -> m Char -> m String
string =
list
-- | Generates a string using 'Range' to determine the length.
--
text :: MonadGen m => Range Int -> m Char -> m Text
text range =
fmap Text.pack . string range
-- | Generates a UTF-8 encoded string, using 'Range' to determine the length.
--
utf8 :: MonadGen m => Range Int -> m Char -> m ByteString
utf8 range =
fmap Text.encodeUtf8 . text range
-- | Generates a random 'ByteString', using 'Range' to determine the
-- length.
--
bytes :: MonadGen m => Range Int -> m ByteString
bytes range =
fmap ByteString.pack $
choice [
list range . word8 $
Range.constant
(fromIntegral $ Char.ord 'a')
(fromIntegral $ Char.ord 'z')
, list range . word8 $
Range.constant minBound maxBound
]
------------------------------------------------------------------------
-- Combinators - Choice
-- | Trivial generator that always produces the same element.
--
-- /This is another name for 'pure' \/ 'return'./
constant :: MonadGen m => a -> m a
constant =
pure
-- | Randomly selects one of the elements in the list.
--
-- This generator shrinks towards the first element in the list.
--
-- /The input list must be non-empty./
--
element :: MonadGen m => [a] -> m a
element = \case
[] ->
error "Hedgehog.Gen.element: used with empty list"
xs -> do
n <- integral $ Range.constant 0 (length xs - 1)
pure $ xs !! n
-- | Randomly selects one of the generators in the list.
--
-- This generator shrinks towards the first generator in the list.
--
-- /The input list must be non-empty./
--
choice :: MonadGen m => [m a] -> m a
choice = \case
[] ->
error "Hedgehog.Gen.choice: used with empty list"
xs -> do
n <- integral $ Range.constant 0 (length xs - 1)
xs !! n
-- | Uses a weighted distribution to randomly select one of the generators in
-- the list.
--
-- This generator shrinks towards the first generator in the list.
--
-- /The input list must be non-empty./
--
frequency :: MonadGen m => [(Int, m a)] -> m a
frequency = \case
[] ->
error "Hedgehog.Gen.frequency: used with empty list"
xs0 -> do
let
pick n = \case
[] ->
error "Hedgehog.Gen.frequency/pick: used with empty list"
(k, x) : xs ->
if n <= k then
x
else
pick (n - k) xs
total =
sum (fmap fst xs0)
n <- integral $ Range.constant 1 total
pick n xs0
-- | Modifies combinators which choose from a list of generators, like 'choice'
-- or 'frequency', so that they can be used in recursive scenarios.
--
-- This combinator modifies its target to select one of the generators in
-- either the non-recursive or the recursive list. When a selection is made
-- from the recursive list, the 'Size' is halved. When the 'Size' gets to one
-- or less, selections are no longer made from the recursive list, this
-- ensures termination.
--
-- A good example of where this might be useful is abstract syntax trees:
--
-- @
-- data Expr =
-- Var String
-- | Lam String Expr
-- | App Expr Expr
--
-- -- Assuming we have a name generator
-- genName :: 'MonadGen' m => m String
--
-- -- We can write a generator for expressions
-- genExpr :: 'MonadGen' m => m Expr
-- genExpr =
-- Gen.'recursive' Gen.'choice' [
-- -- non-recursive generators
-- Var '<$>' genName
-- ] [
-- -- recursive generators
-- Gen.'subtermM' genExpr (\x -> Lam '<$>' genName '<*>' pure x)
-- , Gen.'subterm2' genExpr genExpr App
-- ]
-- @
--
-- If we wrote the above example using only 'choice', it is likely that it
-- would fail to terminate. This is because for every call to @genExpr@,
-- there is a 2 in 3 chance that we will recurse again.
--
recursive :: MonadGen m => ([m a] -> m a) -> [m a] -> [m a] -> m a
recursive f nonrec rec =
sized $ \n ->
if n <= 1 then
f nonrec
else
f $ nonrec ++ fmap small rec
------------------------------------------------------------------------
-- Combinators - Conditional
-- | Discards the whole generator.
--
discard :: MonadGen m => m a
discard =
liftGen mzero
-- | Discards the generator if the generated value does not satisfy the
-- predicate.
--
ensure :: MonadGen m => (a -> Bool) -> m a -> m a
ensure p gen = do
x <- gen
if p x then
pure x
else
discard
-- | Generates a value that satisfies a predicate.
--
-- This is essentially:
--
-- @
-- filter p gen = 'mfilter' p gen '<|>' filter p gen
-- @
--
-- It differs from the above in that we keep some state to avoid looping
-- forever. If we trigger these limits then the whole generator is discarded.
--
filter :: MonadGen m => (a -> Bool) -> m a -> m a
filter p gen =
let
try k =
if k > 100 then
discard
else do
x <- scale (2 * k +) gen
if p x then
pure x
else
try (k + 1)
in
try 0
-- | Runs a 'Maybe' generator until it produces a 'Just'.
--
-- This is implemented using 'filter' and has the same caveats.
--
just :: MonadGen m => m (Maybe a) -> m a
just g = do
mx <- filter Maybe.isJust g
case mx of
Just x ->
pure x
Nothing ->
error "Hedgehog.Gen.just: internal error, unexpected Nothing"
------------------------------------------------------------------------
-- Combinators - Collections
-- | Generates a 'Nothing' some of the time.
--
maybe :: MonadGen m => m a -> m (Maybe a)
maybe gen =
sized $ \n ->
frequency [
(2, pure Nothing)
, (1 + fromIntegral n, Just <$> gen)
]
-- | Generates a list using a 'Range' to determine the length.
--
list :: MonadGen m => Range Int -> m a -> m [a]
list range gen =
sized $ \size ->
(traverse snd =<<) .
ensure (atLeast $ Range.lowerBound size range) .
shrink Shrink.list $ do
k <- integral_ range
replicateM k (freeze gen)
-- | Generates a seq using a 'Range' to determine the length.
--
seq :: MonadGen m => Range Int -> m a -> m (Seq a)
seq range gen =
Seq.fromList <$> list range gen
-- | Generates a non-empty list using a 'Range' to determine the length.
--
nonEmpty :: MonadGen m => Range Int -> m a -> m (NonEmpty a)
nonEmpty range gen = do
xs <- list (fmap (max 1) range) gen
case xs of
[] ->
error "Hedgehog.Gen.nonEmpty: internal error, generated empty list"
_ ->
pure $ NonEmpty.fromList xs
-- | Generates a set using a 'Range' to determine the length.
--
-- /This may fail to generate anything if the element generator/
-- /cannot produce a large enough number of unique items to satify/
-- /the required set size./
--
set :: (MonadGen m, Ord a) => Range Int -> m a -> m (Set a)
set range gen =
fmap Map.keysSet . map range $ fmap (, ()) gen
-- | Generates a map using a 'Range' to determine the length.
--
-- /This may fail to generate anything if the keys produced by the/
-- /generator do not account for a large enough number of unique/
-- /items to satify the required map size./
--
map :: (MonadGen m, Ord k) => Range Int -> m (k, v) -> m (Map k v)
map range gen =
sized $ \size ->
ensure ((>= Range.lowerBound size range) . Map.size) .
fmap Map.fromList .
(sequence =<<) .
shrink Shrink.list $ do
k <- integral_ range
uniqueByKey k gen
-- | Generate exactly 'n' unique generators.
--
uniqueByKey :: (MonadGen m, Ord k) => Int -> m (k, v) -> m [m (k, v)]
uniqueByKey n gen =
let
try k xs0 =
if k > 100 then
discard
else
replicateM n (freeze gen) >>= \kvs ->
case uniqueInsert n xs0 (fmap (first fst) kvs) of
Left xs ->
pure $ Map.elems xs
Right xs ->
try (k + 1) xs
in
try (0 :: Int) Map.empty
uniqueInsert :: Ord k => Int -> Map k v -> [(k, v)] -> Either (Map k v) (Map k v)
uniqueInsert n xs kvs0 =
if Map.size xs >= n then
Left xs
else
case kvs0 of
[] ->
Right xs
(k, v) : kvs ->
uniqueInsert n (Map.insertWith (\x _ -> x) k v xs) kvs
-- | Check that list contains at least a certain number of elements.
--
atLeast :: Int -> [a] -> Bool
atLeast n =
if n == 0 then
const True
else
not . null . drop (n - 1)
------------------------------------------------------------------------
-- Combinators - Subterms
data Subterms n a =
One a
| All (Vec n a)
deriving (Functor, Foldable, Traversable)
data Nat =
Z
| S Nat
data Vec n a where
Nil :: Vec 'Z a
(:.) :: a -> Vec n a -> Vec ('S n) a
infixr 5 :.
deriving instance Functor (Vec n)
deriving instance Foldable (Vec n)
deriving instance Traversable (Vec n)
-- | Freeze the size and seed used by a generator, so we can inspect the value
-- which it will produce.
--
-- This is used for implementing `list` and `subtermMVec`. It allows us to
-- shrink the list itself before trying to shrink the values inside the list.
--
freeze :: MonadGen m => m a -> m (a, m a)
freeze =
freezeGen
shrinkSubterms :: Subterms n a -> [Subterms n a]
shrinkSubterms = \case
One _ ->
[]
All xs ->
fmap One $ toList xs
genSubterms :: MonadGen m => Vec n (m a) -> m (Subterms n a)
genSubterms =
(sequence =<<) .
shrink shrinkSubterms .
fmap All .
mapM (fmap snd . freeze)
fromSubterms :: Applicative m => (Vec n a -> m a) -> Subterms n a -> m a
fromSubterms f = \case
One x ->
pure x
All xs ->
f xs
-- | Constructs a generator from a number of sub-term generators.
--
-- /Shrinks to one of the sub-terms if possible./
--
subtermMVec :: MonadGen m => Vec n (m a) -> (Vec n a -> m a) -> m a
subtermMVec gs f =
fromSubterms f =<< genSubterms gs
-- | Constructs a generator from a sub-term generator.
--
-- /Shrinks to the sub-term if possible./
--
subtermM :: MonadGen m => m a -> (a -> m a) -> m a
subtermM gx f =
subtermMVec (gx :. Nil) $ \(x :. Nil) ->
f x
-- | Constructs a generator from a sub-term generator.
--
-- /Shrinks to the sub-term if possible./
--
subterm :: MonadGen m => m a -> (a -> a) -> m a
subterm gx f =
subtermM gx $ \x ->
pure (f x)
-- | Constructs a generator from two sub-term generators.
--
-- /Shrinks to one of the sub-terms if possible./
--
subtermM2 :: MonadGen m => m a -> m a -> (a -> a -> m a) -> m a
subtermM2 gx gy f =
subtermMVec (gx :. gy :. Nil) $ \(x :. y :. Nil) ->
f x y
-- | Constructs a generator from two sub-term generators.
--
-- /Shrinks to one of the sub-terms if possible./
--
subterm2 :: MonadGen m => m a -> m a -> (a -> a -> a) -> m a
subterm2 gx gy f =
subtermM2 gx gy $ \x y ->
pure (f x y)
-- | Constructs a generator from three sub-term generators.
--
-- /Shrinks to one of the sub-terms if possible./
--
subtermM3 :: MonadGen m => m a -> m a -> m a -> (a -> a -> a -> m a) -> m a
subtermM3 gx gy gz f =
subtermMVec (gx :. gy :. gz :. Nil) $ \(x :. y :. z :. Nil) ->
f x y z
-- | Constructs a generator from three sub-term generators.
--
-- /Shrinks to one of the sub-terms if possible./
--
subterm3 :: MonadGen m => m a -> m a -> m a -> (a -> a -> a -> a) -> m a
subterm3 gx gy gz f =
subtermM3 gx gy gz $ \x y z ->
pure (f x y z)
------------------------------------------------------------------------
-- Combinators - Combinations & Permutations
-- | Generates a random subsequence of a list.
--
subsequence :: MonadGen m => [a] -> m [a]
subsequence xs =
shrink Shrink.list $ filterM (const bool_) xs
-- | Generates a random permutation of a list.
--
-- This shrinks towards the order of the list being identical to the input
-- list.
--
shuffle :: MonadGen m => [a] -> m [a]
shuffle = \case
[] ->
pure []
xs0 -> do
n <- integral $ Range.constant 0 (length xs0 - 1)
case splitAt n xs0 of
(xs, y : ys) ->
(y :) <$> shuffle (xs ++ ys)
(_, []) ->
error "Hedgehog.Gen.shuffle: internal error, split generated empty list"
------------------------------------------------------------------------
-- Sampling
-- | Generate a sample from a generator.
--
sample :: MonadIO m => Gen a -> m a
sample gen =
liftIO $
let
loop n =
if n <= 0 then
error "Hedgehog.Gen.sample: too many discards, could not generate a sample"
else do
seed <- Seed.random
case runIdentity . runMaybeT . runTree $ runGenT 30 seed gen of
Nothing ->
loop (n - 1)
Just x ->
pure $ nodeValue x
in
loop (100 :: Int)
-- | Print the value produced by a generator, and the first level of shrinks,
-- for the given size and seed.
--
-- Use 'print' to generate a value from a random seed.
--
printWith :: (MonadIO m, Show a) => Size -> Seed -> Gen a -> m ()
printWith size seed gen =
liftIO $ do
let
Node x ss =
runIdentity . runTree $ renderNodes size seed gen
putStrLn "=== Outcome ==="
putStrLn x
putStrLn "=== Shrinks ==="
for_ ss $ \s ->
let
Node y _ =
runIdentity $ runTree s
in
putStrLn y
-- | Print the shrink tree produced by a generator, for the given size and
-- seed.
--
-- Use 'printTree' to generate a value from a random seed.
--
printTreeWith :: (MonadIO m, Show a) => Size -> Seed -> Gen a -> m ()
printTreeWith size seed gen = do
liftIO . putStr . runIdentity . Tree.render $ renderNodes size seed gen
-- | Run a generator with a random seed and print the outcome, and the first
-- level of shrinks.
--
-- @
-- Gen.print (Gen.'enum' \'a\' \'f\')
-- @
--
-- > === Outcome ===
-- > 'd'
-- > === Shrinks ===
-- > 'a'
-- > 'b'
-- > 'c'
--
print :: (MonadIO m, Show a) => Gen a -> m ()
print gen = do
seed <- liftIO Seed.random
printWith 30 seed gen
-- | Run a generator with a random seed and print the resulting shrink tree.
--
-- @
-- Gen.printTree (Gen.'enum' \'a\' \'f\')
-- @
--
-- > 'd'
-- > ├╼'a'
-- > ├╼'b'
-- > │ └╼'a'
-- > └╼'c'
-- > ├╼'a'
-- > └╼'b'
-- > └╼'a'
--
-- /This may not terminate when the tree is very large./
--
printTree :: (MonadIO m, Show a) => Gen a -> m ()
printTree gen = do
seed <- liftIO Seed.random
printTreeWith 30 seed gen
-- | Render a generator as a tree of strings.
--
renderNodes :: (Monad m, Show a) => Size -> Seed -> Gen a -> Tree m String
renderNodes size seed =
fmap (Maybe.maybe "" show) . runDiscardEffect . runGenT size seed . lift
------------------------------------------------------------------------
-- Internal
-- $internal
--
-- These functions are exported in case you need them in a pinch, but are not
-- part of the public API and may change at any time, even as part of a minor
-- update.
hedgehog-0.6.1/src/Hedgehog/Internal/Config.hs 0000644 0000000 0000000 00000007424 13351371600 017302 0 ustar 00 0000000 0000000 {-# 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)
hedgehog-0.6.1/src/Hedgehog/Internal/Shrink.hs 0000644 0000000 0000000 00000005436 13351371600 017334 0 ustar 00 0000000 0000000 {-# OPTIONS_HADDOCK not-home #-}
module Hedgehog.Internal.Shrink (
towards
, towardsFloat
, list
, halves
, removes
, consNub
) where
-- | Shrink an integral number by edging towards a destination.
--
-- >>> towards 0 100
-- [0,50,75,88,94,97,99]
--
-- >>> towards 500 1000
-- [500,750,875,938,969,985,993,997,999]
--
-- >>> towards (-50) (-26)
-- [-50,-38,-32,-29,-27]
--
-- /Note we always try the destination first, as that is the optimal shrink./
--
towards :: Integral a => a -> a -> [a]
towards destination x =
if destination == x then
[]
else
let
-- Halve the operands before subtracting them so they don't overflow.
-- Consider 'minBound' and 'maxBound' for a fixed sized type like 'Int64'.
diff =
(x `quot` 2) - (destination `quot` 2)
in
destination `consNub` fmap (x -) (halves diff)
-- | Shrink a floating-point number by edging towards a destination.
--
-- >>> take 7 (towardsFloat 0.0 100)
-- [0.0,50.0,75.0,87.5,93.75,96.875,98.4375]
--
-- >>> take 7 (towardsFloat 1.0 0.5)
-- [1.0,0.75,0.625,0.5625,0.53125,0.515625,0.5078125]
--
-- /Note we always try the destination first, as that is the optimal shrink./
--
towardsFloat :: RealFloat a => a -> a -> [a]
towardsFloat destination x =
if destination == x then
[]
else
let
diff =
x - destination
ok y =
y /= x && not (isNaN y) && not (isInfinite y)
in
takeWhile ok .
fmap (x -) $
iterate (/ 2) diff
-- | Shrink a list by edging towards the empty list.
--
-- >>> list [1,2,3]
-- [[],[2,3],[1,3],[1,2]]
--
-- >>> list "abcd"
-- ["","cd","ab","bcd","acd","abd","abc"]
--
-- /Note we always try the empty list first, as that is the optimal shrink./
--
list :: [a] -> [[a]]
list xs =
concatMap
(\k -> removes k xs)
(halves $ length xs)
-- | Produce all permutations of removing 'k' elements from a list.
--
-- >>> removes 2 "abcdef"
-- ["cdef","abef","abcd"]
--
removes :: Int -> [a] -> [[a]]
removes k0 xs0 =
let
loop k n xs =
let
(hd, tl) =
splitAt k xs
in
if k > n then
[]
else if null tl then
[[]]
else
tl : fmap (hd ++) (loop k (n - k) tl)
in
loop k0 (length xs0) xs0
-- | Produce a list containing the progressive halving of an integral.
--
-- >>> halves 15
-- [15,7,3,1]
--
-- >>> halves 100
-- [100,50,25,12,6,3,1]
--
-- >>> halves (-26)
-- [-26,-13,-6,-3,-1]
--
halves :: Integral a => a -> [a]
halves =
takeWhile (/= 0) . iterate (`quot` 2)
-- | Cons an element on to the front of a list unless it is already there.
--
consNub :: Eq a => a -> [a] -> [a]
consNub x ys0 =
case ys0 of
[] ->
x : []
y : ys ->
if x == y then
y : ys
else
x : y : ys
hedgehog-0.6.1/src/Hedgehog/Internal/Exception.hs 0000644 0000000 0000000 00000001247 13351371600 020030 0 ustar 00 0000000 0000000 {-# OPTIONS_HADDOCK not-home #-}
module Hedgehog.Internal.Exception (
tryAll
, tryEvaluate
) where
import Control.Exception (Exception(..), AsyncException, SomeException(..), evaluate)
import Control.Monad.Catch (MonadCatch(..), throwM)
import System.IO.Unsafe (unsafePerformIO)
tryAll :: MonadCatch m => m a -> m (Either SomeException a)
tryAll m =
catch (fmap Right m) $ \exception ->
case fromException exception :: Maybe AsyncException of
Nothing ->
pure $ Left exception
Just async ->
throwM async
tryEvaluate :: a -> Either SomeException a
tryEvaluate x =
unsafePerformIO (tryAll (evaluate x))
hedgehog-0.6.1/src/Hedgehog/Internal/Runner.hs 0000644 0000000 0000000 00000026251 13351371600 017345 0 ustar 00 0000000 0000000 {-# 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)
hedgehog-0.6.1/src/Hedgehog/Internal/Tree.hs 0000644 0000000 0000000 00000022075 13351371600 016773 0 ustar 00 0000000 0000000 {-# 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
hedgehog-0.6.1/src/Hedgehog/Internal/Show.hs 0000644 0000000 0000000 00000014011 13351371600 017003 0 ustar 00 0000000 0000000 {-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}
module Hedgehog.Internal.Show (
Name
, Value(..)
, ValueDiff(..)
, LineDiff(..)
, mkValue
, showPretty
, valueDiff
, lineDiff
, toLineDiff
, renderValue
, renderValueDiff
, renderLineDiff
, takeLeft
, takeRight
) where
import Data.Bifunctor (second)
import Text.Show.Pretty (Value(..), Name, reify, valToStr, ppShow)
data ValueDiff =
ValueCon Name [ValueDiff]
| ValueRec Name [(Name, ValueDiff)]
| ValueTuple [ValueDiff]
| ValueList [ValueDiff]
| ValueSame Value
| ValueDiff Value Value
deriving (Eq, Show)
data LineDiff =
LineSame String
| LineRemoved String
| LineAdded String
deriving (Eq, Show)
data DocDiff =
DocSame Int String
| DocRemoved Int String
| DocAdded Int String
| DocOpen Int String
| DocItem Int String [DocDiff]
| DocClose Int String
deriving (Eq, Show)
renderValue :: Value -> String
renderValue =
valToStr
renderValueDiff :: ValueDiff -> String
renderValueDiff =
unlines .
fmap renderLineDiff .
toLineDiff
renderLineDiff :: LineDiff -> String
renderLineDiff = \case
LineSame x ->
" " ++ x
LineRemoved x ->
"- " ++ x
LineAdded x ->
"+ " ++ x
mkValue :: Show a => a -> Maybe Value
mkValue =
reify
showPretty :: Show a => a -> String
showPretty =
ppShow
lineDiff :: Value -> Value -> [LineDiff]
lineDiff x y =
toLineDiff $ valueDiff x y
toLineDiff :: ValueDiff -> [LineDiff]
toLineDiff =
concatMap (mkLineDiff 0 "") .
collapseOpen .
dropLeadingSep .
mkDocDiff 0
valueDiff :: Value -> Value -> ValueDiff
valueDiff x y =
if x == y then
ValueSame x
else
case (x, y) of
(Con nx xs, Con ny ys)
| nx == ny
, length xs == length ys
->
ValueCon nx (zipWith valueDiff xs ys)
(Rec nx nxs, Rec ny nys)
| nx == ny
, fmap fst nxs == fmap fst nys
, ns <- fmap fst nxs
, xs <- fmap snd nxs
, ys <- fmap snd nys
->
ValueRec nx (zip ns (zipWith valueDiff xs ys))
(Tuple xs, Tuple ys)
| length xs == length ys
->
ValueTuple (zipWith valueDiff xs ys)
(List xs, List ys)
| length xs == length ys
->
ValueList (zipWith valueDiff xs ys)
_ ->
ValueDiff x y
takeLeft :: ValueDiff -> Value
takeLeft = \case
ValueCon n xs ->
Con n (fmap takeLeft xs)
ValueRec n nxs ->
Rec n (fmap (second takeLeft) nxs)
ValueTuple xs ->
Tuple (fmap takeLeft xs)
ValueList xs ->
List (fmap takeLeft xs)
ValueSame x ->
x
ValueDiff x _ ->
x
takeRight :: ValueDiff -> Value
takeRight = \case
ValueCon n xs ->
Con n (fmap takeRight xs)
ValueRec n nxs ->
Rec n (fmap (second takeRight) nxs)
ValueTuple xs ->
Tuple (fmap takeRight xs)
ValueList xs ->
List (fmap takeRight xs)
ValueSame x ->
x
ValueDiff _ x ->
x
mkLineDiff :: Int -> String -> DocDiff -> [LineDiff]
mkLineDiff indent0 prefix0 diff =
let
mkLinePrefix indent =
spaces indent0 ++ prefix0 ++ spaces indent
mkLineIndent indent =
indent0 + length prefix0 + indent
in
case diff of
DocSame indent x ->
[LineSame $ mkLinePrefix indent ++ x]
DocRemoved indent x ->
[LineRemoved $ mkLinePrefix indent ++ x]
DocAdded indent x ->
[LineAdded $ mkLinePrefix indent ++ x]
DocOpen indent x ->
[LineSame $ mkLinePrefix indent ++ x]
DocItem _ _ [] ->
[]
DocItem indent prefix (x@DocRemoved{} : y@DocAdded{} : xs) ->
mkLineDiff (mkLineIndent indent) prefix x ++
mkLineDiff (mkLineIndent indent) prefix y ++
concatMap (mkLineDiff (mkLineIndent (indent + length prefix)) "") xs
DocItem indent prefix (x : xs) ->
mkLineDiff (mkLineIndent indent) prefix x ++
concatMap (mkLineDiff (mkLineIndent (indent + length prefix)) "") xs
DocClose indent x ->
[LineSame $ spaces (mkLineIndent indent) ++ x]
spaces :: Int -> String
spaces indent =
replicate indent ' '
collapseOpen :: [DocDiff] -> [DocDiff]
collapseOpen = \case
DocSame indent line : DocOpen _ bra : xs ->
DocSame indent (line ++ " " ++ bra) : collapseOpen xs
DocItem indent prefix xs : ys ->
DocItem indent prefix (collapseOpen xs) : collapseOpen ys
x : xs ->
x : collapseOpen xs
[] ->
[]
dropLeadingSep :: [DocDiff] -> [DocDiff]
dropLeadingSep = \case
DocOpen oindent bra : DocItem indent prefix xs : ys ->
DocOpen oindent bra : DocItem (indent + length prefix) "" (dropLeadingSep xs) : dropLeadingSep ys
DocItem indent prefix xs : ys ->
DocItem indent prefix (dropLeadingSep xs) : dropLeadingSep ys
x : xs ->
x : dropLeadingSep xs
[] ->
[]
mkDocDiff :: Int -> ValueDiff -> [DocDiff]
mkDocDiff indent = \case
ValueSame x ->
same indent (renderValue x)
diff
| x <- takeLeft diff
, y <- takeRight diff
, oneLiner x
, oneLiner y
->
removed indent (renderValue x) ++
added indent (renderValue y)
ValueCon n xs ->
same indent n ++
concatMap (mkDocDiff (indent + 2)) xs
ValueRec n nxs ->
same indent n ++
[DocOpen indent "{"] ++
fmap (\(name, x) -> DocItem (indent + 2) ", " (same 0 (name ++ " =") ++ mkDocDiff 2 x)) nxs ++
[DocClose (indent + 2) "}"]
ValueTuple xs ->
[DocOpen indent "("] ++
fmap (DocItem indent ", " . mkDocDiff 0) xs ++
[DocClose indent ")"]
ValueList xs ->
[DocOpen indent "["] ++
fmap (DocItem indent ", " . mkDocDiff 0) xs ++
[DocClose indent "]"]
ValueDiff x y ->
removed indent (renderValue x) ++
added indent (renderValue y)
oneLiner :: Value -> Bool
oneLiner x =
case lines (renderValue x) of
_ : _ : _ ->
False
_ ->
True
same :: Int -> String -> [DocDiff]
same indent =
fmap (DocSame indent) . lines
removed :: Int -> String -> [DocDiff]
removed indent =
fmap (DocRemoved indent) . lines
added :: Int -> String -> [DocDiff]
added indent =
fmap (DocAdded indent) . lines
hedgehog-0.6.1/src/Hedgehog/Internal/Queue.hs 0000644 0000000 0000000 00000005665 13351371600 017166 0 ustar 00 0000000 0000000 {-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
module Hedgehog.Internal.Queue (
TaskIndex(..)
, TasksRemaining(..)
, runTasks
, finalizeTask
, runActiveFinalizers
, dequeueMVar
, updateNumCapabilities
) where
import Control.Concurrent (rtsSupportsBoundThreads)
import Control.Concurrent.Async (forConcurrently)
import Control.Concurrent.MVar (MVar)
import qualified Control.Concurrent.MVar as MVar
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified GHC.Conc as Conc
import Hedgehog.Internal.Config
newtype TaskIndex =
TaskIndex Int
deriving (Eq, Ord, Enum, Num)
newtype TasksRemaining =
TasksRemaining Int
dequeueMVar ::
MVar [(TaskIndex, a)]
-> (TasksRemaining -> TaskIndex -> a -> IO b)
-> IO (Maybe (TaskIndex, b))
dequeueMVar mvar start =
MVar.modifyMVar mvar $ \case
[] ->
pure ([], Nothing)
(ix, x) : xs -> do
y <- start (TasksRemaining $ length xs) ix x
pure (xs, Just (ix, y))
runTasks ::
WorkerCount
-> [a]
-> (TasksRemaining -> TaskIndex -> a -> IO b)
-> (b -> IO ())
-> (b -> IO ())
-> (b -> IO c)
-> IO [c]
runTasks n tasks start finish finalize runTask = do
qvar <- MVar.newMVar (zip [0..] tasks)
fvar <- MVar.newMVar (-1, Map.empty)
let
worker rs = do
mx <- dequeueMVar qvar start
case mx of
Nothing ->
pure rs
Just (ix, x) -> do
r <- runTask x
finish x
finalizeTask fvar ix (finalize x)
worker (r : rs)
-- FIXME ensure all workers have finished running
fmap concat . forConcurrently [1..max 1 n] $ \_ix ->
worker []
runActiveFinalizers ::
MonadIO m
=> MVar (TaskIndex, Map TaskIndex (IO ()))
-> m ()
runActiveFinalizers mvar =
liftIO $ do
again <-
MVar.modifyMVar mvar $ \original@(minIx, finalizers0) ->
case Map.minViewWithKey finalizers0 of
Nothing ->
pure (original, False)
Just ((ix, finalize), finalizers) ->
if ix == minIx + 1 then do
finalize
pure ((ix, finalizers), True)
else
pure (original, False)
when again $
runActiveFinalizers mvar
finalizeTask ::
MonadIO m
=> MVar (TaskIndex, Map TaskIndex (IO ()))
-> TaskIndex
-> IO ()
-> m ()
finalizeTask mvar ix finalize = do
liftIO . MVar.modifyMVar_ mvar $ \(minIx, finalizers) ->
pure (minIx, Map.insert ix finalize finalizers)
runActiveFinalizers mvar
-- | Update the number of capabilities but never set it lower than it already
-- is.
--
updateNumCapabilities :: WorkerCount -> IO ()
updateNumCapabilities (WorkerCount n) = when rtsSupportsBoundThreads $ do
ncaps <- Conc.getNumCapabilities
Conc.setNumCapabilities (max n ncaps)
hedgehog-0.6.1/src/Hedgehog/Internal/TH.hs 0000644 0000000 0000000 00000003067 13351371600 016407 0 ustar 00 0000000 0000000 {-# 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
hedgehog-0.6.1/src/Hedgehog/Internal/Opaque.hs 0000644 0000000 0000000 00000001060 13351371600 017315 0 ustar 00 0000000 0000000 {-# OPTIONS_HADDOCK not-home #-}
module Hedgehog.Internal.Opaque (
Opaque(..)
) where
-- | Opaque values.
--
-- Useful if you want to put something without a 'Show' instance inside
-- something which you'd like to be able to display.
--
-- For example:
--
-- @
-- data State v =
-- State {
-- stateRefs :: [Var (Opaque (IORef Int)) v]
-- } deriving (Eq, Show)
-- @
--
newtype Opaque a =
Opaque {
unOpaque :: a
} deriving (Eq, Ord)
instance Show (Opaque a) where
showsPrec _ (Opaque _) =
showString "Opaque"
hedgehog-0.6.1/src/Hedgehog/Internal/Range.hs 0000644 0000000 0000000 00000025764 13351371600 017140 0 ustar 00 0000000 0000000 {-# 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.
hedgehog-0.6.1/src/Hedgehog/Internal/Region.hs 0000644 0000000 0000000 00000005621 13351371600 017315 0 ustar 00 0000000 0000000 {-# 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 ()