hedgehog 0.6.1 → 1.0

raw patch · 22 files changed

+2472/−967 lines, 22 filesdep +faildep −th-liftdep −unixdep ~basedep ~primitivedep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: fail

Dependencies removed: th-lift, unix

Dependency ranges changed: base, primitive, transformers, transformers-base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +93/−23
• README.md +26/−8
• hedgehog.cabal +32/−28
• src/Hedgehog.hs +15/−4
• src/Hedgehog/Gen.hs +1/−4
• src/Hedgehog/Internal/Config.hs +7/−22
• src/Hedgehog/Internal/Discovery.hs +6/−10
• src/Hedgehog/Internal/Distributive.hs +255/−25
• src/Hedgehog/Internal/Gen.hs +377/−364
• src/Hedgehog/Internal/Property.hs +372/−70
• src/Hedgehog/Internal/Report.hs +364/−84
• src/Hedgehog/Internal/Runner.hs +60/−34
• src/Hedgehog/Internal/Source.hs +1/−26
• src/Hedgehog/Internal/State.hs +105/−71
• src/Hedgehog/Internal/TH.hs +6/−2
• src/Hedgehog/Internal/Tree.hs +450/−176
• src/Hedgehog/Internal/Tripping.hs +16/−4
• src/Hedgehog/Main.hs +20/−0
• test/Test/Hedgehog/Applicative.hs +97/−0
• test/Test/Hedgehog/Filter.hs +97/−0
• test/Test/Hedgehog/Zip.hs +62/−0
• test/test.hs +10/−12

@@ -1,6 +1,28 @@+## Version 1.0 (2019-05-13)+- Add histograms to labels / coverage ([#289][289], [@jacobstanley][jacobstanley])+- Improved shrinking of lists ([#276][276], [@jacobstanley][jacobstanley] / [@edsko][edsko])+- Simplify `MonadGen`, this breaks the use of `StateT` on the outside of a `GenT` for the time being, it still works fine on the inside though and you can use `distributeT` to run it ([#276][276], [@jacobstanley][jacobstanley])+- Change `Applicative` `GenT` to use zipping ([#272][272], [@jacobstanley][jacobstanley] / [@edsko][edsko])+- Rename `Tree` -> `TreeT`, `Node` -> `NodeT` ([#272][272], [@jacobstanley][jacobstanley])+- `diff` function which takes any `a -> a -> Bool` comparison function ([#196][196], [@chessai][chessai] / [@jacobstanley][jacobstanley])+- Labelling of test runs via `label`, `collect` ([#262][262], [@ruhatch][ruhatch] / [@jacobstanley][jacobstanley])+- Classification of test runs via `cover`, `classify` ([#253][253], [@felixmulder][felixmulder] / [@jacobstanley][jacobstanley])+- Define proper `Applicative` instances for `NodeT`, `TreeT` and `GenT` ([#173][173][@sjakobi][sjakobi]+- `MonadFail` instance for `PropertyT` ([#267][267], [@geigerzaehler][geigerzaehler])+- `MonadResource` instance for `PropertyT` ([#268][268], [@geigerzaehler][geigerzaehler])+- Example for the `tripping` function ([#258][258], [@HuwCampbell][HuwCampbell])+- Improve documentation for state machine testing ([#252][252], [@endgame][endgame])+- `runTests` function for running tests from a top level executable, this was later renamed to `defaultMain` as is the de facto convention ([#168][168], [@erikd][erikd])+- Show output variables when parallel state machine testing fails to linearise ([#235][235], [@HuwCampbell][HuwCampbell])+- Note about `enumBounded` danger ([#202][202], [@thumphries][thumphries])+- Expose `discoverPrefix` to find prefixed properties ([#229][229], [@ruhatch][ruhatch])+- Remove use of `unix` package and replace with `lookupEnv` ([#226][226], [@puffnfresh][puffnfresh])+ ## Version 0.6.1 (2018-09-22) -- Set stdout/stderr encoding to UTF-8 on Windows ([#218][218], [@moodmosaic][moodmosaic])+- Fix UTF-8 related rendering bugs on Windows ([#218][218], [@moodmosaic][moodmosaic])+- Verify that our SplitMix/Seed avoids pathological γ-values ([#207][207], [@moodmosaic][moodmosaic])+- Avoid weak gamma values in Hedgehog.Internal.Seed ([#198][198], [@moodmosaic][moodmosaic])  ## Version 0.6 (2018-05-14) @@ -28,29 +50,29 @@  ## 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])+- Parallel state machine testing, allows detection of commands which are not-atomic ([#98][98], [@jacobstanley][jacobstanley])+- Easier to use variables for state machine testing ([#94][94], [@jacobstanley][jacobstanley])+- `MonadGen` class allows the use of transformers like `ReaderT` and `StateT` on the outside of generators ([#99][99], [@jacobstanley][jacobstanley])+- Better error messages for tests which throw exceptions ([#95][95], [@jacobstanley][jacobstanley])+- Separated test input generation and assertions in to `PropertyT` and `TestT` respectively, this allows `TestT` to have a `MonadBaseControl` instance ([#96][96], [@jacobstanley][jacobstanley]) - This document grew links to the pull requests which introduced various changes ([#93][93], [@moodmosaic][moodmosaic])  ## Version 0.4.1 (2017-06-28) -- Fixed runtime type error that could occur when shrinking state machine commands ([#91][91], [@jystic][jystic])+- Fixed runtime type error that could occur when shrinking state machine commands ([#91][91], [@jacobstanley][jacobstanley])  ## Version 0.4 (2017-06-28) -- Abstract state machine testing, check out Tim Humphries' great [blog post](http://teh.id.au/posts/2017/07/15/state-machine-testing) or the [process registry example](https://github.com/hedgehogqa/haskell-hedgehog/blob/master/hedgehog-example/test/Test/Example/Registry.hs) to see how it works ([#89][89], [@jystic][jystic])-- `liftCatch`, `liftCatchIO`, `withCatch` functions for isolating exceptions during tests ([#89][89], [@jystic][jystic])+- Abstract state machine testing, check out Tim Humphries' great [blog post](http://teh.id.au/posts/2017/07/15/state-machine-testing) or the [process registry example](https://github.com/hedgehogqa/haskell-hedgehog/blob/master/hedgehog-example/test/Test/Example/Registry.hs) to see how it works ([#89][89], [@jacobstanley][jacobstanley])+- `liftCatch`, `liftCatchIO`, `withCatch` functions for isolating exceptions during tests ([#89][89], [@jacobstanley][jacobstanley])  ## Version 0.3 (2017-06-11)  - Exponential range combinators ([#43][43], [@chris-martin][chris-martin]) - Roundtrip example, check out the [blog post](http://teh.id.au/posts/2017/06/07/round-trip-property/) ([#85][85], [@thumphries][thumphries])-- `tripping` now displays intermediate value ([#85][85], [@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])+- `tripping` now displays intermediate value ([#85][85], [@jacobstanley][jacobstanley])+- `distribute` function for pulling a transformer out to the top level ([#83][83], [@jacobstanley][jacobstanley])+- `withExceptT` function for executing tests with an inner `ExceptT` (e.g. `Test (ExceptT x m) a`) ([#83][83], [@jacobstanley][jacobstanley])  ## Version 0.2.2 (2017-05-16) @@ -61,24 +83,24 @@  ## Version 0.2.1 (2017-05-09) -- Added `ascii`, `latin1`, `unicode` character generators ([#73][73], [@jystic][jystic])+- Added `ascii`, `latin1`, `unicode` character generators ([#73][73], [@jacobstanley][jacobstanley])  ## Version 0.2 (2017-05-06) -- Added a quiet test runner which can be activated by setting `HEDGEHOG_VERBOSITY=0` ([@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])+- Added a quiet test runner which can be activated by setting `HEDGEHOG_VERBOSITY=0` ([@jacobstanley][jacobstanley])+- Concurrent test runner does not display tests until they are executing ([@jacobstanley][jacobstanley])+- Test runner now outputs a summary of how many successful / failed tests were run ([@jacobstanley][jacobstanley])+- `checkSequential` and `checkParallel` now allow for tests to be run without Template Haskell ([@jacobstanley][jacobstanley])+- Auto-discovery of properties is now available via `discover` instead of being baked in ([@jacobstanley][jacobstanley])+- `annotate` allows source code to be annotated inline with extra information ([@jacobstanley][jacobstanley])+- `forAllWith` can be used to generate values without a `Show` instance ([@jacobstanley][jacobstanley])+- Removed uses of `Typeable` to allow for generating types which cannot implement it ([@jacobstanley][jacobstanley])  [Dieharder]:   https://webhome.phy.duke.edu/~rgb/General/dieharder.php -[jystic]:-  https://github.com/jystic+[jacobstanley]:+  https://github.com/jacobstanley [chris-martin]:   https://github.com/chris-martin [thumphries]:@@ -105,11 +127,59 @@   https://github.com/dredozubov [fisx]:   https://github.com/fisx+[puffnfresh]:+  https://github.com/puffnfresh+[ruhatch]:+  https://github.com/ruhatch+[HuwCampbell]:+  https://github.com/HuwCampbell+[endgame]:+  https://github.com/endgame+[geigerzaehler]:+  https://github.com/geigerzaehler+[sjakobi]:+  https://github.com/sjakobi+[felixmulder]:+  https://github.com/felixmulder+[edsko]:+  https://github.com/edsko +[289]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/289+[276]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/276+[272]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/272+[268]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/268+[262]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/262+[258]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/258+[253]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/253+[252]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/252+[235]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/235+[229]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/229+[226]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/226+[218]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/218+[207]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/207+[202]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/202+[198]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/198 [185]:   https://github.com/hedgehogqa/haskell-hedgehog/pull/185 [184]:   https://github.com/hedgehogqa/haskell-hedgehog/pull/184+[168]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/168 [162]:   https://github.com/hedgehogqa/haskell-hedgehog/pull/162 [157]:

@@ -1,14 +1,24 @@-hedgehog [![Hackage][hackage-shield]][hackage] [![Travis][travis-shield]][travis]-========+<!--+Apologies to those who are able to read this. Unfortunately, Hackage+doesn't seem to render the HTML portion of the markdown spec so you may+be better off paying us a visit on GitHub instead:+https://github.com/hedgehogqa/haskell-hedgehog+--> -> Hedgehog will eat all your bugs.+<div align="center"> -<img src="https://github.com/hedgehogqa/haskell-hedgehog/raw/master/img/hedgehog-logo.png" width="307" align="right"/>+<img width="400" src="https://github.com/hedgehogqa/haskell-hedgehog/raw/master/img/hedgehog-text-logo.png" /> -[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.+# Release with confidence. +[![Hackage][hackage-shield]][hackage] [![Travis][travis-shield]][travis] [![AppVeyor][appveyor-shield]][appveyor]++<div align="left">++[Hedgehog](http://hedgehog.qa/) automatically generates a comprehensive array of test cases, exercising your software in ways human testers would never imagine.++Generate hundreds of test cases automatically, exposing even the most insidious of corner cases. Failures are automatically simplified, giving developers coherent, intelligible error messages.+ ## Features  - Integrated shrinking, shrinks obey invariants by construction.@@ -28,6 +38,7 @@ qualified. You also need to enable Template Haskell so the Hedgehog test runner can find your properties. + ```hs {-# LANGUAGE TemplateHaskell #-} @@ -76,11 +87,18 @@  ``` +<div align="center">+<br />+<img width="307" src="https://github.com/hedgehogqa/haskell-hedgehog/raw/master/img/hedgehog-logo-grey.png" />+  [hackage]: http://hackage.haskell.org/package/hedgehog- [hackage-shield]: https://img.shields.io/badge/hackage-v0.5-blue.svg+ [hackage-shield]: https://img.shields.io/badge/hackage-v1.0-blue.svg   [travis]: https://travis-ci.org/hedgehogqa/haskell-hedgehog  [travis-shield]: https://travis-ci.org/hedgehogqa/haskell-hedgehog.svg?branch=master++ [appveyor]: https://ci.appveyor.com/project/hedgehogqa/haskell-hedgehog+ [appveyor-shield]: https://ci.appveyor.com/api/projects/status/o4rlstbc80sum3on/branch/master?svg=true   [haddock-hedgehog]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog.html  [haddock-hedgehog-gen]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog-Gen.html

@@ -1,4 +1,4 @@-version: 0.6.1+version: 1.0  name:   hedgehog@@ -11,14 +11,17 @@ bug-reports:   https://github.com/hedgehogqa/haskell-hedgehog/issues synopsis:-  Hedgehog will eat all your bugs.+  Release with confidence. 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.+  <http://hedgehog.qa/ Hedgehog> automatically generates a comprehensive array+  of test cases, exercising your software in ways human testers would never+  imagine.   .-  To get started quickly, see the examples:-  <https://github.com/hedgehogqa/haskell-hedgehog/tree/master/hedgehog-example>+  Generate hundreds of test cases automatically, exposing even the+  most insidious of corner cases. Failures are automatically simplified, giving+  developers coherent, intelligible error messages.+  .+  To get started quickly, see the <https://github.com/hedgehogqa/haskell-hedgehog/tree/master/hedgehog-example examples>. category:   Testing license:@@ -30,15 +33,10 @@ 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.0.2   , GHC == 8.2.2-  , GHC == 8.4.1-  , GHC == 8.4.2-  , GHC == 8.4.3+  , GHC == 8.4.4+  , GHC == 8.6.4 extra-source-files:   README.md   CHANGELOG.md@@ -49,45 +47,46 @@  library   build-depends:-      base                            >= 3          && < 5-    , ansi-terminal                   >= 0.6        && < 0.9+   -- GHC 8.0.1 / base-4.9.0.0 (May 2016)+      base                            >= 4.9        && < 5+    , ansi-terminal                   >= 0.6        && < 0.10     , 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+    , fail                            >= 4.9        && < 5     , lifted-async                    >= 0.7        && < 0.11     , mmorph                          >= 1.0        && < 1.2     , monad-control                   >= 1.0        && < 1.1     , mtl                             >= 2.1        && < 2.3-    , pretty-show                     >= 1.6        && < 1.8+    , pretty-show                     >= 1.6        && < 1.10     , 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+    , stm                             >= 2.4        && < 2.6+    , template-haskell                >= 2.10       && < 2.15     , 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+    , transformers                    >= 0.5        && < 0.6+    , transformers-base               >= 0.4.5.1    && < 0.5     , wl-pprint-annotated             >= 0.0        && < 0.2 -  if !os(windows)-    build-depends:-      unix                            >= 2.6        && < 2.8-   ghc-options:     -Wall +  if impl(ghc >= 8.0)+    ghc-options: -Wnoncanonical-monad-instances+   hs-source-dirs:     src    exposed-modules:     Hedgehog     Hedgehog.Gen+    Hedgehog.Main     Hedgehog.Range      Hedgehog.Internal.Config@@ -126,14 +125,19 @@     test    other-modules:+    Test.Hedgehog.Applicative+    Test.Hedgehog.Filter     Test.Hedgehog.Seed     Test.Hedgehog.Text+    Test.Hedgehog.Zip    build-depends:       hedgehog     , base                            >= 3          && < 5     , containers                      >= 0.4        && < 0.7-    , pretty-show                     >= 1.6        && < 1.8+    , mmorph                          >= 1.0        && < 1.2+    , mtl                             >= 2.1        && < 2.3+    , pretty-show                     >= 1.6        && < 1.10     , semigroups                      >= 0.16       && < 0.19     , text                            >= 1.1        && < 1.3     , transformers                    >= 0.3        && < 0.6

@@ -62,6 +62,7 @@   , recheck    , discover+  , discoverPrefix   , checkParallel   , checkSequential @@ -97,6 +98,7 @@   , success   , failure   , assert+  , diff   , (===)   , (/==)   , tripping@@ -107,6 +109,12 @@   , evalEither   , evalExceptT +  -- * Coverage+  , classify+  , cover+  , label+  , collect+   -- * State Machine Tests   , Command(..)   , Callback(..)@@ -125,7 +133,7 @@   , Opaque(..)    -- * Transformers-  , distribute+  , distributeT    -- * Functors   , HTraversable(..)@@ -142,12 +150,13 @@  import           Data.Functor.Classes (Eq1, eq1, Ord1, compare1, Show1, showsPrec1) -import           Hedgehog.Internal.Distributive (Distributive(..))+import           Hedgehog.Internal.Distributive (distributeT) import           Hedgehog.Internal.Gen (Gen, GenT, MonadGen(..)) import           Hedgehog.Internal.HTraversable (HTraversable(..)) import           Hedgehog.Internal.Opaque (Opaque(..)) import           Hedgehog.Internal.Property (annotate, annotateShow)-import           Hedgehog.Internal.Property (assert, (===), (/==))+import           Hedgehog.Internal.Property (assert, diff, (===), (/==))+import           Hedgehog.Internal.Property (classify, cover) import           Hedgehog.Internal.Property (discard, failure, success) import           Hedgehog.Internal.Property (DiscardLimit, withDiscards) import           Hedgehog.Internal.Property (eval, evalM, evalIO)@@ -161,12 +170,14 @@ import           Hedgehog.Internal.Property (ShrinkRetries, withRetries) import           Hedgehog.Internal.Property (Test, TestT, property, test) import           Hedgehog.Internal.Property (TestLimit, withTests)+import           Hedgehog.Internal.Property (collect, label) import           Hedgehog.Internal.Range (Range, Size(..)) import           Hedgehog.Internal.Runner (check, recheck, checkSequential, checkParallel)+ import           Hedgehog.Internal.Seed (Seed(..)) import           Hedgehog.Internal.State (Command(..), Callback(..)) import           Hedgehog.Internal.State (Action, Sequential(..), Parallel(..)) import           Hedgehog.Internal.State (executeSequential, executeParallel) import           Hedgehog.Internal.State (Var(..), Symbolic, Concrete(..), concrete, opaque)-import           Hedgehog.Internal.TH (discover)+import           Hedgehog.Internal.TH (discover, discoverPrefix) import           Hedgehog.Internal.Tripping (tripping)

@@ -1,9 +1,6 @@ module Hedgehog.Gen (-  -- * Combinators-    lift-   -- ** Shrinking-  , shrink+    shrink   , prune    -- ** Size

@@ -1,5 +1,5 @@ {-# OPTIONS_HADDOCK not-home #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveLift #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}@@ -25,16 +25,12 @@  import qualified GHC.Conc as Conc -import           Language.Haskell.TH.Lift (deriveLift)+import           Language.Haskell.TH.Syntax (Lift)  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)  @@ -45,7 +41,7 @@     -- ^ Disable ANSI colors in report output.   | EnableColor     -- ^ Enable ANSI colors in report output.-    deriving (Eq, Ord, Show)+    deriving (Eq, Ord, Show, Lift)  -- | How verbose should the report output be. --@@ -54,22 +50,18 @@     -- ^ 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)+    deriving (Eq, Ord, Show, Lift)  -- | The number of workers to use when running properties in parallel. -- newtype WorkerCount =   WorkerCount Int-  deriving (Eq, Ord, Show, Num, Enum, Real, Integral)+  deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)  detectMark :: MonadIO m => m Bool detectMark = do-#if mingw32_HOST_OS-   pure False-#else-   user <- liftIO getEffectiveUserName-   pure $ user == "mth"-#endif+  user <- liftIO $ lookupEnv "USER"+  pure $ user == Just "mth"  lookupBool :: MonadIO m => String -> m (Maybe Bool) lookupBool key =@@ -163,10 +155,3 @@     detectWorkers   Just x ->     pure x----------------------------------------------------------------------------- FIXME Replace with DeriveLift when we drop 7.10 support.--$(deriveLift ''UseColor)-$(deriveLift ''Verbosity)-$(deriveLift ''WorkerCount)

@@ -33,9 +33,9 @@       propertySource :: Pos String     } deriving (Eq, Ord, Show) -readProperties :: MonadIO m => FilePath -> m (Map PropertyName PropertySource)-readProperties path =-  findProperties path <$> liftIO (readFile path)+readProperties :: MonadIO m => String -> FilePath -> m (Map PropertyName PropertySource)+readProperties prefix path =+  findProperties prefix path <$> liftIO (readFile path)  readDeclaration :: MonadIO m => FilePath -> LineNo -> m (Maybe (String, Pos String)) readDeclaration path line = do@@ -59,11 +59,11 @@   x : _ ->     Just x -findProperties :: FilePath -> String -> Map PropertyName PropertySource-findProperties path =+findProperties :: String -> FilePath -> String -> Map PropertyName PropertySource+findProperties prefix path =   Map.map PropertySource .   Map.mapKeysMonotonic PropertyName .-  Map.filterWithKey (\k _ -> isProperty k) .+  Map.filterWithKey (\k _ -> List.isPrefixOf prefix k) .   findDeclarations path  findDeclarations :: FilePath -> String -> Map String (Pos String)@@ -71,10 +71,6 @@   declarations .   classified .   positioned path--isProperty :: String -> Bool-isProperty =-  List.isPrefixOf "prop_"  ------------------------------------------------------------------------ -- Declaration Identification

@@ -1,54 +1,284 @@ {-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeOperators #-} module Hedgehog.Internal.Distributive (-    Distributive(..)+    MonadTransDistributive(..)+  , MonadTransJuggle(..)   ) where  import           Control.Monad (join) import           Control.Monad.Morph (MFunctor(..)) import           Control.Monad.Trans.Class (MonadTrans(..))+import           Control.Monad.Trans.Control (MonadTransControl(..))+import           Control.Monad.Trans.Identity (IdentityT(..)) import           Control.Monad.Trans.Except (ExceptT(..), runExceptT) import           Control.Monad.Trans.Maybe (MaybeT(..))+import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))+import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..)) import           Control.Monad.Trans.Reader (ReaderT(..))-import           Control.Monad.Trans.Writer (WriterT(..))+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict +import           Data.Proxy (Proxy(..))+import           Data.Bifunctor (Bifunctor(..))+ import           GHC.Exts (Constraint) +-- NOTE: Replace use of Proxy with TypeApplications when we drop 7.10 support. -class Distributive g where+------------------------------------------------------------------------+-- * MonadTransDistributive++class MonadTransDistributive g where   type Transformer     (f :: (* -> *) -> * -> *)     (g :: (* -> *) -> * -> *)     (m :: * -> *) :: Constraint    type Transformer f g m = (-        Monad m-      , Monad (f m)-      , Monad (g m)-      , Monad (f (g m))-      , MonadTrans f-      , MFunctor f-      )+      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+  distributeT :: 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 MonadTransDistributive IdentityT where+  distributeT m =+    lift . IdentityT . pure =<< hoist lift (runIdentityT m) -instance Distributive (ExceptT x) where-  distribute x =-    lift . ExceptT . pure =<< hoist lift (runExceptT x)+instance MonadTransDistributive MaybeT where+  distributeT m =+    lift . MaybeT . pure =<< hoist lift (runMaybeT m) -instance Monoid w => Distributive (WriterT w) where-  distribute x =-    lift . WriterT . pure =<< hoist lift (runWriterT x)+instance MonadTransDistributive (ExceptT x) where+  distributeT m =+    lift . ExceptT . pure =<< hoist lift (runExceptT m) -instance Distributive (ReaderT r) where-  distribute x =+instance MonadTransDistributive (ReaderT r) where+  distributeT m =     join . lift . ReaderT $ \r ->-      pure . hoist lift $ runReaderT x r+      pure . hoist lift $ runReaderT m r++instance Monoid w => MonadTransDistributive (Lazy.WriterT w) where+  distributeT m =+    lift . Lazy.WriterT . pure =<< hoist lift (Lazy.runWriterT m)++instance Monoid w => MonadTransDistributive (Strict.WriterT w) where+  distributeT m = do+    lift . Strict.WriterT . pure =<< hoist lift (Strict.runWriterT m)++instance MonadTransDistributive (Lazy.StateT s) where+  type Transformer f (Lazy.StateT s) m = (+      Monad m+    , Monad (f m)+    , Monad (Lazy.StateT s m)+    , Monad (f (Lazy.StateT s m))+    , MonadTrans f+    , MonadTransControl f+    , MonadTransJuggle f+    , MFunctor f+    )++  distributeT :: forall f m a.+       Transformer f (Lazy.StateT s) m+    => Lazy.StateT s (f m) a+    -> f (Lazy.StateT s m) a+  distributeT m =+    join $ liftWith $ \run ->+      let+        restoreStateT :: s -> StT f (a, s) -> (f (Lazy.StateT s m) a, s)+        restoreStateT s = do+          first (restoreT . pure) . juggleState @f @a Proxy Proxy s+      in+        Lazy.StateT $ \s -> do+          fmap (restoreStateT s) . run $ Lazy.runStateT m s++instance MonadTransDistributive (Strict.StateT s) where+  type Transformer f (Strict.StateT s) m = (+      Monad m+    , Monad (f m)+    , Monad (Strict.StateT s m)+    , Monad (f (Strict.StateT s m))+    , MonadTrans f+    , MonadTransControl f+    , MonadTransJuggle f+    , MFunctor f+    )++  distributeT :: forall f m a.+       Transformer f (Strict.StateT s) m+    => Strict.StateT s (f m) a+    -> f (Strict.StateT s m) a+  distributeT m =+    join $ liftWith $ \run ->+      let+        restoreStateT :: s -> StT f (a, s) -> (f (Strict.StateT s m) a, s)+        restoreStateT s = do+          first (restoreT . pure) . juggleState @f @a Proxy Proxy s+      in+        Strict.StateT $ \s -> do+          fmap (restoreStateT s) . run $ Strict.runStateT m s++instance Monoid w => MonadTransDistributive (Lazy.RWST r w s) where+  type Transformer f (Lazy.RWST r w s) m = (+      Monad m+    , Monad (f m)+    , Monad (Lazy.RWST r w s m)+    , Monad (f (Lazy.RWST r w s m))+    , MonadTrans f+    , MonadTransControl f+    , MonadTransJuggle f+    , MFunctor f+    )++  distributeT :: forall f m a.+       Transformer f (Lazy.RWST r w s) m+    => Lazy.RWST r w s (f m) a+    -> f (Lazy.RWST r w s m) a+  distributeT m =+    join $ liftWith $ \run ->+      let+        restoreRWST :: s -> StT f (a, s, w) -> (f (Lazy.RWST r w s m) a, s, w)+        restoreRWST s = do+          first3 (restoreT . pure) . juggleRWS @f @w @a Proxy Proxy Proxy s+      in+        Lazy.RWST $ \r s -> do+          fmap (restoreRWST s) . run $ Lazy.runRWST m r s++instance Monoid w => MonadTransDistributive (Strict.RWST r w s) where+  type Transformer f (Strict.RWST r w s) m = (+      Monad m+    , Monad (f m)+    , Monad (Strict.RWST r w s m)+    , Monad (f (Strict.RWST r w s m))+    , MonadTrans f+    , MonadTransControl f+    , MonadTransJuggle f+    , MFunctor f+    )++  distributeT :: forall f m a.+       Transformer f (Strict.RWST r w s) m+    => Strict.RWST r w s (f m) a+    -> f (Strict.RWST r w s m) a+  distributeT m =+    join $ liftWith $ \run ->+      let+        restoreRWST :: s -> StT f (a, s, w) -> (f (Strict.RWST r w s m) a, s, w)+        restoreRWST s = do+          first3 (restoreT . pure) . juggleRWS @f @w @a Proxy Proxy Proxy s+      in+        Strict.RWST $ \r s -> do+          fmap (restoreRWST s) . run $ Strict.runRWST m r s++------------------------------------------------------------------------+-- * MonadTransJuggle++first3 :: (a -> b) -> (a, s, w) -> (b, s, w)+first3 f (a, s, w) =+  (f a, s, w)++unpack3 :: (a, s, w) -> (a, (s, w))+unpack3 (a, s, w) =+  (a, (s, w))++juggleRWS :: forall t w a s.+     (MonadTransJuggle t, Monoid w)+  => Proxy t+  -> Proxy w+  -> Proxy a+  -> s+  -> StT t (a, s, w)+  -> (StT t a, s, w)+juggleRWS _ _ _ s0 st0 =+  let+    (st, (s, w)) =+      juggleState @t @a Proxy Proxy (s0, mempty) $+        mapStT @t @(a, s, w) Proxy Proxy unpack3 st0+  in+    (st, s, w)++class MonadTransControl t => MonadTransJuggle (t :: (* -> *) -> * -> *) where+  mapStT :: Proxy t -> Proxy a -> (a -> b) -> StT t a -> StT t b+  juggleState :: Proxy t -> Proxy a -> s -> StT t (a, s) -> (StT t a, s)++instance MonadTransJuggle MaybeT where+  mapStT _ _ =+    fmap++  juggleState _ _ s0 = \case+    Nothing ->+      (Nothing, s0)+    Just (x, s) ->+      (Just x, s)++instance MonadTransJuggle (ExceptT x) where+  mapStT _ _ =+    fmap++  juggleState _ _ s0 = \case+    Left x ->+      (Left x, s0)+    Right (x, s) ->+      (Right x, s)++instance MonadTransJuggle (ReaderT r) where+  mapStT _ _ =+    id++  juggleState _ _ _ (x, s) =+    (x, s)++instance Monoid w => MonadTransJuggle (Lazy.WriterT w) where+  mapStT _ _ =+    first++  juggleState _ _ _ ((x, s), w) =+    ((x, w), s)++instance Monoid w => MonadTransJuggle (Strict.WriterT w) where+  mapStT _ _ =+    first++  juggleState _ _ _ ((x, s), w) =+    ((x, w), s)++instance MonadTransJuggle (Lazy.StateT s) where+  mapStT _ _ =+    first++  juggleState _ _ _ ((x, s0), s1) =+    ((x, s1), s0)++instance MonadTransJuggle (Strict.StateT s) where+  mapStT _ _ =+    first++  juggleState _ _ _ ((x, s0), s1) =+    ((x, s1), s0)++instance Monoid w => MonadTransJuggle (Lazy.RWST r w s) where+  mapStT _ _ =+    first3++  juggleState _ _ _ ((x, s0), s1, w) =+    ((x, s1, w), s0)++instance Monoid w => MonadTransJuggle (Strict.RWST r w s) where+  mapStT _ _ =+    first3++  juggleState _ _ _ ((x, s0), s1, w) =+    ((x, s1, w), s0)

@@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-}@@ -23,7 +24,7 @@   , MonadGen(..)    -- * Combinators-  , lift+  , generalize    -- ** Shrinking   , shrink@@ -94,7 +95,9 @@   , discard   , ensure   , filter+  , filterT   , just+  , justT    -- ** Collections   , maybe@@ -123,16 +126,24 @@   , printTree   , printWith   , printTreeWith+  , renderTree    -- * Internal   -- $internal    -- ** Transfomer   , runGenT+  , evalGen+  , evalGenT   , mapGenT   , generate-  , liftTree+  , toTree+  , toTreeMaybeT+  , fromTree+  , fromTreeT+  , fromTreeMaybeT   , runDiscardEffect+  , runDiscardEffectT    -- ** Size   , golden@@ -148,37 +159,33 @@   , Vec(..)   , Nat(..)   , subtermMVec--  -- ** Sampling-  , renderNodes   ) where  import           Control.Applicative (Alternative(..),liftA2)-import           Control.Monad (MonadPlus(..), filterM, replicateM, ap, join)+import           Control.Monad (MonadPlus(..), filterM, replicateM, join) import           Control.Monad.Base (MonadBase(..)) import           Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import           Control.Monad.Error.Class (MonadError(..))+import           Control.Monad.Fail (MonadFail (..))+import qualified Control.Monad.Fail as Fail import           Control.Monad.IO.Class (MonadIO(..))-import           Control.Monad.Morph (MFunctor(..), MMonad(..), generalize)+import           Control.Monad.Morph (MFunctor(..), MMonad(..))+import qualified Control.Monad.Morph as Morph import           Control.Monad.Primitive (PrimMonad(..)) import           Control.Monad.Reader.Class (MonadReader(..)) import           Control.Monad.State.Class (MonadState(..))-import           Control.Monad.Trans.Class (MonadTrans)-import 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.Class (MonadTrans(..))+import           Control.Monad.Trans.Except (ExceptT(..))+import           Control.Monad.Trans.Identity (IdentityT(..))+import           Control.Monad.Trans.Maybe (MaybeT(..))+import           Control.Monad.Trans.Reader (ReaderT(..)) import           Control.Monad.Trans.Resource (MonadResource(..))-import qualified Control.Monad.Trans.State.Lazy as Lazy-import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Strict as Strict import           Control.Monad.Writer.Class (MonadWriter(..))+import           Control.Monad.Zip (MonadZip(..)) -import           Data.Bifunctor (first, second)+import           Data.Bifunctor (first) import           Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.Char as Char@@ -200,11 +207,11 @@ import qualified Data.Text.Encoding as Text import           Data.Word (Word8, Word16, Word32, Word64) -import           Hedgehog.Internal.Distributive (Distributive(..))+import           Hedgehog.Internal.Distributive (MonadTransDistributive(..)) 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           Hedgehog.Internal.Tree (Tree, TreeT(..), NodeT(..)) import qualified Hedgehog.Internal.Tree as Tree import           Hedgehog.Range (Size, Range) import qualified Hedgehog.Range as Range@@ -224,18 +231,35 @@ -- newtype GenT m a =   GenT {-      unGen :: Size -> Seed -> Tree (MaybeT m) a+      unGenT :: Size -> Seed -> TreeT (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 a -> TreeT (MaybeT m) a runGenT size seed (GenT m) =   m size seed +-- | Run a generator, producing its shrink tree.+--+--   'Nothing' means discarded, 'Just' means we have a value.+--+evalGen :: Size -> Seed -> Gen a -> Maybe (Tree a)+evalGen size seed =+  fmap (fmap Maybe.fromJust) .+  Tree.filter Maybe.isJust .+  evalGenT size seed++-- | Runs a generator, producing its shrink tree.+--+evalGenT :: Monad m => Size -> Seed -> GenT m a -> TreeT m (Maybe a)+evalGenT size seed =+  runDiscardEffectT .+  runGenT size seed+ -- | Map over a generator's shrink tree. ---mapGenT :: (Tree (MaybeT m) a -> Tree (MaybeT n) b) -> GenT m a -> GenT n b+mapGenT :: (TreeT (MaybeT m) a -> TreeT (MaybeT n) b) -> GenT m a -> GenT n b mapGenT f gen =   GenT $ \size seed ->     f (runGenT size seed gen)@@ -243,308 +267,217 @@ -- | 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)+fromTree :: MonadGen m => Tree a -> m a+fromTree =+  fromTreeT .+  hoist (Morph.generalize) --- | 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.+-- | Lift a predefined shrink tree in to a generator, ignoring the seed and the+--   size. ---runDiscardEffect :: Monad m => Tree (MaybeT m) a -> Tree m (Maybe a)+fromTreeT :: MonadGen m => TreeT (GenBase m) a -> m a+fromTreeT x =+  fromTreeMaybeT $+    hoist (MaybeT . fmap Just) x++-- | Lift a predefined shrink tree in to a generator, ignoring the seed and the+--   size.+--+fromTreeMaybeT :: MonadGen m => TreeT (MaybeT (GenBase m)) a -> m a+fromTreeMaybeT x =+  fromGenT . GenT $ \_ _ ->+    x++-- | Observe a generator's shrink tree.+--+toTree :: forall m a. (MonadGen m, GenBase m ~ Identity) => m a -> m (Tree a)+toTree =+  withGenT $ mapGenT (Maybe.maybe empty pure . runDiscardEffect)++-- | Lift a predefined shrink tree in to a generator, ignoring the seed and the+--   size.+--+toTreeMaybeT :: MonadGen m => m a -> m (TreeT (MaybeT (GenBase m)) a)+toTreeMaybeT =+  withGenT $ mapGenT pure++-- | Lazily run the discard effects through the tree and reify it a+--   @Maybe (Tree a)@.+--+--   'Nothing' means discarded, 'Just' means we have a value.+--+--   Discards in the child nodes of the tree are simply removed.+--+runDiscardEffect :: TreeT (MaybeT Identity) a -> Maybe (Tree a) runDiscardEffect =-  runMaybeT . distribute+  fmap (fmap Maybe.fromJust) .+  Tree.filter Maybe.isJust .+  runDiscardEffectT +-- | Run the discard effects through the tree and reify them as 'Maybe' values+--   at the nodes.+--+--   'Nothing' means discarded, 'Just' means we have a value.+--+runDiscardEffectT :: Monad m => TreeT (MaybeT m) a -> TreeT m (Maybe a)+runDiscardEffectT =+  runMaybeT .+  distributeT++-- | Lift a @Gen / GenT Identity@ in to a @Monad m => GenT m@+--+generalize :: Monad m => Gen a -> GenT m a+generalize =+  hoist Morph.generalize+ ------------------------------------------------------------------------ -- MonadGen  -- | Class of monads which can generate input data for tests. -----   /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+class (Monad m, Monad (GenBase m)) => MonadGen m where+  type GenBase m :: (* -> *) -  -- | See @Gen.@'Hedgehog.Gen.prune'+  -- | Extract a 'GenT' from a  'MonadGen'.   ---  pruneGen :: m a -> m a+  toGenT :: m a -> GenT (GenBase m) a -  -- | See @Gen.@'Hedgehog.Gen.scale'+  -- | Lift a 'GenT' in to a 'MonadGen'.   ---  scaleGen :: (Size -> Size) -> m a -> m a+  fromGenT :: GenT (GenBase m) a -> m a -  -- | See @Gen.@'Hedgehog.Gen.freeze'-  ---  freezeGen :: m a -> m (a, m a)+-- | Transform a 'MonadGen' as a 'GenT'.+--+withGenT :: (MonadGen m, MonadGen n) => (GenT (GenBase m) a -> GenT (GenBase n) b) -> m a -> n b+withGenT f =+  fromGenT . f . toGenT  instance Monad m => MonadGen (GenT m) where-  liftGen gen =-    hoist generalize gen--  shrinkGen =-    mapGenT . Tree.expand--  pruneGen =-    mapGenT Tree.prune+  -- | The type of the transformer stack's base 'Monad'.+  --+  type GenBase (GenT m) =+    m -  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+  -- | Convert a 'MonadGen' to a 'GenT'.+  --+  toGenT =+    id -  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)+  -- | Convert a 'GenT' to a 'MonadGen'.+  --+  fromGenT =+    id  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)+  type GenBase (IdentityT m) =+    IdentityT (GenBase m) -shrink2 :: (a -> [a]) -> (a, b) -> [(a, b)]-shrink2 f (x, y) =-  fmap (, y) (f x)+  toGenT =+    distributeT . hoist toGenT -shrink3 :: (a -> [a]) -> (a, b, c) -> [(a, b, c)]-shrink3 f (x, y, z) =-  fmap (, y, z) (f x)+  fromGenT =+    hoist fromGenT . distributeT  instance MonadGen m => MonadGen (MaybeT m) where-  liftGen =-    Trans.lift . liftGen--  shrinkGen f =-    mapMaybeT $-      shrink (shrinkMaybe f)--  pruneGen =-    hoist prune+  type GenBase (MaybeT m) =+    MaybeT (GenBase m) -  scaleGen f =-    hoist (scale f)+  toGenT =+    distributeT . hoist toGenT -  freezeGen =-    mapMaybeT $ \m0 -> do-      (mx, m) <- freeze m0-      pure $ fmap (, MaybeT m) mx+  fromGenT =+    hoist fromGenT . distributeT  instance MonadGen m => MonadGen (ExceptT x m) where-  liftGen =-    Trans.lift . liftGen--  shrinkGen f =-    mapExceptT $-      shrink (shrinkEither f)--  pruneGen =-    hoist prune+  type GenBase (ExceptT x m) =+    ExceptT x (GenBase m) -  scaleGen f =-    hoist (scale f)+  toGenT =+    distributeT . hoist toGenT -  freezeGen =-    mapExceptT $ \m0 -> do-      (mx, m) <- freeze m0-      pure $ fmap (, ExceptT m) mx+  fromGenT =+    hoist fromGenT . distributeT  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+  type GenBase (ReaderT r m) =+    ReaderT r (GenBase m) -  scaleGen f =-    hoist (scale f)+  toGenT =+    distributeT . hoist toGenT -  freezeGen m0 =-    Strict.StateT $ \s0 -> do-      ((x, s), m) <- freeze (Strict.runStateT m0 s0)-      pure ((x, Strict.StateT (const m)), s)+  fromGenT =+    hoist fromGenT . distributeT  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+  type GenBase (Lazy.WriterT w m) =+    Lazy.WriterT w (GenBase m) -  scaleGen f =-    hoist (scale f)+  toGenT =+    distributeT . hoist toGenT -  freezeGen m0 =-    Lazy.WriterT $ do-      ((x, w), m) <- freeze (Lazy.runWriterT m0)-      pure ((x, Lazy.WriterT m), w)+  fromGenT =+    hoist fromGenT . distributeT  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+  type GenBase (Strict.WriterT w m) =+    Strict.WriterT w (GenBase m) -  scaleGen f =-    hoist (scale f)+  toGenT =+    distributeT . hoist toGenT -  freezeGen m0 =-    Strict.RWST $ \r s0 -> do-      ((x, s, w), m) <- freeze (Strict.runRWST m0 r s0)-      pure ((x, Strict.RWST (\_ _ -> m)), s, w)+  fromGenT =+    hoist fromGenT . distributeT  ------------------------------------------------------------------------ -- GenT instances  instance (Monad m, Semigroup a) => Semigroup (GenT m a) where-  (<>) = liftA2 (Semigroup.<>)+  (<>) =+    liftA2 (Semigroup.<>)  instance (Monad m, Monoid a) => Monoid (GenT m a) where-  mappend = liftA2 mappend-  mempty = return mempty+  mappend =+    liftA2 mappend +  mempty =+    return mempty+ instance Functor m => Functor (GenT m) where   fmap f gen =     GenT $ \seed size ->       fmap f (runGenT seed size gen) +--+-- implementation: parallel shrinking+-- instance Monad m => Applicative (GenT m) where   pure =-    return-  (<*>) =-    ap+    fromTreeMaybeT . pure +  (<*>) f m =+    GenT $ \ size seed ->+      case Seed.split seed of+        (sf, sm) ->+          uncurry ($) <$>+            runGenT size sf f `mzip`+            runGenT size sm m++--+-- implementation: satisfies law (ap = <*>)+--+--instance Monad m => Applicative (GenT m) where+--  pure =+--    fromTreeMaybeT . pure+--  (<*>) f m =+--    GenT $ \ size seed ->+--      case Seed.split seed of+--        (sf, sm) ->+--          runGenT size sf f <*>+--          runGenT size sm m+ instance Monad m => Monad (GenT m) where   return =-    liftTree . pure+    pure    (>>=) m k =     GenT $ \size seed ->@@ -553,15 +486,23 @@           runGenT size sk . k =<<           runGenT size sm m +  fail =+    Fail.fail++instance Monad m => MonadFail (GenT m) where+  fail =+    error+ instance Monad m => Alternative (GenT m) where   empty =     mzero+   (<|>) =     mplus  instance Monad m => MonadPlus (GenT m) where   mzero =-    liftTree mzero+    fromTreeMaybeT mzero    mplus x y =     GenT $ \size seed ->@@ -572,70 +513,79 @@  instance MonadTrans GenT where   lift =-    liftTree . Trans.lift . Trans.lift+    fromTreeMaybeT . lift . lift  instance MFunctor GenT where   hoist f =     mapGenT (hoist (hoist f)) -embedMaybe ::+embedMaybeT ::      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)+embedMaybeT f m =+  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+embedTreeMaybeT ::+     Monad n+  => (forall a. m a -> TreeT (MaybeT n) a)+  -> TreeT (MaybeT m) b+  -> TreeT (MaybeT n) b+embedTreeMaybeT f tree_ =+  embed (embedMaybeT f) tree_ -embedGen :: Monad n => (forall a. m a -> GenT n a) -> GenT m b -> GenT n b-embedGen f gen =+embedGenT ::+     Monad n+  => (forall a. m a -> GenT n a)+  -> GenT m b+  -> GenT n b+embedGenT f gen =   GenT $ \size seed ->     case Seed.split seed of       (sf, sg) ->-        (runGenT size sf . f) `embedTree`+        (runGenT size sf . f) `embedTreeMaybeT`         (runGenT size sg gen)  instance MMonad GenT where   embed =-    embedGen+    embedGenT -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+distributeGenT :: Transformer t GenT m => GenT (t m) a -> t (GenT m) a+distributeGenT x =+  join . lift . GenT $ \size seed ->+    pure . hoist fromTreeMaybeT . distributeT . hoist distributeT $ runGenT size seed x -instance Distributive GenT where+instance MonadTransDistributive GenT where   type Transformer t GenT m = (       Monad (t (GenT m))     , Transformer t MaybeT m-    , Transformer t Tree (MaybeT m)+    , Transformer t TreeT (MaybeT m)     ) -  distribute =-    distributeGen+  distributeT =+    distributeGenT  instance PrimMonad m => PrimMonad (GenT m) where   type PrimState (GenT m) =     PrimState m+   primitive =-    Trans.lift . primitive+    lift . primitive  instance MonadIO m => MonadIO (GenT m) where   liftIO =-    Trans.lift . liftIO+    lift . liftIO  instance MonadBase b m => MonadBase b (GenT m) where   liftBase =-    Trans.lift . liftBase+    lift . liftBase  instance MonadThrow m => MonadThrow (GenT m) where   throwM =-    Trans.lift . throwM+    lift . throwM  instance MonadCatch m => MonadCatch (GenT m) where   catch m onErr =@@ -647,31 +597,33 @@  instance MonadReader r m => MonadReader r (GenT m) where   ask =-    Trans.lift ask+    lift ask   local f m =     mapGenT (local f) m  instance MonadState s m => MonadState s (GenT m) where   get =-    Trans.lift get+    lift get   put =-    Trans.lift . put+    lift . put   state =-    Trans.lift . state+    lift . state  instance MonadWriter w m => MonadWriter w (GenT m) where   writer =-    Trans.lift . writer+    lift . writer   tell =-    Trans.lift . tell+    lift . tell   listen =-    mapGenT listen+    undefined+    --mapGenT listen   pass =-    mapGenT pass+    undefined+    --mapGenT pass  instance MonadError e m => MonadError e (GenT m) where   throwError =-    Trans.lift . throwError+    lift . throwError   catchError m onErr =     GenT $ \size seed ->       case Seed.split seed of@@ -681,22 +633,16 @@  instance MonadResource m => MonadResource (GenT m) where   liftResourceT =-    Trans.lift . liftResourceT+    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 ->+  fromGenT . GenT $ \size seed ->     pure (f size seed)  ------------------------------------------------------------------------@@ -708,14 +654,14 @@ --   the existing shrinks intact. -- shrink :: MonadGen m => (a -> [a]) -> m a -> m a-shrink =-  shrinkGen+shrink f =+  withGenT $ mapGenT (Tree.expand f)  -- | Throw away a generator's shrink tree. -- prune :: MonadGen m => m a -> m a prune =-  pruneGen+  withGenT $ mapGenT (Tree.prune 0)  ------------------------------------------------------------------------ -- Combinators - Size@@ -736,8 +682,17 @@ -- | Adjust the size parameter by transforming it with the given function. -- scale :: MonadGen m => (Size -> Size) -> m a -> m a-scale =-  scaleGen+scale f =+  withGenT $ \gen ->+    GenT $ \size0 seed ->+      let+        size =+          f size0+      in+        if size < 0 then+          error "Hedgehog.Gen.scale: negative size"+        else+          runGenT size seed gen  -- | Make a generator smaller by scaling its size parameter. --@@ -957,6 +912,8 @@ -- enumBounded :: 'Gen' 'Bool' -- @ --+--   /This is implemented in terms of the 'Enum' class, and thus may be+--    partial for integral types larger than 'Int', e.g. 'Word64'./ enumBounded :: (MonadGen m, Enum a, Bounded a) => m a enumBounded =   enum minBound maxBound@@ -1049,7 +1006,7 @@ -- | Generates a Unicode character, excluding noncharacters and invalid standalone surrogates: --   @'\0'..'\1114111' (excluding '\55296'..'\57343')@ ---unicode :: MonadGen m => m Char+unicode :: (MonadGen m, GenBase m ~ Identity) => m Char unicode =   filter (not . isNoncharacter) $ filter (not . isSurrogate) unicodeAll @@ -1229,7 +1186,7 @@ -- discard :: MonadGen m => m a discard =-  liftGen mzero+  fromGenT empty  -- | Discards the generator if the generated value does not satisfy the --   predicate.@@ -1247,32 +1204,49 @@ --   This is essentially: -- -- @--- filter p gen = 'mfilter' p gen '<|>' filter p gen+--   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 =+filter :: (MonadGen m, GenBase m ~ Identity) => (a -> Bool) -> m a -> m a+filter p gen0 =   let     try k =       if k > 100 then         discard       else do-        x <- scale (2 * k +) gen+        (x, gen) <- freeze $ scale (2 * k +) gen0+         if p x then-          pure x+          withGenT (mapGenT (Tree.filterMaybeT p)) gen         else           try (k + 1)   in     try 0 +filterT :: MonadGen m => (a -> Bool) -> m a -> m a+filterT p gen0 =+  let+    try k =+      if k > 100 then+        discard+      else do+        (x, gen) <- freeze $ scale (2 * k +) gen0++        if p x then+          withGenT (mapGenT (Tree.filterT p)) gen+        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 :: (MonadGen m, GenBase m ~ Identity) => m (Maybe a) -> m a just g = do   mx <- filter Maybe.isJust g   case mx of@@ -1281,6 +1255,19 @@     Nothing ->       error "Hedgehog.Gen.just: internal error, unexpected Nothing" +-- | Runs a 'Maybe' generator until it produces a 'Just'.+--+--   This is implemented using 'filter' and has the same caveats.+--+justT :: MonadGen m => m (Maybe a) -> m a+justT g = do+  mx <- filterT Maybe.isJust g+  case mx of+    Just x ->+      pure x+    Nothing ->+      error "Hedgehog.Gen.just: internal error, unexpected Nothing"+ ------------------------------------------------------------------------ -- Combinators - Collections @@ -1298,13 +1285,20 @@ -- 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)+  let+     interleave =+       (interleaveTreeT . nodeValue =<<)+  in+    sized $ \size ->+      ensure (atLeast $ Range.lowerBound size range) .+      withGenT (mapGenT (TreeT . interleave . runTreeT)) $ do+        n <- integral_ range+        replicateM n (toTreeMaybeT gen) +interleaveTreeT :: Monad m => [TreeT m a] -> m (NodeT m [a])+interleaveTreeT =+  fmap Tree.interleave . traverse runTreeT+ -- | Generates a seq using a 'Range' to determine the length. -- seq :: MonadGen m => Range Int -> m a -> m (Seq a)@@ -1416,7 +1410,14 @@ -- freeze :: MonadGen m => m a -> m (a, m a) freeze =-  freezeGen+  withGenT $ \gen ->+    GenT $ \size seed -> do+      mx <- lift . lift . runMaybeT . runTreeT $ runGenT size seed gen+      case mx of+        Nothing ->+          empty+        Just (NodeT x xs) ->+          pure (x, fromGenT . fromTreeMaybeT . Tree.fromNodeT $ NodeT x xs)  shrinkSubterms :: Subterms n a -> [Subterms n a] shrinkSubterms = \case@@ -1541,46 +1542,14 @@           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+          case evalGen 30 seed gen of             Nothing ->               loop (n - 1)             Just x ->-              pure $ nodeValue x+              pure $ Tree.treeValue 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. --@@ -1600,6 +1569,35 @@   seed <- liftIO Seed.random   printWith 30 seed gen +-- | Print the value produced by a generator, and the first level of shrinks,+--   for the given size and seed.+--+--   Use 'print' to generate a value from a random seed.+--+printWith :: (MonadIO m, Show a) => Size -> Seed -> Gen a -> m ()+printWith size seed gen =+  liftIO $ do+    case evalGen size seed gen of+      Nothing -> do+        putStrLn "=== Outcome ==="+        putStrLn "<discard>"++      Just tree_ -> do+        let+          NodeT x ss =+            runIdentity (runTreeT tree_)++        putStrLn "=== Outcome ==="+        putStrLn (show x)+        putStrLn "=== Shrinks ==="++        for_ ss $ \s ->+          let+            NodeT y _ =+              runIdentity $ runTreeT s+          in+            putStrLn (show y)+ -- | Run a generator with a random seed and print the resulting shrink tree. -- -- @@@ -1622,11 +1620,26 @@   seed <- liftIO Seed.random   printTreeWith 30 seed gen --- | Render a generator as a tree of strings.+-- | Print the shrink tree produced by a generator, for the given size and+--   seed. ---renderNodes :: (Monad m, Show a) => Size -> Seed -> Gen a -> Tree m String-renderNodes size seed =-  fmap (Maybe.maybe "<discard>" show) . runDiscardEffect . runGenT size seed . lift+--   Use 'printTree' to generate a value from a random seed.+--+printTreeWith :: (MonadIO m, Show a) => Size -> Seed -> Gen a -> m ()+printTreeWith size seed gen = do+  liftIO . putStr $+    renderTree size seed gen++-- | Render the shrink tree produced by a generator, for the given size and+--   seed.+--+renderTree :: Show a => Size -> Seed -> Gen a -> String+renderTree size seed gen =+  case evalGen size seed gen of+    Nothing ->+      "<discard>"+    Just x ->+      Tree.render (fmap show x)  ------------------------------------------------------------------------ -- Internal

@@ -1,6 +1,10 @@ {-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -21,8 +25,11 @@   , PropertyName(..)   , PropertyConfig(..)   , TestLimit(..)+  , TestCount(..)   , DiscardLimit(..)+  , DiscardCount(..)   , ShrinkLimit(..)+  , ShrinkCount(..)   , ShrinkRetries(..)   , withTests   , withDiscards@@ -39,12 +46,14 @@   -- * Group   , Group(..)   , GroupName(..)+  , PropertyCount(..)    -- * TestT   , MonadTest(..)   , Test   , TestT(..)   , Log(..)+  , Journal(..)   , Failure(..)   , Diff(..)   , annotate@@ -54,6 +63,7 @@   , failure   , success   , assert+  , diff   , (===)   , (/==) @@ -63,6 +73,25 @@   , evalEither   , evalExceptT +  -- * Coverage+  , Coverage(..)+  , Label(..)+  , LabelName(..)+  , cover+  , classify+  , label+  , collect+  , coverPercentage+  , labelCovered+  , coverageSuccess+  , coverageFailures+  , journalCoverage++  , Cover(..)+  , CoverCount(..)+  , CoverPercentage(..)+  , toCoverCount+   -- * Internal   -- $internal   , defaultConfig@@ -84,6 +113,8 @@ import           Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import           Control.Monad.Catch (SomeException(..), displayException) import           Control.Monad.Error.Class (MonadError(..))+import           Control.Monad.Fail (MonadFail (..))+import qualified Control.Monad.Fail as Fail import           Control.Monad.IO.Class (MonadIO(..)) import           Control.Monad.Morph (MFunctor(..)) import           Control.Monad.Primitive (PrimMonad(..))@@ -108,8 +139,10 @@  import qualified Data.Char as Char import           Data.Functor.Identity (Identity(..))+import           Data.Map (Map)+import qualified Data.Map.Strict as Map import qualified Data.List as List-import           Data.Semigroup (Semigroup)+import           Data.Semigroup (Semigroup(..)) import           Data.String (IsString) import           Data.Typeable (typeOf) @@ -120,7 +153,7 @@ import           Hedgehog.Internal.Show import           Hedgehog.Internal.Source -import           Language.Haskell.TH.Lift (deriveLift)+import           Language.Haskell.TH.Syntax (Lift)  ------------------------------------------------------------------------ @@ -151,6 +184,8 @@     , MonadState s     , MonadError e     )+-- NOTE: Move this to the deriving list above when we drop 7.10+deriving instance MonadResource m => MonadResource (PropertyT m)  -- | A test monad allows the assertion of expectations. --@@ -161,7 +196,7 @@ -- newtype TestT m a =   TestT {-      unTest :: ExceptT Failure (Lazy.WriterT [Log] m) a+      unTest :: ExceptT Failure (Lazy.WriterT Journal m) a     } deriving (       Functor     , Applicative@@ -184,7 +219,7 @@ newtype PropertyName =   PropertyName {       unPropertyName :: String-    } deriving (Eq, Ord, Show, IsString, Semigroup)+    } deriving (Eq, Ord, Show, IsString, Semigroup, Lift)  -- | Configuration for a property test. --@@ -194,7 +229,7 @@     , propertyDiscardLimit :: !DiscardLimit     , propertyShrinkLimit :: !ShrinkLimit     , propertyShrinkRetries :: !ShrinkRetries-    } deriving (Eq, Ord, Show)+    } deriving (Eq, Ord, Show, Lift)  -- | The number of successful tests that need to be run before a property test --   is considered successful.@@ -207,8 +242,20 @@ -- newtype TestLimit =   TestLimit Int+  deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)++-- | The number of tests a property ran successfully.+--+newtype TestCount =+  TestCount Int   deriving (Eq, Ord, Show, Num, Enum, Real, Integral) +-- | The number of tests a property had to discard.+--+newtype DiscardCount =+  DiscardCount Int+  deriving (Eq, Ord, Show, Num, Enum, Real, Integral)+ -- | The number of discards to allow before giving up. -- --   Can be constructed using numeric literals:@@ -220,7 +267,7 @@ -- newtype DiscardLimit =   DiscardLimit Int-  deriving (Eq, Ord, Show, Num, Enum, Real, Integral)+  deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)  -- | The number of shrinks to try before giving up on shrinking. --@@ -232,6 +279,12 @@ -- newtype ShrinkLimit =   ShrinkLimit Int+  deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)++-- | The numbers of times a property was able to shrink after a failing test.+--+newtype ShrinkCount =+  ShrinkCount Int   deriving (Eq, Ord, Show, Num, Enum, Real, Integral)  -- | The number of times to re-run a test during shrinking. This is useful if@@ -251,7 +304,7 @@ -- newtype ShrinkRetries =   ShrinkRetries Int-  deriving (Eq, Ord, Show, Num, Enum, Real, Integral)+  deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)  -- | A named collection of property tests. --@@ -272,12 +325,18 @@ newtype GroupName =   GroupName {       unGroupName :: String-    } deriving (Eq, Ord, Show, IsString, Semigroup)+    } deriving (Eq, Ord, Show, IsString, Semigroup, Lift) +-- | The number of properties in a group. --+newtype PropertyCount =+  PropertyCount Int+  deriving (Eq, Ord, Show, Num, Enum, Real, Integral)++-- -- 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.+-- FIXME allow user's to crete their own diffs anywhere. --  -- | Log messages which are recorded during a test run.@@ -285,8 +344,15 @@ data Log =     Annotation (Maybe Span) String   | Footnote String+  | Label (Label Cover)     deriving (Eq, Show) +-- | A record containing the details of a test run.+newtype Journal =+  Journal {+      journalLogs :: [Log]+    } deriving (Eq, Show, Semigroup, Monoid)+ -- | Details on where and why a test failed. -- data Failure =@@ -305,18 +371,89 @@     , diffValue :: ValueDiff     } deriving (Eq, Show) +-- | Whether a test is covered by a classifier, and therefore belongs to a+--   'Class'.+--+data Cover =+    NoCover+  | Cover+    deriving (Eq, Ord, Show)++-- | The total number of tests which are covered by a classifier.+--+--   Can be constructed using numeric literals:+--+-- @+--   30 :: CoverCount+-- @+--+newtype CoverCount =+  CoverCount {+      unCoverCount :: Int+    } deriving (Eq, Ord, Show, Num)++-- | The relative number of tests which are covered by a classifier.+--+--   Can be constructed using numeric literals:+--+-- @+--   30 :: CoverPercentage+-- @+--+newtype CoverPercentage =+  CoverPercentage {+      unCoverPercentage :: Double+    } deriving (Eq, Ord, Show, Num)++-- | The name of a classifier.+--+--   Can be constructed using `OverloadedStrings`:+--+-- @+--   "apples" :: LabelName+-- @+--+newtype LabelName =+  LabelName {+      unLabelName :: String+    } deriving (Eq, Ord, Show, IsString)++-- | The extent to which a test is covered by a classifier.+--+--   /When a classifier's coverage does not exceed the required minimum, the+--   test will be failed./+--+data Label a =+  MkLabel {+      labelName :: !LabelName+    , labelLocation :: !(Maybe Span)+    , labelMinimum :: !CoverPercentage+    , labelAnnotation :: !a+    } deriving (Eq, Show, Functor, Foldable, Traversable)++-- | The extent to which all classifiers cover a test.+--+--   /When a given classification's coverage does not exceed the required+--   minimum, the test will be failed./+--+newtype Coverage a =+  Coverage {+      coverageLabels :: Map LabelName (Label a)+    } deriving (Eq, Show, Functor, Foldable, Traversable)+ ------------------------------------------------------------------------ -- TestT  instance Monad m => Monad (TestT m) where   return =-    TestT . return+    pure    (>>=) m k =     TestT $       unTest m >>=       unTest . k +instance Monad m => MonadFail (TestT m) where   fail err =     TestT . ExceptT . pure . Left $ Failure Nothing err Nothing @@ -328,16 +465,16 @@   hoist f =     TestT . hoist (hoist f) . unTest -instance Distributive TestT where+instance MonadTransDistributive TestT where   type Transformer t TestT m = (-      Transformer t (Lazy.WriterT [Log]) m-    , Transformer t (ExceptT Failure) (Lazy.WriterT [Log] m)+      Transformer t (Lazy.WriterT Journal) m+    , Transformer t (ExceptT Failure) (Lazy.WriterT Journal m)     ) -  distribute =+  distributeT =     hoist TestT .-    distribute .-    hoist distribute .+    distributeT .+    hoist distributeT .     unTest  instance PrimMonad m => PrimMonad (TestT m) where@@ -362,10 +499,10 @@  instance MonadTransControl TestT where   type StT TestT a =-    (Either Failure a, [Log])+    (Either Failure a, Journal)    liftWith f =-    mkTestT . fmap (, []) . fmap Right $ f $ runTestT+    mkTestT . fmap (, mempty) . fmap Right $ f $ runTestT    restoreT =     mkTestT@@ -435,19 +572,19 @@   liftTest =     lift . liftTest -mkTestT :: m (Either Failure a, [Log]) -> TestT m a+mkTestT :: m (Either Failure a, Journal) -> TestT m a mkTestT =   TestT . ExceptT . Lazy.WriterT -mkTest :: (Either Failure a, [Log]) -> Test a+mkTest :: (Either Failure a, Journal) -> Test a mkTest =   mkTestT . Identity -runTestT :: TestT m a -> m (Either Failure a, [Log])+runTestT :: TestT m a -> m (Either Failure a, Journal) runTestT =   Lazy.runWriterT . runExceptT . unTest -runTest :: Test a -> (Either Failure a, [Log])+runTest :: Test a -> (Either Failure a, Journal) runTest =   runIdentity . runTestT @@ -455,14 +592,14 @@ -- writeLog :: MonadTest m => Log -> m () writeLog x =-  liftTest $ mkTest (pure (), [x])+  liftTest $ mkTest (pure (), (Journal [x]))  -- | Fail the test with an error message, useful for building other failure --   combinators. -- failWith :: (MonadTest m, HasCallStack) => Maybe Diff -> String -> m a-failWith diff msg =-  liftTest $ mkTest (Left $ Failure (getCaller callStack) msg diff, [])+failWith mdiff msg =+  liftTest $ mkTest (Left $ Failure (getCaller callStack) msg mdiff, mempty)  -- | Annotates the source code with a message that might be useful for --   debugging a test failure.@@ -492,22 +629,31 @@ footnoteShow =   writeLog . Footnote . showPretty --- | Fails with an error which shows the difference between two values.---+-- | Fails with an error that shows the difference between two values. failDiff :: (MonadTest m, Show a, Show b, HasCallStack) => a -> b -> m () failDiff x y =   case valueDiff <$> mkValue x <*> mkValue y of     Nothing ->       withFrozenCallStack $-        failWith Nothing $ unlines [-            "━━━ Not Equal ━━━"+        failWith Nothing $+        unlines $ [+            "Failed"+          , "━━ lhs ━━"           , showPretty x+          , "━━ rhs ━━"           , showPretty y           ]-    Just diff ->++    Just vdiff@(ValueSame _) ->       withFrozenCallStack $-        failWith (Just $ Diff "Failed (" "- lhs" "=/=" "+ rhs" ")" diff) ""+        failWith (Just $+          Diff "━━━ Failed ("  "" "no differences" "" ") ━━━" vdiff) "" +    Just vdiff ->+      withFrozenCallStack $+        failWith (Just $+          Diff "━━━ Failed (" "- lhs" ") (" "+ rhs" ") ━━━" vdiff) ""+ -- | Fails with an error which renders the type of an exception and its error --   message. --@@ -515,7 +661,7 @@ failException (SomeException x) =   withFrozenCallStack $     failWith Nothing $ unlines [-        "━━━ Exception: " ++ show (typeOf x) ++ " ━━━"+        "━━━ Exception (" ++ show (typeOf x) ++ ") ━━━"       , List.dropWhileEnd Char.isSpace (displayException x)       ] @@ -541,33 +687,48 @@   else     withFrozenCallStack failure -infix 4 ===---- | Fails the test if the two arguments provided are not equal.+-- | Fails the test and shows a git-like diff if the comparison operation+--   evaluates to 'False' when applied to its arguments. ---(===) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()-(===) x y = do-  ok <- withFrozenCallStack $ eval (x == y)+--   The comparison function is the second argument, which may be+--   counter-intuitive to Haskell programmers. However, it allows operators to+--   be written infix for easy reading:+--+-- @+--   diff y (<) 87+--   diff x (<=) 'r'+-- @+--+--   /This function behaves like the unix `diff` tool, which gives a `0` exit+--   code if the compared files are identical, or a `1` exit code code+--   otherwise. Like unix `diff`, if the arguments fail the comparison, a diff+--   is shown./+--+diff :: (MonadTest m, Show a, Show b, HasCallStack) => a -> (a -> b -> Bool) -> b -> m ()+diff x op y = do+  ok <- withFrozenCallStack $ eval (x `op` y)   if ok then     success   else     withFrozenCallStack $ failDiff x y +infix 4 ===++-- | Fails the test if the two arguments provided are not equal.+--+(===) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()+(===) x y =+  withFrozenCallStack $+    diff x (==) y+ infix 4 /==  -- | Fails the test if the two arguments provided are equal. -- (/==) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()-(/==) x y = do-  ok <- withFrozenCallStack $ eval (x /= y)-  if ok then-    success-  else-    withFrozenCallStack $-      failWith Nothing $ unlines [-          "━━━ Both equal to ━━━"-        , showPretty x-        ]+(/==) x y =+  withFrozenCallStack $+    diff x (/=) y  -- | Fails the test if the value throws an exception when evaluated to weak --   head normal form (WHNF).@@ -618,20 +779,24 @@   lift =     PropertyT . lift . lift +instance Monad m => MonadFail (PropertyT m) where+  fail err =+    PropertyT (Fail.fail err)+ instance MFunctor PropertyT where   hoist f =     PropertyT . hoist (hoist f) . unPropertyT -instance Distributive PropertyT where+instance MonadTransDistributive PropertyT where   type Transformer t PropertyT m = (       Transformer t GenT m     , Transformer t TestT (GenT m)     ) -  distribute =+  distributeT =     hoist PropertyT .-    distribute .-    hoist distribute .+    distributeT .+    hoist distributeT .     unPropertyT  instance PrimMonad m => PrimMonad (PropertyT m) where@@ -680,10 +845,11 @@ -- forAllWith :: (Monad m, HasCallStack) => (a -> String) -> Gen a -> PropertyT m a forAllWith render gen =-  withFrozenCallStack $ forAllWithT render $ Gen.lift gen+  withFrozenCallStack $ forAllWithT render $ Gen.generalize gen  -- | Generates a random input for the test by running the provided generator. --+-- forAllT :: (Monad m, Show a, HasCallStack) => GenT m a -> PropertyT m a forAllT gen =   withFrozenCallStack $ forAllWithT showPretty gen@@ -698,7 +864,7 @@ -- discard :: Monad m => PropertyT m a discard =-  PropertyT $ lift Gen.discard+  PropertyT $ lift (Gen.generalize Gen.discard)  -- | Lift a test in to a property. --@@ -708,14 +874,9 @@ --   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--- @+--   An example where this is useful is parallel state machine testing, as+--   'Hedgehog.Internal.State.executeParallel' requires 'MonadBaseControl' 'IO'+--   in order to be able to spawn threads in 'MonadTest'. -- test :: Monad m => TestT m a -> PropertyT m a test =@@ -786,15 +947,156 @@     withFrozenCallStack (evalM m)  --------------------------------------------------------------------------- FIXME Replace with DeriveLift when we drop 7.10 support.+-- Coverage -$(deriveLift ''GroupName)-$(deriveLift ''PropertyName)-$(deriveLift ''PropertyConfig)-$(deriveLift ''TestLimit)-$(deriveLift ''DiscardLimit)-$(deriveLift ''ShrinkLimit)-$(deriveLift ''ShrinkRetries)+instance Semigroup Cover where+  (<>) NoCover NoCover =+    NoCover+  (<>) _ _ =+    Cover++instance Monoid Cover where+  mempty =+    NoCover+  mappend =+    (<>)++instance Semigroup CoverCount where+  (<>) (CoverCount n0) (CoverCount n1) =+    CoverCount (n0 + n1)++instance Monoid CoverCount where+  mempty =+    CoverCount 0+  mappend =+    (<>)++toCoverCount :: Cover -> CoverCount+toCoverCount = \case+  NoCover ->+    CoverCount 0+  Cover ->+    CoverCount 1++-- | This semigroup is right biased. The name, location and percentage from the+--   rightmost `Label` will be kept. This shouldn't be a problem since the+--   library doesn't allow setting multiple classes with the same 'ClassifierName'.+instance Semigroup a => Semigroup (Label a) where+  (<>) (MkLabel _ _ _ m0) (MkLabel name location percentage m1) =+    MkLabel name location percentage (m0 <> m1)++instance Semigroup a => Semigroup (Coverage a) where+  (<>) (Coverage c0) (Coverage c1) =+    Coverage $+      Map.foldrWithKey (Map.insertWith (<>)) c0 c1++instance (Semigroup a, Monoid a) => Monoid (Coverage a) where+  mempty =+    Coverage mempty+  mappend =+    (<>)++coverPercentage :: TestCount -> CoverCount -> CoverPercentage+coverPercentage (TestCount tests) (CoverCount count) =+  let+    percentage :: Double+    percentage =+      fromIntegral count / fromIntegral tests * 100++    thousandths :: Int+    thousandths =+      round $ percentage * 10+  in+    CoverPercentage (fromIntegral thousandths / 10)++labelCovered :: TestCount -> Label CoverCount -> Bool+labelCovered tests (MkLabel _ _ minimum_ population) =+  coverPercentage tests population >= minimum_++coverageSuccess :: TestCount -> Coverage CoverCount -> Bool+coverageSuccess tests =+  null . coverageFailures tests++coverageFailures :: TestCount -> Coverage CoverCount -> [Label CoverCount]+coverageFailures tests (Coverage kvs) =+  filter (not . labelCovered tests) (Map.elems kvs)++fromLabel :: Label a -> Coverage a+fromLabel x =+  Coverage $+    Map.singleton (labelName x) x++unionsCoverage :: Semigroup a => [Coverage a] -> Coverage a+unionsCoverage =+  Coverage .+  Map.unionsWith (<>) .+  fmap coverageLabels++journalCoverage :: Journal -> Coverage CoverCount+journalCoverage (Journal logs) =+  fmap toCoverCount .+  unionsCoverage $ do+    Label x <- logs+    pure (fromLabel x)++-- | Require a certain percentage of the tests to be covered by the+--   classifier.+--+-- @+--    prop_with_coverage :: Property+--    prop_with_coverage =+--      property $ do+--        match <- forAll Gen.bool+--        cover 30 "True" $ match+--        cover 30 "False" $ not match+-- @+--+--   The example above requires a minimum of 30% coverage for both+--   classifiers. If these requirements are not met, it will fail the test.+--+cover :: (MonadTest m, HasCallStack) => CoverPercentage -> LabelName -> Bool -> m ()+cover minimum_ name covered =+  let+    cover_ =+      if covered then+        Cover+      else+        NoCover+  in+    writeLog . Label $+      MkLabel name (getCaller callStack) minimum_ cover_++-- | Records the proportion of tests which satisfy a given condition.+--+-- @+--    prop_with_classifier :: Property+--    prop_with_classifier =+--      property $ do+--        xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha+--        for_ xs $ \x -> do+--          classify "newborns" $ x == 0+--          classify "children" $ x > 0 && x < 13+--          classify "teens" $ x > 12 && x < 20+-- @+classify :: (MonadTest m, HasCallStack) => LabelName -> Bool -> m ()+classify name covered =+  withFrozenCallStack $+    cover 0 name covered++-- | Add a label for each test run. It produces a table showing the percentage+--   of test runs that produced each label.+--+label :: (MonadTest m, HasCallStack) => LabelName -> m ()+label name =+  withFrozenCallStack $+    cover 0 name True++-- | Like 'label', but uses 'Show' to render its argument for display.+--+collect :: (MonadTest m, Show a, HasCallStack) => a -> m ()+collect x =+  withFrozenCallStack $+    cover 0 (LabelName (show x)) True  ------------------------------------------------------------------------ -- Internal

@@ -8,6 +8,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}+ module Hedgehog.Internal.Report (   -- * Report     Summary(..)@@ -17,11 +18,6 @@   , FailureReport(..)   , FailedAnnotation(..) -  , ShrinkCount(..)-  , TestCount(..)-  , DiscardCount(..)-  , PropertyCount(..)-   , Style(..)   , Markup(..) @@ -50,11 +46,19 @@ import qualified Data.Map as Map import           Data.Maybe (mapMaybe, catMaybes) import           Data.Semigroup (Semigroup(..))+import           Data.Traversable (for)  import           Hedgehog.Internal.Config import           Hedgehog.Internal.Discovery (Pos(..), Position(..)) import qualified Hedgehog.Internal.Discovery as Discovery+import           Hedgehog.Internal.Property (Coverage(..), Label(..), LabelName(..))+import           Hedgehog.Internal.Property (CoverCount(..), CoverPercentage(..)) import           Hedgehog.Internal.Property (PropertyName(..), Log(..), Diff(..))+import           Hedgehog.Internal.Property (ShrinkCount(..), PropertyCount(..))+import           Hedgehog.Internal.Property (TestCount(..), DiscardCount(..))+import           Hedgehog.Internal.Property (coverPercentage, coverageFailures)+import           Hedgehog.Internal.Property (labelCovered)+ import           Hedgehog.Internal.Seed (Seed) import           Hedgehog.Internal.Show import           Hedgehog.Internal.Source@@ -64,6 +68,7 @@ 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@@ -75,30 +80,6 @@ ------------------------------------------------------------------------ -- 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)@@ -110,6 +91,7 @@       failureSize :: !Size     , failureSeed :: !Seed     , failureShrinks :: !ShrinkCount+    , failureCoverage :: !(Maybe (Coverage CoverCount))     , failureAnnotations :: ![FailedAnnotation]     , failureLocation :: !(Maybe Span)     , failureMessage :: !String@@ -141,6 +123,7 @@   Report {       reportTests :: !TestCount     , reportDiscards :: !DiscardCount+    , reportCoverage :: !(Coverage CoverCount)     , reportStatus :: !a     } deriving (Show, Functor, Foldable, Traversable) @@ -220,11 +203,14 @@   | ShrinkingIcon   | ShrinkingHeader   | FailedIcon-  | FailedHeader+  | FailedText   | GaveUpIcon-  | GaveUpHeader+  | GaveUpText   | SuccessIcon-  | SuccessHeader+  | SuccessText+  | CoverageIcon+  | CoverageText+  | CoverageFill   | DeclarationLocation   | StyledLineNo !Style   | StyledBorder !Style@@ -279,12 +265,13 @@      Size   -> Seed   -> ShrinkCount+  -> Maybe (Coverage CoverCount)   -> Maybe Span   -> String   -> Maybe Diff   -> [Log]   -> FailureReport-mkFailure size seed shrinks location message diff logs =+mkFailure size seed shrinks mcoverage location message diff logs =   let     inputs =       mapMaybe takeAnnotation logs@@ -292,7 +279,7 @@     footnotes =       mapMaybe takeFootnote logs   in-    FailureReport size seed shrinks inputs location message diff footnotes+    FailureReport size seed shrinks mcoverage inputs location message diff footnotes  ------------------------------------------------------------------------ -- Pretty Printing@@ -496,19 +483,19 @@ 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 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+  => [Doc Markup]   -> Maybe Diff   -> Span   -> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))-ppFailureLocation msg mdiff sloc =+ppFailureLocation msgs mdiff sloc =   runMaybeT $ do     decl <- fmap defaultStyle . MaybeT $ readDeclaration sloc     (startCol, endCol) <- bimap fromIntegral fromIntegral <$> lastLineSpan sloc decl@@ -523,7 +510,7 @@           markup FailureGutter (WL.text "│ ") <> x        msgDocs =-        fmap ((StyleFailure, ) . ppFailure . markup FailureMessage . WL.text) (List.lines msg)+        fmap ((StyleFailure, ) . ppFailure . markup FailureMessage) msgs        diffDocs =         case mdiff of@@ -619,9 +606,9 @@ 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) <-+ppFailureReport :: MonadIO m => Maybe PropertyName -> TestCount -> FailureReport -> m [Doc Markup]+ppFailureReport name tests (FailureReport size seed _ mcoverage inputs0 mlocation0 msg mdiff msgs0) = do+  (msgs1, mlocation) <-     case mlocation0 of       Nothing ->         -- Move the failure message to the end section if we have@@ -638,16 +625,37 @@           pure (docs, Nothing)        Just location0 ->-        (concatMap ppTextLines msgs0,)-          <$> ppFailureLocation msg mdiff location0+        fmap (concatMap ppTextLines msgs0,) $+          ppFailureLocation (fmap WL.text $ List.lines msg) mdiff location0 -  (args, idecls) <- partitionEithers <$> zipWithM ppFailedInput [0..] inputs0+  coverageLocations <-+    case mcoverage of+      Nothing ->+        pure []+      Just coverage ->+        for (coverageFailures tests coverage) $ \(MkLabel _ mclocation _ count) ->+          case mclocation of+            Nothing ->+              pure Nothing+            Just clocation ->+              let+                coverageMsg =+                  WL.cat [+                      "Failed ("+                    , WL.annotate CoverageText $+                        ppCoverPercentage (coverPercentage tests count) <> " coverage"+                    , ")"+                    ]+              in+                ppFailureLocation [coverageMsg] Nothing clocation +  (args, idecls) <- fmap partitionEithers $ zipWithM ppFailedInput [0..] inputs0+   let     decls =       mergeDeclarations .       catMaybes $-        mlocation : fmap pure idecls+        mlocation : coverageLocations <> fmap pure idecls      with xs f =       if null xs then@@ -655,14 +663,31 @@       else         [f xs] -  pure . WL.indent 2 . WL.vsep . WL.punctuate WL.line $ concat [+    whenSome f xs =+      if null xs then+        xs+      else+        f xs++    bottom =+      maybe [ppReproduce name size seed] (const []) mcoverage++  pure .+    whenSome (mempty :) .+    whenSome (++ [mempty]) .+    WL.punctuate WL.line .+    fmap (WL.vsep . fmap (WL.indent 2)) .+    fmap (id :: [Doc Markup] -> [Doc Markup]) .+    filter (not . null) $+    concat [       with args $-        WL.vsep . WL.punctuate WL.line+        WL.punctuate WL.line     , with decls $-        WL.vsep . WL.punctuate WL.line . fmap ppDeclaration-    , with msgs $-        WL.vsep-    , [ppReproduce name size seed]+        WL.punctuate WL.line . fmap ppDeclaration+    , with msgs1 $+        id+    , with bottom $+        id     ]  ppName :: Maybe PropertyName -> Doc a@@ -673,15 +698,18 @@     WL.text name  ppProgress :: MonadIO m => Maybe PropertyName -> Report Progress -> m (Doc Markup)-ppProgress name (Report tests discards status) =+ppProgress name (Report tests discards coverage status) =   case status of     Running ->-      pure . icon RunningIcon '●' . WL.annotate RunningHeader $-        ppName name <+>-        "passed" <+>-        ppTestCount tests <>-        ppWithDiscardCount discards <+>-        "(running)"+      pure . WL.vsep $ [+          icon RunningIcon '●' . WL.annotate RunningHeader $+            ppName name <+>+            "passed" <+>+            ppTestCount tests <>+            ppWithDiscardCount discards <+>+            "(running)"+        ] +++        ppCoverage tests coverage      Shrinking failure ->       pure . icon ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $@@ -692,38 +720,283 @@         "(shrinking)"  ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup)-ppResult name (Report tests discards result) =+ppResult name (Report tests discards coverage result) = do   case result of     Failed failure -> do-      pfailure <- ppFailureReport name failure+      pfailure <- ppFailureReport name tests failure       pure . WL.vsep $ [-          icon FailedIcon '✗' . WL.annotate FailedHeader $+          icon FailedIcon '✗' . WL.annotate FailedText $             ppName name <+>             "failed after" <+>             ppTestCount tests <>             ppShrinkDiscard (failureShrinks failure) discards <>             "."-        , mempty-        , pfailure-        , mempty-        ]+        ] +++        ppCoverage tests coverage +++        pfailure      GaveUp ->-      pure . icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader $-        ppName name <+>-        "gave up after" <+>-        ppDiscardCount discards <>-        ", passed" <+>-        ppTestCount tests <>-        "."+      pure . WL.vsep $ [+          icon GaveUpIcon '⚐' . WL.annotate GaveUpText $+            ppName name <+>+            "gave up after" <+>+            ppDiscardCount discards <>+            ", passed" <+>+            ppTestCount tests <>+            "."+        ] +++        ppCoverage tests coverage      OK ->-      pure . icon SuccessIcon '✓' . WL.annotate SuccessHeader $-        ppName name <+>-        "passed" <+>-        ppTestCount tests <>-        "."+      pure . WL.vsep $ [+          icon SuccessIcon '✓' . WL.annotate SuccessText $+            ppName name <+>+            "passed" <+>+            ppTestCount tests <>+            "."+        ] +++        ppCoverage tests coverage +ppCoverage :: TestCount -> Coverage CoverCount -> [Doc Markup]+ppCoverage tests x =+  if Map.null (coverageLabels x) then+    mempty+  else+    fmap (ppLabel tests (coverageWidth tests x)) .+    List.sortOn labelLocation $+    Map.elems (coverageLabels x)++data ColumnWidth =+  ColumnWidth {+      widthPercentage :: !Int+    , widthMinimum :: !Int+    , widthName :: !Int+    , _widthNameFail :: !Int+    }++instance Semigroup ColumnWidth where+  (<>) (ColumnWidth p0 m0 n0 f0) (ColumnWidth p1 m1 n1 f1) =+    ColumnWidth+      (max p0 p1)+      (max m0 m1)+      (max n0 n1)+      (max f0 f1)++instance Monoid ColumnWidth where+  mempty =+    ColumnWidth 0 0 0 0+  mappend =+    (<>)++coverageWidth :: TestCount -> Coverage CoverCount -> ColumnWidth+coverageWidth tests (Coverage labels) =+  foldMap (labelWidth tests) labels++labelWidth :: TestCount -> Label CoverCount -> ColumnWidth+labelWidth tests x =+  let+    percentage =+      length .+      renderCoverPercentage .+      coverPercentage tests $+      labelAnnotation x++    minimum_ =+      if labelMinimum x == 0 then+        0+      else+        length .+        renderCoverPercentage $+        labelMinimum x++    name =+      length .+      unLabelName $+      labelName x++    nameFail =+      if labelCovered tests x then+        0+      else+        name+  in+    ColumnWidth percentage minimum_ name nameFail++ppLeftPad :: Int -> Doc a -> Doc a+ppLeftPad n doc =+  let+    ndoc =+      length (show doc)++    pad =+      WL.text $+        List.replicate (n - ndoc) ' '+  in+    pad <> doc++ppLabel :: TestCount -> ColumnWidth -> Label CoverCount -> Doc Markup+ppLabel tests w x@(MkLabel name _ minimum_ count) =+  let+    covered =+      labelCovered tests x++    ltext =+      if not covered then+        WL.annotate CoverageText+      else+        id++    lborder =+      WL.annotate (StyledBorder StyleDefault)++    licon =+      if not covered then+        WL.annotate CoverageText "⚠ "+      else+        "  "++    lname =+      WL.fill (widthName w) (ppLabelName name)++    wminimum =+      ppLeftPad (widthMinimum w) $+        ppCoverPercentage minimum_++    wcover i =+      ppLeftPad (widthPercentage w + length i) $+        WL.text i <>+        ppCoverPercentage (coverPercentage tests count)++    lminimum =+      if widthMinimum w == 0 then+        mempty+      else if not covered then+        " ✗ " <> wminimum+      else if minimum_ == 0 then+        "   " <> ppLeftPad (widthMinimum w) ""+      else+        " ✓ " <> wminimum++    lcover =+      if widthMinimum w == 0 then+        wcover ""+      else if not covered then+        wcover ""+      else if minimum_ == 0 then+        wcover ""+      else+        wcover ""+  in+    WL.hcat [+        licon+      , ltext lname+      , lborder " "+      , ltext lcover+      , lborder " "+      , ltext $ ppCoverBar (coverPercentage tests count) minimum_+      , lborder "" -- "│"+      , ltext lminimum+      ]++ppLabelName :: LabelName -> Doc a+ppLabelName (LabelName name) =+  WL.text name++ppCoverPercentage :: CoverPercentage -> Doc Markup+ppCoverPercentage =+  WL.text . renderCoverPercentage++ppCoverBar :: CoverPercentage -> CoverPercentage -> Doc Markup+ppCoverBar (CoverPercentage percentage) (CoverPercentage minimum_) =+  let+    barWidth :: Int+    barWidth =+      20++    coverageRatio :: Double+    coverageRatio =+      percentage / 100.0++    coverageWidth_ :: Int+    coverageWidth_ =+      floor $+        coverageRatio * fromIntegral barWidth++    minimumRatio :: Double+    minimumRatio =+      minimum_ / 100.0++    minimumWidth :: Int+    minimumWidth =+      floor $+        minimumRatio * fromIntegral barWidth++    index :: [a] -> Int+    index xs =+      floor $+        ((coverageRatio * fromIntegral barWidth) - fromIntegral coverageWidth_) *+        fromIntegral (length xs)++    part xs =+      xs !! index xs++    fillWidth =+      barWidth - coverageWidth_ - 1++    fillErrorWidth =+      max 0 (minimumWidth - coverageWidth_ - 1)++    fillSurplusWidth =+      fillWidth - fillErrorWidth++    bar :: (Char, [Char]) -> Doc Markup+    bar (full, parts) =+      WL.hcat [+        WL.text $ replicate coverageWidth_ full+      , if fillWidth >= 0 then+          if index parts == 0 then+            if fillErrorWidth > 0 then+              WL.annotate FailedText $ WL.text [part parts]+            else+              WL.annotate CoverageFill $ WL.text [part parts]+          else+            WL.text [part parts]+        else+          ""+      , WL.annotate FailedText . WL.text $+          replicate fillErrorWidth (head parts)+      , WL.annotate CoverageFill . WL.text $+          replicate fillSurplusWidth (head parts)+      --+      -- Uncomment when debugging:+      --+      -- , WL.annotate CoverageFill . WL.text $+      --        " " ++ show barWidth+      --     ++ " " ++ show coverageWidth_+      --     ++ " " ++ show minimumWidth+      --     ++ " " ++ "/"+      --     ++ " " ++ show fillErrorWidth+      --     ++ " " ++ "+"+      --     ++ " " ++ show fillSurplusWidth+      --     ++ " " ++ "="+      --     ++ " " ++ show fillWidth+      ]+  in+    bar ('█', ['·', '▏', '▎', '▍', '▌', '▋', '▊', '▉'])++    -- FIXME Maybe this should be configurable?+    -- Alternative histogram bars:+    --bar ('⣿', ['·', '⡀', '⡄', '⡆', '⡇', '⣇', '⣧', '⣷'])+    --bar ('⣿', ['⢕', '⡀', '⣀', '⣄', '⣤', '⣦', '⣶', '⣷'])+    --bar ('⣿', ['⢕', '⡵', '⢗', '⣗', '⣟'])+    --bar ('⣿', [' ', '⡵', '⢗', '⣗', '⣟'])+    --bar ('█', ['░','▓'])+    --bar ('█', ['░'])++renderCoverPercentage :: CoverPercentage -> String+renderCoverPercentage (CoverPercentage percentage) =+  printf "%.0f" percentage <> "%"+ ppWhenNonZero :: Doc a -> PropertyCount -> Maybe (Doc a) ppWhenNonZero suffix n =   if n <= 0 then@@ -734,13 +1007,13 @@ annotateSummary :: Summary -> Doc Markup -> Doc Markup annotateSummary summary =   if summaryFailed summary > 0 then-    icon FailedIcon '✗' . WL.annotate FailedHeader+    icon FailedIcon '✗' . WL.annotate FailedText   else if summaryGaveUp summary > 0 then-    icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader+    icon GaveUpIcon '⚐' . WL.annotate GaveUpText   else if summaryWaiting summary > 0 || summaryRunning summary > 0 then     icon WaitingIcon '○' . WL.annotate WaitingHeader   else-    icon SuccessIcon '✓' . WL.annotate SuccessHeader+    icon SuccessIcon '✓' . WL.annotate SuccessText  ppSummary :: MonadIO m => Summary -> m (Doc Markup) ppSummary summary =@@ -811,16 +1084,22 @@         setSGRCode [vivid Red]       FailedIcon ->         setSGRCode [vivid Red]-      FailedHeader ->+      FailedText ->         setSGRCode [vivid Red]       GaveUpIcon ->         setSGRCode [dull Yellow]-      GaveUpHeader ->+      GaveUpText ->         setSGRCode [dull Yellow]       SuccessIcon ->         setSGRCode [dull Green]-      SuccessHeader ->+      SuccessText ->         setSGRCode [dull Green]+      CoverageIcon ->+        setSGRCode [dull Yellow]+      CoverageText ->+        setSGRCode [dull Yellow]+      CoverageFill ->+        setSGRCode [vivid Black]        DeclarationLocation ->         setSGRCode []@@ -894,6 +1173,7 @@     hSetEncoding stdout utf8     hSetEncoding stderr utf8 #endif+   pure .     display .     WL.renderSmart 100 $

@@ -1,6 +1,7 @@ {-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveLift #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}@@ -31,20 +32,24 @@ import           Data.Semigroup ((<>))  import           Hedgehog.Internal.Config-import           Hedgehog.Internal.Gen (runGenT, runDiscardEffect)+import           Hedgehog.Internal.Gen (evalGenT)+import           Hedgehog.Internal.Property (DiscardCount(..), ShrinkCount(..)) import           Hedgehog.Internal.Property (Group(..), GroupName(..))+import           Hedgehog.Internal.Property (Journal(..), Coverage(..), CoverCount(..)) import           Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..))+import           Hedgehog.Internal.Property (PropertyT(..), Failure(..), runTestT) import           Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withTests)-import           Hedgehog.Internal.Property (PropertyT(..), Log(..), Failure(..), runTestT)+import           Hedgehog.Internal.Property (TestCount(..), PropertyCount(..))+import           Hedgehog.Internal.Property (coverageSuccess, journalCoverage) 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.Internal.Tree (TreeT(..), NodeT(..)) import           Hedgehog.Range (Size) -import           Language.Haskell.TH.Lift (deriveLift)+import           Language.Haskell.TH.Syntax (Lift)  #if mingw32_HOST_OS import           System.IO (hSetEncoding, stdout, stderr, utf8)@@ -65,7 +70,7 @@       -- | How verbose to be in the runner output. 'Nothing' means detect from       --   the environment.     , runnerVerbosity :: !(Maybe Verbosity)-    } deriving (Eq, Ord, Show)+    } deriving (Eq, Ord, Show, Lift)  findM :: Monad m => [a] -> b -> (a -> m (Maybe b)) -> m b findM xs0 def p =@@ -80,24 +85,24 @@           Just x ->             return x -isFailure :: Node m (Maybe (Either x a, b)) -> Bool+isFailure :: NodeT m (Maybe (Either x a, b)) -> Bool isFailure = \case-  Node (Just (Left _, _)) _ ->+  NodeT (Just (Left _, _)) _ ->     True   _ ->     False -isSuccess :: Node m (Maybe (Either x a, b)) -> Bool+isSuccess :: NodeT 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)))+  -> TreeT m (Maybe (Either x a, b))+  -> m (NodeT m (Maybe (Either x a, b))) runTreeN n m = do-  o <- runTree m+  o <- runTreeT m   if n > 0 && isSuccess o then     runTreeN (n - 1) m   else@@ -111,18 +116,18 @@   -> ShrinkLimit   -> ShrinkRetries   -> (Progress -> m ())-  -> Node m (Maybe (Either Failure (), [Log]))+  -> NodeT m (Maybe (Either Failure (), Journal))   -> m Result takeSmallest size seed shrinks slimit retries updateUI = \case-  Node Nothing _ ->+  NodeT Nothing _ ->     pure GaveUp -  Node (Just (x, w)) xs ->+  NodeT (Just (x, (Journal logs))) xs ->     case x of       Left (Failure loc err mdiff) -> do         let           failure =-            mkFailure size seed shrinks loc err mdiff (reverse w)+            mkFailure size seed shrinks Nothing loc err mdiff (reverse logs)          updateUI $ Shrinking failure @@ -155,35 +160,56 @@     test =       catchAll test0 (fail . show) -    loop :: TestCount -> DiscardCount -> Size -> Seed -> m (Report Result)-    loop !tests !discards !size !seed = do-      updateUI $ Report tests discards Running+    loop ::+         TestCount+      -> DiscardCount+      -> Size+      -> Seed+      -> Coverage CoverCount+      -> m (Report Result)+    loop !tests !discards !size !seed !coverage0 = do+      updateUI $ Report tests discards coverage0 Running        if size > 99 then         -- size has reached limit, reset to 0-        loop tests discards 0 seed+        loop tests discards 0 seed coverage0        else if tests >= fromIntegral (propertyTestLimit cfg) then-        -- we've hit the test limit, test was successful-        pure $ Report tests discards OK+        -- we've hit the test limit+        if coverageSuccess tests coverage0 then+          -- all classifiers satisfied, test was successful+          pure $ Report tests discards coverage0 OK +        else+          -- some classifiers unsatisfied, test was successful+          pure . Report tests discards coverage0 . Failed $+            mkFailure+              size+              seed+              0+              (Just coverage0)+              Nothing+              "Insufficient coverage."+              Nothing+              []+       else if discards >= fromIntegral (propertyDiscardLimit cfg) then         -- we've hit the discard limit, give up-        pure $ Report tests discards GaveUp+        pure $ Report tests discards coverage0 GaveUp        else         case Seed.split seed of           (s0, s1) -> do-            node@(Node x _) <--              runTree . runDiscardEffect $ runGenT size s0 . runTestT $ unPropertyT test+            node@(NodeT x _) <-+              runTreeT . evalGenT size s0 . runTestT $ unPropertyT test             case x of               Nothing ->-                loop tests (discards + 1) (size + 1) s1+                loop tests (discards + 1) (size + 1) s1 coverage0                Just (Left _, _) ->                 let                   mkReport =-                    Report (tests + 1) discards+                    Report (tests + 1) discards coverage0                 in                   fmap mkReport $                     takeSmallest@@ -195,10 +221,14 @@                       (updateUI . mkReport)                       node -              Just (Right (), _) ->-                loop (tests + 1) discards (size + 1) s1+              Just (Right (), journal) ->+                let+                  coverage =+                    journalCoverage journal <> coverage0+                in+                  loop (tests + 1) discards (size + 1) s1 coverage   in-    loop 0 0 size0 seed0+    loop 0 0 size0 seed0 mempty  checkRegion ::      MonadIO m@@ -273,6 +303,7 @@     hSetEncoding stdout utf8     hSetEncoding stderr utf8 #endif+     putStrLn $ "━━━ " ++ unGroupName group ++ " ━━━"      verbosity <- resolveVerbosity (runnerVerbosity config)@@ -401,8 +432,3 @@       , runnerVerbosity =           Nothing       }----------------------------------------------------------------------------- FIXME Replace with DeriveLift when we drop 7.10 support.--$(deriveLift ''RunnerConfig)

@@ -18,13 +18,10 @@   , 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@@ -44,25 +41,7 @@     , 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     [] ->@@ -74,10 +53,6 @@         (fromIntegral $ srcLocStartCol x)         (fromIntegral $ srcLocEndLine x)         (fromIntegral $ srcLocEndCol x)-#else-getCaller _ =-  Nothing-#endif  ------------------------------------------------------------------------ -- Show instances

@@ -56,27 +56,27 @@ import           Control.Monad (foldM, foldM_) import           Control.Monad.Catch (MonadCatch) import           Control.Monad.State.Class (MonadState, get, put, modify)+import           Control.Monad.Morph (MFunctor(..)) import           Control.Monad.Trans.Class (lift) import           Control.Monad.Trans.Control (MonadBaseControl) import           Control.Monad.Trans.State (State, runState, execState)-import           Control.Monad.Trans.State (StateT(..), evalStateT)+import           Control.Monad.Trans.State (StateT(..), evalStateT, runStateT)  import           Data.Dynamic (Dynamic, toDyn, fromDynamic, dynTypeRep) import           Data.Foldable (traverse_) import           Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..))-#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           Hedgehog.Internal.Distributive (distributeT)+import           Hedgehog.Internal.Gen (MonadGen, GenT, GenBase) import qualified Hedgehog.Internal.Gen as Gen import           Hedgehog.Internal.HTraversable (HTraversable(..)) import           Hedgehog.Internal.Opaque (Opaque(..))-import           Hedgehog.Internal.Property (MonadTest(..), Test, evalEither, evalM, success, runTest, failWith)+import           Hedgehog.Internal.Property (MonadTest(..), Test, evalEither, evalM, success, runTest, failWith, annotate) import           Hedgehog.Internal.Range (Range) import           Hedgehog.Internal.Show (showPretty) import           Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack)@@ -92,8 +92,18 @@   showsPrec p (Name x) =     showsPrec p x --- | Symbolic values.+-- | Symbolic values: Because hedgehog generates actions in a separate phase+--   before execution, you will sometimes need to refer to the result of a+--   previous action in a generator without knowing the value of the result+--   (e.g., to get the ID of a previously-created user). --+--   Symmbolic variables provide a token to stand in for the actual variables at+--   generation time (and in 'Require'/'Update' callbacks). At execution time,+--   real values are available, so your execute actions work on 'Concrete'+--   variables.+--+--   See also: 'Command', 'Var'+-- data Symbolic a where   Symbolic :: Typeable a => Name -> Symbolic a @@ -104,7 +114,6 @@   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@@ -116,21 +125,11 @@ 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.+-- | Concrete values: At test-execution time, 'Symbolic' values from generation+--   are replaced with 'Concrete' values from performing actions. This type+--   gives us something of the same kind as 'Symbolic' to pass as a type+--   argument to 'Var'. -- newtype Concrete a where   Concrete :: a -> Concrete a@@ -140,7 +139,6 @@   showsPrec =     showsPrec1 -#if MIN_VERSION_transformers(0,5,0) instance Show1 Concrete where   liftShowsPrec sp _ p (Concrete x) =     sp p x@@ -152,20 +150,7 @@ 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@@ -185,7 +170,10 @@ --   type of variable because it is used in both the generation and the --   execution phase. ---data Var a v =+--   The order of arguments makes 'Var' 'HTraverable', which is how 'Symbolic'+--   values are turned into 'Concrete' ones.+--+newtype Var a v =   Var (v a)  -- | Take the value from a concrete variable.@@ -241,6 +229,10 @@ emptyEnvironment =   Environment Map.empty +unionsEnvironment :: [Environment] -> Environment+unionsEnvironment =+  Environment . Map.unions . fmap unEnvironment+ -- | Insert a symbolic / concrete pairing in to the environment. -- insertConcrete :: Symbolic a -> Concrete a -> Environment -> Environment@@ -375,18 +367,24 @@  ------------------------------------------------------------------------ --- | The specification for the expected behaviour of an 'Action'.+-- | The specification for the expected behaviour of an+-- 'Action'. These are used to generate sequences of actions to test. ---data Command n m (state :: (* -> *) -> *) =+-- This is the main type you will use when writing state machine+-- tests. @gen@ is usually an instance of 'MonadGen', and @m@ is usually+-- an instance of 'MonadTest'. These constraints appear when you pass+-- your 'Command' list to 'sequential' or 'parallel'.+--+data Command gen m (state :: (* -> *) -> *) =   forall input output.-  (HTraversable input, Show (input Symbolic), Typeable output) =>+  (HTraversable input, Show (input Symbolic), Show output, Typeable output) =>   Command {     -- | A generator which provides random arguments for a command. If the     --   command cannot be executed in the current state, it should return     --   'Nothing'.     --       commandGen ::-        state Symbolic -> Maybe (n (input Symbolic))+        state Symbolic -> Maybe (gen (input Symbolic))      -- | Executes a command using the arguments generated by 'commandGen'.     --@@ -402,7 +400,7 @@  -- | Checks that input for a command can be executed in the given state. ---commandGenOK :: Command n m state -> state Symbolic -> Bool+commandGenOK :: Command gen m state -> state Symbolic -> Bool commandGenOK (Command inputGen _ _) state =   Maybe.isJust (inputGen state) @@ -411,7 +409,7 @@ -- data Action m (state :: (* -> *) -> *) =   forall input output.-  (HTraversable input, Show (input Symbolic)) =>+  (HTraversable input, Show (input Symbolic), Show output) =>   Action {       actionInput ::         input Symbolic@@ -536,11 +534,11 @@ -- | 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)+     (MonadGen gen, MonadTest m)+  => [Command gen m state]+  -> GenT (StateT (Context state) (GenBase gen)) (Action m state) action commands =-  Gen.just $ do+  Gen.justT $ do     Context state0 _ <- get      Command mgenInput exec callbacks <-@@ -550,8 +548,8 @@       case mgenInput state0 of         Nothing ->           error "genCommand: internal error, tried to use generator with invalid state."-        Just g ->-          lift g+        Just gen ->+          hoist lift $ Gen.toGenT gen      if not $ callbackRequire callbacks state0 input then       pure Nothing@@ -569,13 +567,13 @@           (callbackEnsure callbacks)  genActions ::-     (MonadGen n, MonadTest m)+     (MonadGen gen, MonadTest m)   => Range Int-  -> [Command n m state]+  -> [Command gen m state]   -> Context state-  -> n ([Action m state], Context state)+  -> gen ([Action m state], Context state) genActions range commands ctx = do-  xs <- Gen.list range (action commands) `evalStateT` ctx+  xs <- Gen.fromGenT . (`evalStateT` ctx) . distributeT $ Gen.list range (action commands)   pure $     dropInvalid xs `runState` ctx @@ -603,6 +601,33 @@         (prefix0 ++ x) :         fmap (prefix ++) xs +renderActionResult :: Environment -> Action m state -> [String]+renderActionResult env (Action _ output@(Symbolic (Name name)) _ _ _ _) =+  let+    prefix0 =+      "Var " ++ show name ++ " = "++    prefix =+      replicate (length prefix0) ' '++    unfound = \case+      EnvironmentValueNotFound _+        -> "<<not found in environment>>"+      EnvironmentTypeError _ _+        -> "<<type representation in environment unexpected>>"++    actual =+      either unfound showPretty+        $ reifyEnvironment env output++  in+    case lines actual of+      [] ->+        [prefix0 ++ "?"]+      x : xs ->+        (prefix0 ++ x) :+        fmap (prefix ++) xs+ -- FIXME we should not abuse Show to get nice output for actions instance Show (Sequential m state) where   show (Sequential xs) =@@ -611,11 +636,11 @@ -- | Generates a sequence of actions from an initial model state and set of commands. -- sequential ::-     (MonadGen n, MonadTest m)+     (MonadGen gen, MonadTest m)   => Range Int   -> (forall v. state v)-  -> [Command n m state]-  -> n (Sequential m state)+  -> [Command gen m state]+  -> gen (Sequential m state) sequential range initial commands =   fmap (Sequential . fst) $     genActions range commands (mkContext initial)@@ -636,27 +661,32 @@  -- 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)-      ]+  show =+    renderParallel renderAction +renderParallel :: (Action m state -> [String]) -> Parallel m state -> String+renderParallel render (Parallel pre xs ys) =+  unlines $ concat [+      ["━━━ Prefix ━━━"]+    , concatMap render pre+    , ["", "━━━ Branch 1 ━━━"]+    , concatMap render xs+    , ["", "━━━ Branch 2 ━━━"]+    , concatMap render ys+    ]++ -- | Given the initial model state and set of commands, generates prefix --   actions to be run sequentially, followed by two branches to be run in --   parallel. -- parallel ::-     (MonadGen n, MonadTest m)+     (MonadGen gen, MonadTest m)   => Range Int   -> Range Int   -> (forall v. state v)-  -> [Command n m state]-  -> n (Parallel m state)+  -> [Command gen m state]+  -> gen (Parallel m state) parallel prefixN parallelN initial commands = do   (prefix, ctx0) <- genActions prefixN commands (mkContext initial)   (branch1, ctx1) <- genActions parallelN commands ctx0@@ -792,13 +822,17 @@   => (forall v. state v)   -> Parallel m state   -> m ()-executeParallel initial (Parallel prefix branch1 branch2) =+executeParallel initial p@(Parallel prefix branch1 branch2) =   withFrozenCallStack $ evalM $ do     (s0, env0) <- foldM executeUpdateEnsure (initial, emptyEnvironment) prefix -    (xs, ys) <-+    ((xs, env1), (ys, env2)) <-       Async.concurrently-        (evalStateT (traverse execute branch1) env0)-        (evalStateT (traverse execute branch2) env0)+        (runStateT (traverse execute branch1) env0)+        (runStateT (traverse execute branch2) env0) +    let+      env = unionsEnvironment [env0, env1, env2]++    annotate $ renderParallel (renderActionResult env) p     linearize s0 xs ys

@@ -4,6 +4,7 @@ module Hedgehog.Internal.TH (     TExpQ   , discover+  , discoverPrefix   ) where  import qualified Data.List as List@@ -24,9 +25,12 @@ --   Functions starting with `prop_` are assumed to be properties. -- discover :: TExpQ Group-discover = do+discover = discoverPrefix "prop_"++discoverPrefix :: String -> TExpQ Group+discoverPrefix prefix = do   file <- getCurrentFile-  properties <- Map.toList <$> runIO (readProperties file)+  properties <- Map.toList <$> runIO (readProperties prefix file)    let     startLine =

@@ -1,16 +1,29 @@ {-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- MonadBase module Hedgehog.Internal.Tree (-    Tree(..)-  , Node(..)+    Tree+  , pattern Tree+  , TreeT(..)+  , runTree+  , mapTreeT+  , treeValue+  , treeChildren -  , fromNode+  , Node+  , pattern Node+  , NodeT(..)+  , fromNodeT    , unfold   , unfoldForest@@ -18,228 +31,484 @@   , expand   , prune +  , catMaybes+  , filter+  , filterMaybeT+  , filterT+  , depth+  , interleave+   , render+  , renderT   ) where -import           Control.Applicative (Alternative(..))-import           Control.Monad (MonadPlus(..), ap, join)+import           Control.Applicative (Alternative(..), liftA2)+import           Control.Monad (MonadPlus(..), join) import           Control.Monad.Base (MonadBase(..))+import           Control.Monad.Trans.Control () import           Control.Monad.Catch (MonadThrow(..), MonadCatch(..), Exception) import           Control.Monad.Error.Class (MonadError(..)) import           Control.Monad.IO.Class (MonadIO(..))-import           Control.Monad.Morph (MFunctor(..), MMonad(..))+import           Control.Monad.Morph (MFunctor(..), MMonad(..), generalize) import           Control.Monad.Primitive (PrimMonad(..)) import           Control.Monad.Reader.Class (MonadReader(..)) import           Control.Monad.State.Class (MonadState(..)) import           Control.Monad.Trans.Class (MonadTrans(..))+import           Control.Monad.Trans.Maybe (MaybeT(..)) import           Control.Monad.Trans.Resource (MonadResource(..)) import           Control.Monad.Writer.Class (MonadWriter(..))+import           Control.Monad.Zip (MonadZip(..)) -#if MIN_VERSION_base(4,9,0)+import           Data.Functor.Identity (Identity(..))+import           Data.Functor.Classes (Eq1(..)) import           Data.Functor.Classes (Show1(..), showsPrec1) import           Data.Functor.Classes (showsUnaryWith, showsBinaryWith)-#endif+import qualified Data.Maybe as Maybe  import           Hedgehog.Internal.Distributive +import           Prelude hiding (filter)+ ------------------------------------------------------------------------ +-- | A rose tree.+--+type Tree =+  TreeT Identity++-- | Pattern to ease construction / deconstruction of pure trees.+--+pattern Tree :: NodeT Identity a -> Tree a+pattern Tree node =+  TreeT (Identity node)+{-# COMPLETE Tree #-}+ -- | 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)+newtype TreeT m a =+  TreeT {+      runTreeT :: m (NodeT m a)     } +-- | A node in a rose tree.+--+type Node =+  NodeT Identity+{-# COMPLETE Node #-}++-- | Pattern to ease construction / deconstruction of pure nodes.+--+pattern Node :: a -> [Tree a] -> Node a+pattern Node x xs =+  NodeT x xs+ -- | A node in an effectful tree, as well as its unevaluated children. ---data Node m a =-  Node {+data NodeT m a =+  NodeT {+      -- | The value at this 'NodeT' in the 'TreeT'.       nodeValue :: a-    , nodeChildren :: [Tree m a]-    } --- | Create a 'Tree' from a 'Node'+      -- | The children of this 'NodeT'.+    , nodeChildren :: [TreeT m a]+    } deriving (Eq)++-- | Extracts the 'Node' from a 'Tree'. ---fromNode :: Applicative m => Node m a -> Tree m a-fromNode =-  Tree . pure+runTree :: Tree a -> Node a+runTree =+  runIdentity . runTreeT +-- | Map between 'TreeT' computations.+--+mapTreeT :: (m (NodeT m a) -> m (NodeT m a)) -> TreeT m a -> TreeT m a+mapTreeT f =+  TreeT . f . runTreeT++-- | Create a 'TreeT' from a 'NodeT'+--+fromNodeT :: Applicative m => NodeT m a -> TreeT m a+fromNodeT =+  TreeT . pure++-- | The value at the root of the 'Tree'.+--+treeValue :: Tree a -> a+treeValue =+  nodeValue . runTree++-- | The children of the 'Tree'.+--+treeChildren :: Tree a -> [Tree a]+treeChildren =+  nodeChildren . runTree+ -- | Create a tree from a value and an unfolding function. ---unfold :: Monad m => (a -> [a]) -> a -> Tree m a+unfold :: Monad m => (a -> [a]) -> a -> TreeT m a unfold f x =-  Tree . pure $-    Node x (unfoldForest f x)+  TreeT . pure $+    NodeT x (unfoldForest f x)  -- | Create a forest from a value and an unfolding function. ---unfoldForest :: Monad m => (a -> [a]) -> a -> [Tree m a]+unfoldForest :: Monad m => (a -> [a]) -> a -> [TreeT m a] unfoldForest f =   fmap (unfold f) . f  -- | Expand a tree using an unfolding function. ---expand :: Monad m => (a -> [a]) -> Tree m a -> Tree m a+expand :: Monad m => (a -> [a]) -> TreeT m a -> TreeT m a expand f m =-  Tree $ do-    Node x xs <- runTree m-    pure . Node x $+  TreeT $ do+    NodeT x xs <- runTreeT m+    pure . NodeT x $       fmap (expand f) xs ++ unfoldForest f x --- | Throw away a tree's children.+-- | Throw away @n@ levels of a tree's children. ---prune :: Monad m => Tree m a -> Tree m a-prune m =-  Tree $ do-    Node x _ <- runTree m-    pure $ Node x []+--   /@prune 0@ will throw away all of a tree's children./+--+prune :: Monad m => Int -> TreeT m a -> TreeT m a+prune n m =+  if n <= 0 then+    TreeT $ do+      NodeT x _ <- runTreeT m+      pure $ NodeT x []+  else+    TreeT $ do+      NodeT x xs0 <- runTreeT m+      pure . NodeT x $+        fmap (prune (n - 1)) xs0 +-- | Returns the depth of the deepest leaf node in the tree.+--+depth :: Tree a -> Int+depth m =+  let+    NodeT _ xs =+      runTree m++    n =+      if null xs then+        0+      else+        maximum (fmap depth xs)+  in+    1 + n++-- | Takes a tree of 'Maybe's and returns a tree of all the 'Just' values.+--+--   If the root of the tree is 'Nothing' then 'Nothing' is returned.+--+catMaybes :: Tree (Maybe a) -> Maybe (Tree a)+catMaybes m =+  let+    NodeT mx mxs =+      runTree m+  in+    case mx of+      Nothing -> do+        case Maybe.mapMaybe catMaybes mxs of+          [] ->+            Nothing+          Tree (NodeT x xs0) : xs1 ->+            Just . Tree $+              Node x (xs0 ++ xs1)+      Just x ->+        Just . Tree $+          Node x (Maybe.mapMaybe catMaybes mxs)++-- | Returns a tree containing only elements that match the predicate.+--+--   If the root of the tree does not match the predicate then 'Nothing' is+--   returned.+--+filter :: (a -> Bool) -> Tree a -> Maybe (Tree a)+filter p =+  catMaybes .+  runTreeMaybeT .+  filterMaybeT p .+  hoist lift++runTreeMaybeT :: Monad m => TreeT (MaybeT m) a -> TreeT m (Maybe a)+runTreeMaybeT =+  runMaybeT .+  distributeT++-- | Returns a tree containing only elements that match the predicate.+--+--   If the root of the tree does not match the predicate then 'Nothing' is+--   returned.+--+filterMaybeT :: (a -> Bool) -> TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) a+filterMaybeT p t =+  case runTreeMaybeT t of+    Tree (Node Nothing _) ->+      TreeT . MaybeT . Identity $ Nothing+    Tree (Node (Just x) xs) ->+      hoist generalize $+        Tree . Node x $+          concatMap (flattenTree (maybe False p)) xs++flattenTree :: (Maybe a -> Bool) -> Tree (Maybe a) -> [Tree a]+flattenTree p (Tree (Node mx mxs0)) =+  let+    mxs =+      concatMap (flattenTree p) mxs0+  in+    if p mx then+      case mx of+        Nothing ->+          []+        Just x ->+          [Tree (Node x mxs)]+    else+      mxs++-- | Returns a tree containing only elements that match the predicate.+--+--   When an element does not match the predicate its node is replaced with+--   'empty'.+--+filterT :: (Monad m, Alternative m) => (a -> Bool) -> TreeT m a -> TreeT m a+filterT p m =+  TreeT $ do+    NodeT x xs <- runTreeT m+    if p x then+      pure $+        NodeT x (fmap (filterT p) xs)+    else+      empty+ --------------------------------------------------------------------------- Node/Tree instances -instance Functor m => Functor (Node m) where-  fmap f (Node x xs) =-    Node (f x) (fmap (fmap f) xs)+-- | All ways a list can be split+--+-- > splits [1,2,3]+-- > ==+-- > [ ([], 1, [2, 3])+--   , ([1], 2, [3])+--   , ([1, 2], 3, [])+--   ]+--+splits :: [a] -> [([a], a, [a])]+splits = \case+  [] ->+    []+  x : xs ->+    ([], x, xs) :+    fmap (\(as, b, cs) -> (x : as, b, cs)) (splits xs) -instance Functor m => Functor (Tree m) where+dropOne :: Monad m => [NodeT m a] -> [TreeT m [a]]+dropOne ts = do+  (xs, _y, zs) <- splits ts+  pure . TreeT . pure $+    interleave (xs ++ zs)++shrinkOne :: Monad m => [NodeT m a] -> [TreeT m [a]]+shrinkOne ts = do+  (xs, y0, zs) <- splits ts+  y1 <- nodeChildren y0+  pure . TreeT $ do+    y2 <- runTreeT y1+    pure $+      interleave (xs ++ [y2] ++ zs)++interleave :: forall m a. Monad m => [NodeT m a] -> NodeT m [a]+interleave ts =+  NodeT (fmap nodeValue ts) $+    concat [+        dropOne ts+      , shrinkOne ts+      ]++------------------------------------------------------------------------++instance Foldable Tree where+  foldMap f (TreeT mx) =+    foldMap f (runIdentity mx)++instance Foldable Node where+  foldMap f (NodeT x xs) =+    f x `mappend` mconcat (fmap (foldMap f) xs)++instance Traversable Tree where+  traverse f (TreeT mx) =+    TreeT <$> traverse (traverse f) mx++instance Traversable Node where+  traverse f (NodeT x xs) =+    NodeT <$> f x <*> traverse (traverse f) xs++------------------------------------------------------------------------+-- NodeT/TreeT instances++instance (Eq1 m, Eq a) => Eq (TreeT m a) where+  TreeT m0 == TreeT m1 =+    liftEq (==) m0 m1++instance Functor m => Functor (NodeT m) where+  fmap f (NodeT x xs) =+    NodeT (f x) (fmap (fmap f) xs)++instance Functor m => Functor (TreeT m) where   fmap f =-    Tree . fmap (fmap f) . runTree+    TreeT . fmap (fmap f) . runTreeT -instance Monad m => Applicative (Node m) where-  pure =-    return-  (<*>) =-    ap+instance Applicative m => Applicative (NodeT m) where+  pure x =+    NodeT x []+  (<*>) (NodeT ab tabs) na@(NodeT a tas) =+    NodeT (ab a) $+      map (<*> (fromNodeT na)) tabs ++ map (fmap ab) tas -instance Monad m => Applicative (Tree m) where+instance Applicative m => Applicative (TreeT m) where   pure =-    return-  (<*>) =-    ap+    TreeT . pure . pure+  (<*>) (TreeT mab) (TreeT ma) =+    TreeT $+      liftA2 (<*>) mab ma -instance Monad m => Monad (Node m) where-  return x =-    Node x []+instance Monad m => Monad (NodeT m) where+  return =+    pure -  (>>=) (Node x xs) k =+  (>>=) (NodeT x xs) k =     case k x of-      Node y ys ->-        Node y $-          fmap (Tree . fmap (>>= k) . runTree) xs ++ ys+      NodeT y ys ->+        NodeT y $+          fmap (TreeT . fmap (>>= k) . runTreeT) xs ++ ys -instance Monad m => Monad (Tree m) where-  return x =-    Tree . pure $ Node x []+instance Monad m => Monad (TreeT m) where+  return =+    pure    (>>=) m k =-    Tree $ do-      Node x xs <- runTree m-      Node y ys <- runTree (k x)-      pure . Node y $+    TreeT $ do+      NodeT x xs <- runTreeT m+      NodeT y ys <- runTreeT (k x)+      pure . NodeT y $         fmap (>>= k) xs ++ ys -instance MonadPlus m => Alternative (Tree m) where+instance Alternative m => Alternative (TreeT m) where   empty =-    mzero-  (<|>) =-    mplus+    TreeT empty+  (<|>) x y =+    TreeT (runTreeT x <|> runTreeT y) -instance MonadPlus m => MonadPlus (Tree m) where+instance MonadPlus m => MonadPlus (TreeT m) where   mzero =-    Tree mzero+    TreeT mzero   mplus x y =-    Tree (runTree x `mplus` runTree y)+    TreeT (runTreeT x `mplus` runTreeT y) -instance MonadTrans Tree where-  lift m =-    Tree $ do-      x <- m-      pure (Node x [])+zipTreeT :: forall f a b. Applicative f => TreeT f a -> TreeT f b -> TreeT f (a, b)+zipTreeT l0@(TreeT left) r0@(TreeT right) =+  TreeT $+    let+      zipNodeT :: NodeT f a -> NodeT f b -> NodeT f (a, b)+      zipNodeT (NodeT a ls) (NodeT b rs) =+          NodeT (a, b) $+            concat [+                [zipTreeT l1 r0 | l1 <- ls]+              , [zipTreeT l0 r1 | r1 <- rs]+              ]+    in+      zipNodeT <$> left <*> right -instance MFunctor Node where-  hoist f (Node x xs) =-    Node x (fmap (hoist f) xs)+instance Monad m => MonadZip (TreeT m) where+  mzip =+    zipTreeT -instance MFunctor Tree where-  hoist f (Tree m) =-    Tree . f $ fmap (hoist f) m+instance MonadTrans TreeT where+  lift f =+    TreeT $+      fmap (\x -> NodeT x []) f -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)+instance MFunctor NodeT where+  hoist f (NodeT x xs) =+    NodeT x (fmap (hoist 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 MFunctor TreeT where+  hoist f (TreeT m) =+    TreeT . f $ fmap (hoist f) m -instance MMonad Tree where+embedNodeT :: Monad m => (t (NodeT t b) -> TreeT m (NodeT t b)) -> NodeT t b -> NodeT m b+embedNodeT f (NodeT x xs) =+  NodeT x (fmap (embedTreeT f) xs)++embedTreeT :: Monad m => (t (NodeT t b) -> TreeT m (NodeT t b)) -> TreeT t b -> TreeT m b+embedTreeT f (TreeT m) =+  TreeT . pure . embedNodeT f =<< f m++instance MMonad TreeT where   embed f m =-    embedTree f m+    embedTreeT 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+distributeNodeT :: Transformer t TreeT m => NodeT (t m) a -> t (TreeT m) a+distributeNodeT (NodeT x xs) =+  join . lift . fromNodeT . NodeT (pure x) $+    fmap (pure . distributeTreeT) xs -distributeTree :: Transformer t Tree m => Tree (t m) a -> t (Tree m) a-distributeTree x =-  distributeNode =<< hoist lift (runTree x)+distributeTreeT :: Transformer t TreeT m => TreeT (t m) a -> t (TreeT m) a+distributeTreeT x =+  distributeNodeT =<< hoist lift (runTreeT x) -instance Distributive Tree where-  distribute =-    distributeTree+instance MonadTransDistributive TreeT where+  distributeT =+    distributeTreeT -instance PrimMonad m => PrimMonad (Tree m) where-  type PrimState (Tree m) =+instance PrimMonad m => PrimMonad (TreeT m) where+  type PrimState (TreeT m) =     PrimState m   primitive =     lift . primitive -instance MonadIO m => MonadIO (Tree m) where+instance MonadIO m => MonadIO (TreeT m) where   liftIO =     lift . liftIO -instance MonadBase b m => MonadBase b (Tree m) where+instance MonadBase b m => MonadBase b (TreeT m) where   liftBase =     lift . liftBase -instance MonadThrow m => MonadThrow (Tree m) where+instance MonadThrow m => MonadThrow (TreeT 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+handleNodeT :: (Exception e, MonadCatch m) => (e -> TreeT m a) -> NodeT m a -> NodeT m a+handleNodeT onErr (NodeT x xs) =+  NodeT x $+    fmap (handleTreeT onErr) xs -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)+handleTreeT :: (Exception e, MonadCatch m) => (e -> TreeT m a) -> TreeT m a -> TreeT m a+handleTreeT onErr m =+  TreeT . fmap (handleNodeT onErr) $+    catch (runTreeT m) (runTreeT . onErr) -instance MonadCatch m => MonadCatch (Tree m) where+instance MonadCatch m => MonadCatch (TreeT m) where   catch =-    flip handleTree+    flip handleTreeT -localNode :: MonadReader r m => (r -> r) -> Node m a -> Node m a-localNode f (Node x xs) =-  Node x $-    fmap (localTree f) xs+localNodeT :: MonadReader r m => (r -> r) -> NodeT m a -> NodeT m a+localNodeT f (NodeT x xs) =+  NodeT x $+    fmap (localTreeT 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+localTreeT :: MonadReader r m => (r -> r) -> TreeT m a -> TreeT m a+localTreeT f (TreeT m) =+  TreeT $+    pure . localNodeT f =<< local f m -instance MonadReader r m => MonadReader r (Tree m) where+instance MonadReader r m => MonadReader r (TreeT m) where   ask =     lift ask   local =-    localTree+    localTreeT -instance MonadState s m => MonadState s (Tree m) where+instance MonadState s m => MonadState s (TreeT m) where   get =     lift get   put =@@ -247,72 +516,71 @@   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+listenNodeT :: MonadWriter w m => w -> NodeT m a -> NodeT m (a, w)+listenNodeT w (NodeT x xs) =+  NodeT (x, w) $+    fmap (listenTreeT w) xs -listenTree :: MonadWriter w m => w -> Tree m a -> Tree m (a, w)-listenTree w0 (Tree m) =-  Tree $ do+listenTreeT :: MonadWriter w m => w -> TreeT m a -> TreeT m (a, w)+listenTreeT w0 (TreeT m) =+  TreeT $ do     (x, w) <- listen m-    pure $ listenNode (mappend w0 w) x+    pure $ listenNodeT (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+passNodeT :: MonadWriter w m => NodeT m (a, w -> w) -> NodeT m a+passNodeT (NodeT (x, _) xs) =+  NodeT x $+    fmap passTreeT xs -passTree :: MonadWriter w m => Tree m (a, w -> w) -> Tree m a-passTree (Tree m) =-  Tree $-    pure . passNode =<< m+passTreeT :: MonadWriter w m => TreeT m (a, w -> w) -> TreeT m a+passTreeT (TreeT m) =+  TreeT $+    pure . passNodeT =<< m -instance MonadWriter w m => MonadWriter w (Tree m) where+instance MonadWriter w m => MonadWriter w (TreeT m) where   writer =     lift . writer   tell =     lift . tell   listen =-    listenTree mempty+    listenTreeT mempty   pass =-    passTree+    passTreeT -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+handleErrorNodeT :: MonadError e m => (e -> TreeT m a) -> NodeT m a -> NodeT m a+handleErrorNodeT onErr (NodeT x xs) =+  NodeT x $+    fmap (handleErrorTreeT onErr) xs -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)+handleErrorTreeT :: MonadError e m => (e -> TreeT m a) -> TreeT m a -> TreeT m a+handleErrorTreeT onErr m =+  TreeT . fmap (handleErrorNodeT onErr) $+    catchError (runTreeT m) (runTreeT . onErr) -instance MonadError e m => MonadError e (Tree m) where+instance MonadError e m => MonadError e (TreeT m) where   throwError =     lift . throwError   catchError =-    flip handleErrorTree+    flip handleErrorTreeT -instance MonadResource m => MonadResource (Tree m) where+instance MonadResource m => MonadResource (TreeT 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+instance (Show1 m, Show a) => Show (NodeT m a) where   showsPrec =     showsPrec1 -instance (Show1 m, Show a) => Show (Tree m a) where+instance (Show1 m, Show a) => Show (TreeT m a) where   showsPrec =     showsPrec1 -instance Show1 m => Show1 (Node m) where-  liftShowsPrec sp sl d (Node x xs) =+instance Show1 m => Show1 (NodeT m) where+  liftShowsPrec sp sl d (NodeT x xs) =     let       sp1 =         liftShowsPrec sp sl@@ -323,10 +591,10 @@       sp2 =         liftShowsPrec sp1 sl1     in-      showsBinaryWith sp sp2 "Node" d x xs+      showsBinaryWith sp sp2 "NodeT" d x xs -instance Show1 m => Show1 (Tree m) where-  liftShowsPrec sp sl d (Tree m) =+instance Show1 m => Show1 (TreeT m) where+  liftShowsPrec sp sl d (TreeT m) =     let       sp1 =         liftShowsPrec sp sl@@ -337,8 +605,7 @@       sp2 =         liftShowsPrec sp1 sl1     in-      showsUnaryWith sp2 "Tree" d m-#endif+      showsUnaryWith sp2 "TreeT" d m  ------------------------------------------------------------------------ -- Pretty Printing@@ -347,22 +614,22 @@ -- 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+renderTreeTLines :: Monad m => TreeT m String -> m [String]+renderTreeTLines (TreeT m) = do+  NodeT x xs0 <- m   xs <- renderForestLines xs0   pure $-    lines (renderNode x) ++ xs+    lines (renderNodeT x) ++ xs -renderNode :: String -> String-renderNode xs =+renderNodeT :: String -> String+renderNodeT xs =   case xs of     [_] ->       ' ' : xs     _ ->       xs -renderForestLines :: Monad m => [Tree m String] -> m [String]+renderForestLines :: Monad m => [TreeT m String] -> m [String] renderForestLines xs0 =   let     shift hd other =@@ -373,18 +640,25 @@         pure []        [x] -> do-        s <- renderTreeLines x+        s <- renderTreeTLines x         pure $           shift " └╼" "   " s        x : xs -> do-        s <- renderTreeLines x+        s <- renderTreeTLines x         ss <- renderForestLines xs         pure $           shift " ├╼" " │ " s ++ ss +-- | Render a tree of strings.+--+render :: Tree String -> String+render =+  runIdentity . renderT+ -- | Render a tree of strings, note that this forces all the delayed effects in --   the tree.-render :: Monad m => Tree m String -> m String-render =-  fmap unlines . renderTreeLines+--+renderT :: Monad m => TreeT m String -> m String+renderT =+  fmap unlines . renderTreeTLines

@@ -3,13 +3,24 @@     tripping   ) where -import           Hedgehog.Internal.Property-import           Hedgehog.Internal.Show-import           Hedgehog.Internal.Source+import           Hedgehog.Internal.Property (MonadTest, Diff(..), success, failWith)+import           Hedgehog.Internal.Show (valueDiff, mkValue, showPretty)+import           Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack)   -- | Test that a pair of encode / decode functions are compatible. --+-- Given a printer from some type 'a -> b', and a parser with a+-- potential failure case 'b -> f a'. Ensure that a valid 'a' round+-- trips through the "print" and "parse" to yield the same 'a'.+--+-- For example, types __should__ have tripping 'Read' and 'Show'+-- instances.+--+-- @+-- trippingShowRead :: (Show a, Read a, Eq a, MonadTest m) => a -> m ()+-- trippingShowRead a = tripping a show readEither+-- @ tripping ::      (MonadTest m, Applicative f, Show b, Show (f a), Eq (f a), HasCallStack)   => a@@ -45,7 +56,8 @@         Just diff ->           withFrozenCallStack $             failWith-              (Just $ Diff "━━━ " "- Original" "/" "+ Roundtrip" " ━━━" diff) $+              (Just $+                Diff "━━━ " "- Original" ") (" "+ Roundtrip" " ━━━" diff) $               unlines [                   "━━━ Intermediate ━━━"                 , showPretty i

@@ -0,0 +1,20 @@+{-# LANGUAGE CPP #-}+module Hedgehog.Main (+  -- * Running tests+    defaultMain+  ) where++import           Control.Monad (unless)++import           System.Exit (exitFailure)+import           System.IO (BufferMode (LineBuffering), hSetBuffering, stderr, stdout)++-- | An entry point that can be used as a main function.+--+defaultMain :: [IO Bool] -> IO ()+defaultMain tests = do+  hSetBuffering stdout LineBuffering+  hSetBuffering stderr LineBuffering+  result <- and <$> sequence tests+  unless result+    exitFailure

@@ -0,0 +1,97 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+module Test.Hedgehog.Applicative where++import           Control.Monad.Morph (hoist)+import           Control.Monad.State.Class (MonadState(..), modify)+import qualified Control.Monad.Trans.State.Lazy as Lazy++import           Data.Foldable (traverse_)+import qualified Data.List as List+import qualified Data.Map as Map++import           Hedgehog hiding (Command, Var)+import qualified Hedgehog.Range as Range++import qualified Hedgehog.Internal.Gen as Gen+import qualified Hedgehog.Internal.Tree as Tree+++newtype Var =+  Var Int+  deriving (Eq, Ord, Show)++data Command =+    Add+  | Remove+    deriving (Eq, Ord, Show)++data a :<- b =+  a :<- b+  deriving (Eq, Ord, Show)++takeVar :: a :<- b -> a+takeVar (var :<- _) =+  var++genVar :: (MonadState Int m, MonadGen m) => m Var+genVar = do+  modify (+1)+  Var <$> get++genCommand :: MonadGen m => m Command+genCommand =+  Gen.element [Add, Remove]++genCommands :: (MonadState Int m, MonadGen m) => m [Var :<- Command]+genCommands =+  Gen.list (Range.constant 0 3) $ do+    var <- genVar+    cmd <- genCommand+    pure $+      var :<- cmd++-- | Uncomment to observe invalid Applicative behaviour+--+--   /This actually also works, if you comment out the ApplicativeDo above./+--+xprop_StateT_inside :: Property+xprop_StateT_inside =+  propVars $ hoist (`Lazy.evalStateT` 0) genCommands++prop_StateT_outside :: Property+prop_StateT_outside =+  propVars . (`Lazy.evalStateT` 0) $ distributeT genCommands++propVars :: Gen [Var :<- Command] -> Property+propVars gen =+  property $ do+    let++    tree <-+      forAllWith (Tree.render . fmap show . Tree.prune 3) $+        Gen.toTree gen++    let+      noDuplicates xs =+        let+          sorted =+            List.sort xs++          unique =+            Map.elems (Map.fromList (fmap (\x -> (takeVar x, x)) xs))++          varsEq ys zs =+            fmap takeVar ys ==+            fmap takeVar zs+        in+          diff sorted varsEq unique++    traverse_ noDuplicates tree++tests :: IO Bool+tests =+  checkParallel $$(discover)

@@ -0,0 +1,97 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+module Test.Hedgehog.Filter where++import           Data.Foldable (toList)+import qualified Data.Set as Set++import           Hedgehog+import qualified Hedgehog.Range as Range++import qualified Hedgehog.Internal.Gen as Gen+import           Hedgehog.Internal.Tree (NodeT(..))+import qualified Hedgehog.Internal.Tree as Tree++-- | Prevent this bug from returning:+--+--   https://stackoverflow.com/questions/54412108/why-the-does-this-shrink-tree-looks-the-way-it-does-when-using-filter+--+--   I'm trying to understand what is the effect that filter has in the shrink+--   tree of a generator when using _integrated shrinking_.+--+--   Consider the following function:+--+-- @+--   {-# LANGUAGE OverloadedStrings #-}+--+--   import Hedgehog+--   import qualified Hedgehog.Gen as Gen+--+--   genChar:: Gen Char+--   genChar =+--     Gen.filter (`elem` ("x" :: String)) (Gen.element "yx")+--+-- @+--+--   When a print the shrink tree:+--+-- @+--   >>>  Gen.printTree genChar+-- @+--+--   I'd get shrink trees that look as follow:+--+-- @+--   'x'+--    └╼'x'+--       └╼'x'+--          └╼'x'+--                  ...+--+--                      └╼<discard>+-- @+--+--   This is, a very deep tree containing only @x@'s, and a @discard@ at the+--   end.+--+prop_filter_repetition :: Property+prop_filter_repetition =+  property $ do+    let+      genChar:: Gen Char+      genChar =+        Gen.filter (`elem` ("x" :: String)) (Gen.element "yx")++    tree <- forAllWith (Tree.render . fmap show . Tree.prune 10) (Gen.toTree genChar)+    Tree.depth tree === 1++prop_filter_even :: Property+prop_filter_even =+  property $ do+    let+      genEven :: Gen Int+      genEven =+        Gen.filter even (Gen.int (Range.constant 0 8))++    tree <- forAllWith (Tree.render . fmap show . Tree.prune 5) (Gen.toTree genEven)++    let+      NodeT x _ =+        Tree.runTree tree++      required =+        Set.fromList (filter even [0..x])++      actual =+        Set.fromList (toList tree)++      missing =+        required `Set.difference` actual++    annotateShow missing+    required === actual++tests :: IO Bool+tests =+  checkParallel $$(discover)

@@ -0,0 +1,62 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+module Test.Hedgehog.Zip where++import           Control.Monad.Zip (mzip)++import           Data.Maybe (fromJust)++import           Hedgehog+import qualified Hedgehog.Range as Range++import qualified Hedgehog.Internal.Gen as Gen+import qualified Hedgehog.Internal.Shrink as Shrink+import           Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack)+import           Hedgehog.Internal.Tree (Tree)+import qualified Hedgehog.Internal.Tree as Tree+++mkTree :: Int -> Tree Int+mkTree n =+  Tree.expand (Shrink.towards 0) (pure n)++mkGen :: Int -> Gen Int+mkGen =+  Gen.fromTree . mkTree++render :: Show a => HasCallStack => Tree a -> PropertyT IO ()+render x =+  withFrozenCallStack $ do+    annotate . Tree.render $ fmap show x++prop_gen_applicative :: Property+prop_gen_applicative =+  property $ do+    let+      treeApplicative n m =+        (,) <$> mkTree n <*> mkTree m++      treeZip n m =+        mzip (mkTree n) (mkTree m)++      genApplicative n m =+        fromJust .+        Gen.evalGen 0 (Seed 0 0) $+          (,) <$> mkGen n <*> mkGen m++    n <- forAll $ Gen.int (Range.constant 1 5)+    m <- forAll $ Gen.int (Range.constant 1 5)++    render $ genApplicative n m+    render $ treeZip n m+    render $ treeApplicative n m++    genApplicative n m === treeZip n m+    genApplicative n m /== treeApplicative n m++    success++tests :: IO Bool+tests =+  checkParallel $$(discover)

@@ -1,20 +1,18 @@-import           Control.Monad (unless)-import           System.IO (BufferMode(..), hSetBuffering, stdout, stderr)-import           System.Exit (exitFailure)+import           Hedgehog.Main (defaultMain) +import qualified Test.Hedgehog.Applicative+import qualified Test.Hedgehog.Filter import qualified Test.Hedgehog.Seed import qualified Test.Hedgehog.Text+import qualified Test.Hedgehog.Zip   main :: IO ()-main = do-  hSetBuffering stdout LineBuffering-  hSetBuffering stderr LineBuffering--  results <- sequence [-      Test.Hedgehog.Text.tests+main =+  defaultMain [+      Test.Hedgehog.Applicative.tests+    , Test.Hedgehog.Filter.tests     , Test.Hedgehog.Seed.tests+    , Test.Hedgehog.Text.tests+    , Test.Hedgehog.Zip.tests     ]--  unless (and results) $-    exitFailure