hedgehog 0.4.1 → 0.5

raw patch · 15 files changed

+1665/−736 lines, 15 filesdep +lifted-asyncdep +monad-controldep ~ansi-terminaldep ~concurrent-outputPVP ok

version bump matches the API change (PVP)

Dependencies added: lifted-async, monad-control

Dependency ranges changed: ansi-terminal, concurrent-output

API changes (from Hackage documentation)

Files

• CHANGELOG.md +76/−21
• README.md +2/−1
• hedgehog.cabal +4/−2
• src/Hedgehog.hs +62/−41
• src/Hedgehog/Gen.hs +6/−5
• src/Hedgehog/Internal/Exception.hs +10/−29
• src/Hedgehog/Internal/Gen.hs +535/−218
• src/Hedgehog/Internal/Opaque.hs +4/−2
• src/Hedgehog/Internal/Property.hs +484/−238
• src/Hedgehog/Internal/Queue.hs +1/−1
• src/Hedgehog/Internal/Region.hs +63/−46
• src/Hedgehog/Internal/Runner.hs +33/−21
• src/Hedgehog/Internal/State.hs +376/−97
• src/Hedgehog/Internal/Tripping.hs +2/−7
• test/Test/Hedgehog/Text.hs +7/−7

@@ -1,38 +1,93 @@+## Version 0.5 (2017-07-16)++- Parallel state machine testing, allows detection of commands which are not-atomic ([#98][98], [@jystic][jystic])+- Easier to use variables for state machine testing ([#94][94], [@jystic][jystic])+- `MonadGen` class allows the use of transformers like `ReaderT` and `StateT` on the outside of generators ([#99][99], [@jystic][jystic])+- Better error messages for tests which throw exceptions ([#95][95], [@jystic][jystic])+- Separated test input generation and assertions in to `PropertyT` and `TestT` respectively, this allows `TestT` to have a `MonadBaseControl` instance ([#96][96], [@jystic][jystic])+- This document grew links to the pull requests which introduced various changes ([#93][93], [@moodmosaic][moodmosaic])+ ## Version 0.4.1 (2017-06-28) -- Fixed runtime type error that could occur when shrinking state machine commands (#91, @jystic)+- Fixed runtime type error that could occur when shrinking state machine commands ([#91][91], [@jystic][jystic])  ## Version 0.4 (2017-06-28) -- Abstract state machine testing, check out 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, @jystic)-- `liftCatch`, `liftCatchIO`, `withCatch` functions for isolating exceptions during tests (#89, @jystic)+- Abstract state machine testing, check out the Tim Humphries' great [blog post](http://teh.id.au/posts/2017/07/15/state-machine-testing) or the [process registry example](https://github.com/hedgehogqa/haskell-hedgehog/blob/master/hedgehog-example/test/Test/Example/Registry.hs) to see how it works ([#89][89], [@jystic][jystic])+- `liftCatch`, `liftCatchIO`, `withCatch` functions for isolating exceptions during tests ([#89][89], [@jystic][jystic])  ## Version 0.3 (2017-06-11) -- Exponential range combinators (#43, @chris-martin)-- Roundtrip example, check out the [blog post](http://teh.id.au/posts/2017/06/07/round-trip-property/) (#85, @thumphries)-- `tripping` now displays intermediate value (#85, @jystic)-- `distribute` function for pulling a transformer out to the top level (#83, @jystic)-- `withExceptT` function for executing tests with an inner `ExceptT` (e.g. `Test (ExceptT x m) a`) (#83, @jystic)+- Exponential range combinators ([#43][43], [@chris-martin][chris-martin])+- Roundtrip example, check out the [blog post](http://teh.id.au/posts/2017/06/07/round-trip-property/) ([#85][85], [@thumphries][thumphries])+- `tripping` now displays intermediate value ([#85][85], [@jystic][jystic])+- `distribute` function for pulling a transformer out to the top level ([#83][83], [@jystic][jystic])+- `withExceptT` function for executing tests with an inner `ExceptT` (e.g. `Test (ExceptT x m) a`) ([#83][83], [@jystic][jystic])  ## Version 0.2.2 (2017-05-16) -- Fixed scope of `unicode` character generators (#76, @moodmosaic)-- Widen version bounds for some dependencies (#80, @amarpotghan)-- Expose test modules to fix build on nix / hydra (#78, @amarpotghan)-- Fixes for GHC 8.2 RC2 (#77, @erikd)+- Fixed scope of `unicode` character generators ([#76][76], [@moodmosaic][moodmosaic])+- Widen version bounds for some dependencies ([#80][80], [@amarpotghan][amarpotghan])+- Expose test modules to fix build on nix / hydra ([#78][78], [@amarpotghan][amarpotghan])+- Fixes for GHC 8.2 RC2 ([#77][77], [@erikd][erikd])  ## Version 0.2.1 (2017-05-09) -- Added `ascii`, `latin1`, `unicode` character generators (#73, @jystic)+- Added `ascii`, `latin1`, `unicode` character generators ([#73][73], [@jystic][jystic])  ## Version 0.2 (2017-05-06) -- Added a quiet test runner which can be activated by setting `HEDGEHOG_VERBOSITY=0` (@jystic)-- Concurrent test runner does not display tests until they are executing (@jystic)-- Test runner now outputs a summary of how many successful / failed tests were run (@jystic)-- `checkSequential` and `checkParallel` now allow for tests to be run without Template Haskell (@jystic)-- Auto-discovery of properties is now available via `discover` instead of being baked in (@jystic)-- `annotate` allows source code to be annotated inline with extra information (@jystic)-- `forAllWith` can be used to generate values without a `Show` instance (@jystic)-- Removed uses of `Typeable` to allow for generating types which cannot implement it (@jystic)+- 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])++[jystic]:+  https://github.com/jystic+[chris-martin]:+  https://github.com/chris-martin+[thumphries]:+  https://github.com/thumphries+[moodmosaic]:+  https://github.com/moodmosaic+[amarpotghan]:+  https://github.com/amarpotghan+[erikd]:+  https://github.com/erikd++[99]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/99+[98]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/98+[96]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/96+[95]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/95+[94]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/94+[93]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/93+[91]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/91+[89]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/89+[85]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/85+[83]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/83+[80]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/80+[78]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/78+[77]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/77+[76]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/76+[73]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/73+[43]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/43

@@ -12,6 +12,7 @@ ## Features  - Integrated shrinking, shrinks obey invariants by construction.+- Abstract state machine testing. - Generators allow monadic effects. - Range combinators for full control over the scope of generated numbers and collections. - Equality and roundtrip assertions show a diff instead of the two inequal values.@@ -76,7 +77,7 @@ ```   [hackage]: http://hackage.haskell.org/package/hedgehog- [hackage-shield]: https://img.shields.io/badge/hackage-v0.4.1-blue.svg+ [hackage-shield]: https://img.shields.io/badge/hackage-v0.5-blue.svg   [travis]: https://travis-ci.org/hedgehogqa/haskell-hedgehog  [travis-shield]: https://travis-ci.org/hedgehogqa/haskell-hedgehog.svg?branch=master

@@ -1,7 +1,7 @@ name:   hedgehog version:-  0.4.1+  0.5 license:   BSD3 author:@@ -50,11 +50,13 @@     , ansi-terminal                   >= 0.6        && < 0.7     , async                           >= 2.0        && < 2.2     , bytestring                      >= 0.10       && < 0.11-    , concurrent-output               >= 1.7        && < 2.0+    , concurrent-output               >= 1.7        && < 1.11     , containers                      >= 0.4        && < 0.6     , directory                       >= 1.2        && < 1.4     , exceptions                      >= 0.7        && < 0.9+    , lifted-async                    >= 0.7        && < 0.10     , mmorph                          >= 1.0        && < 1.2+    , monad-control                   >= 1.0        && < 1.1     , mtl                             >= 2.1        && < 2.3     , pretty-show                     >= 1.6        && < 1.7     , primitive                       >= 0.6        && < 0.7

@@ -44,26 +44,20 @@ -- >   ✓ prop_reverse passed 100 tests. -- module Hedgehog (-    Group(..)-  , GroupName-  , Property+  -- * Properties+    Property+  , PropertyT+  , Group(..)   , PropertyName-  , Test-  , TestLimit-  , DiscardLimit-  , ShrinkLimit--  , Gen-  , Range-  , Size(..)-  , Seed(..)+  , GroupName -  -- * Property   , property-  , withTests-  , withDiscards-  , withShrinks+  , test +  , forAll+  , forAllWith+  , discard+   , check   , recheck @@ -71,39 +65,62 @@   , checkParallel   , checkSequential -  -- * Test-  , forAll-  , forAllWith+  , withTests+  , TestLimit++  , withDiscards+  , DiscardLimit++  , withShrinks+  , ShrinkLimit++  , withRetries+  , ShrinkRetries++  -- * Generating Test Data+  , Gen+  , GenT+  , MonadGen(..)++  , Range+  , Size(..)+  , Seed(..)++  -- * Tests+  , Test+  , TestT+  , MonadTest(..)   , annotate   , annotateShow   , footnote   , footnoteShow   , success-  , discard   , failure   , assert   , (===)--  , liftCatch-  , liftCatchIO-  , liftEither-  , liftExceptT--  , withCatch-  , withExceptT-  , withResourceT-   , tripping -  -- * Abstract State Machine+  , eval+  , evalM+  , evalIO+  , evalEither+  , evalExceptT++  -- * State Machine Tests   , Command(..)   , Callback(..)   , Action+  , Sequential(..)+  , Parallel(..)   , executeSequential+  , executeParallel +  , Var(..)+  , concrete+  , opaque++  , Symbolic   , Concrete(..)-  , Symbolic(..)-  , Var   , Opaque(..)    -- * Transformers@@ -125,26 +142,30 @@ import           Data.Functor.Classes (Eq1, eq1, Ord1, compare1, Show1, showsPrec1)  import           Hedgehog.Internal.Distributive (Distributive(..))-import           Hedgehog.Internal.Gen (Gen)+import           Hedgehog.Internal.Gen (Gen, GenT, MonadGen(..)) import           Hedgehog.Internal.HTraversable (HTraversable(..)) import           Hedgehog.Internal.Opaque (Opaque(..)) import           Hedgehog.Internal.Property (annotate, annotateShow) import           Hedgehog.Internal.Property (assert, (===)) import           Hedgehog.Internal.Property (discard, failure, success) import           Hedgehog.Internal.Property (DiscardLimit, withDiscards)+import           Hedgehog.Internal.Property (eval, evalM, evalIO)+import           Hedgehog.Internal.Property (evalEither, evalExceptT) import           Hedgehog.Internal.Property (footnote, footnoteShow) import           Hedgehog.Internal.Property (forAll, forAllWith)-import           Hedgehog.Internal.Property (liftCatch, liftCatchIO, liftEither, liftExceptT)-import           Hedgehog.Internal.Property (Property, PropertyName, Group(..), GroupName)+import           Hedgehog.Internal.Property (MonadTest(..))+import           Hedgehog.Internal.Property (Property, PropertyT, PropertyName)+import           Hedgehog.Internal.Property (Group(..), GroupName) import           Hedgehog.Internal.Property (ShrinkLimit, withShrinks)-import           Hedgehog.Internal.Property (Test, property)+import           Hedgehog.Internal.Property (ShrinkRetries, withRetries)+import           Hedgehog.Internal.Property (Test, TestT, property, test) import           Hedgehog.Internal.Property (TestLimit, withTests)-import           Hedgehog.Internal.Property (withCatch, withExceptT, withResourceT) 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(..), Action)-import           Hedgehog.Internal.State (executeSequential)-import           Hedgehog.Internal.State (Var(..), Symbolic(..), Concrete(..))+import           Hedgehog.Internal.State (Command(..), Callback(..))+import           Hedgehog.Internal.State (Action, Sequential(..), Parallel(..))+import           Hedgehog.Internal.State (executeSequential, executeParallel)+import           Hedgehog.Internal.State (Var(..), Symbolic, Concrete(..), concrete, opaque) import           Hedgehog.Internal.TH (discover) import           Hedgehog.Internal.Tripping (tripping)

@@ -1,8 +1,7 @@ module Hedgehog.Gen (-  -- * Transformer-    Gen-   -- * Combinators+    lift+   -- ** Shrinking   , shrink   , prune@@ -82,6 +81,7 @@   , map    -- ** Subterms+  , freeze   , subterm   , subtermM   , subterm2@@ -94,7 +94,8 @@   , shuffle    -- ** Abstract State Machine-  , actions+  , sequential+  , parallel    -- * Sampling Generators   , sample@@ -105,6 +106,6 @@   ) where  import           Hedgehog.Internal.Gen-import           Hedgehog.Internal.State (actions)+import           Hedgehog.Internal.State (sequential, parallel)  import           Prelude hiding (filter, print, maybe, map, seq)

@@ -1,42 +1,23 @@ module Hedgehog.Internal.Exception (-    TypedException(..)-  , tryAll+    tryAll+  , tryEvaluate   ) where -import           Control.Exception (Exception(..), AsyncException, SomeException(..))+import           Control.Exception (Exception(..), AsyncException, SomeException(..), evaluate) import           Control.Monad.Catch (MonadCatch(..), throwM) -import           Data.Typeable (typeOf)+import           System.IO.Unsafe (unsafePerformIO)  --- | Newtype for 'SomeException' with a 'Show' instance that only contains---   valid Haskell 98 tokens and also includes the type of the exception.------   For example, when catching the exception thrown by @fail "foo" :: IO ()@---   and calling show:------ @---   IOException "user error (foo)"--- @------   Having access to the type can be useful when trying to track down the---   source of an exception.----newtype TypedException =-  TypedException SomeException--instance Show TypedException where-  showsPrec p (TypedException (SomeException x)) =-    showParen (p > 10) $-      showsPrec 11 (typeOf x) .-      showChar ' ' .-      showsPrec 11 (displayException x)--tryAll :: MonadCatch m => m a -> m (Either TypedException a)+tryAll :: MonadCatch m => m a -> m (Either SomeException a) tryAll m =   catch (fmap Right m) $ \exception ->     case fromException exception :: Maybe AsyncException of       Nothing ->-        pure . Left $ TypedException exception+        pure $ Left exception       Just async ->         throwM async++tryEvaluate :: a -> Either SomeException a+tryEvaluate x =+  unsafePerformIO (tryAll (evaluate x))

@@ -2,6 +2,8 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -15,9 +17,13 @@ {-# LANGUAGE UndecidableInstances #-} -- MonadBase module Hedgehog.Internal.Gen (   -- * Transformer-    Gen(..)+    Gen+  , GenT(..)+  , MonadGen(..)    -- * Combinators+  , lift+   -- ** Shrinking   , shrink   , prune@@ -85,6 +91,7 @@    -- ** Conditional   , discard+  , ensure   , filter   , just @@ -120,8 +127,8 @@   -- $internal    -- ** Transfomer-  , runGen-  , mapGen+  , runGenT+  , mapGenT   , generate   , liftTree   , runDiscardEffect@@ -145,25 +152,36 @@   ) where  import           Control.Applicative (Alternative(..))-import           Control.Monad (MonadPlus(..), mfilter, filterM, replicateM, ap, join)+import           Control.Monad (MonadPlus(..), filterM, replicateM, ap, join) import           Control.Monad.Base (MonadBase(..)) import           Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import           Control.Monad.Error.Class (MonadError(..)) import           Control.Monad.IO.Class (MonadIO(..))-import           Control.Monad.Morph (MFunctor(..), MMonad(..))+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.Class (MonadTrans)+import qualified Control.Monad.Trans.Class as Trans+import           Control.Monad.Trans.Except (ExceptT(..), mapExceptT)+import           Control.Monad.Trans.Identity (IdentityT(..), mapIdentityT)+import           Control.Monad.Trans.Maybe (MaybeT(..), mapMaybeT)+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import           Control.Monad.Trans.Reader (ReaderT(..), mapReaderT) import           Control.Monad.Trans.Resource (MonadResource(..))+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict import           Control.Monad.Writer.Class (MonadWriter(..)) -import           Data.Bifunctor (first)+import           Data.Bifunctor (first, second) import           Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.Char as Char import           Data.Foldable (for_, toList)+import           Data.Functor.Identity (Identity(..)) import           Data.Int (Int8, Int16, Int32, Int64) import           Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty@@ -195,53 +213,35 @@  -- | Generator for random values of @a@. ---newtype Gen m a =-  Gen {+type Gen =+  GenT Identity++-- | Monad transformer which can generate random values of @a@.+--+newtype GenT m a =+  GenT {       unGen :: Size -> Seed -> Tree (MaybeT m) a     }  -- | Runs a generator, producing its shrink tree. ---runGen :: Size -> Seed -> Gen m a -> Tree (MaybeT m) a-runGen size seed (Gen m) =+runGenT :: Size -> Seed -> GenT m a -> Tree (MaybeT m) a+runGenT size seed (GenT m) =   m size seed  -- | Map over a generator's shrink tree. ---mapGen :: (Tree (MaybeT m) a -> Tree (MaybeT n) b) -> Gen m a -> Gen n b-mapGen f gen =-  Gen $ \size seed ->-    f (runGen size seed gen)---- | Generate a value with no shrinks from a 'Size' and a 'Seed'.----generate :: Monad m => (Size -> Seed -> a) -> Gen m a-generate f =-  Gen $ \size seed ->-    pure (f size seed)---- | Freeze the size and seed used by a generator, so we can inspect the value---   which it will produce.------   This is used for implementing `list` and `subtermMVec`. It allows us to---   shrink the list itself before trying to shrink the values inside the list.----freeze :: Monad m => Gen m a -> Gen m (a, Gen m a)-freeze gen =-  Gen $ \size seed -> do-    mx <- lift . lift . runMaybeT . runTree $ runGen size seed gen-    case mx of-      Nothing ->-        mzero-      Just (Node x xs) ->-        pure (x, liftTree . Tree.fromNode $ Node x xs)+mapGenT :: (Tree (MaybeT m) a -> Tree (MaybeT n) b) -> GenT m a -> GenT n b+mapGenT f gen =+  GenT $ \size seed ->+    f (runGenT size seed gen)  -- | Lift a predefined shrink tree in to a generator, ignoring the seed and the --   size. ---liftTree :: Tree (MaybeT m) a -> Gen m a+liftTree :: Tree (MaybeT m) a -> GenT m a liftTree x =-  Gen (\_ _ -> x)+  GenT (\_ _ -> x)  -- | Run the discard effects through the tree and reify them as 'Maybe' values --   at the nodes. 'Nothing' means discarded, 'Just' means we have a value.@@ -251,54 +251,321 @@   runMaybeT . distribute  --------------------------------------------------------------------------- Gen instances+-- MonadGen -instance Functor m => Functor (Gen m) where+-- | Class of monads which can generate input data for tests.+--+--   /The functions on this class can, and should, be used without their @Gen@/+--   /suffix by importing "Hedgehog.Gen" qualified./+--+class Monad m => MonadGen m where+  -- | See @Gen.@'Hedgehog.Gen.lift'+  --+  liftGen :: Gen a -> m a++  -- | See @Gen.@'Hedgehog.Gen.shrink'+  --+  shrinkGen :: (a -> [a]) -> m a -> m a++  -- | See @Gen.@'Hedgehog.Gen.prune'+  --+  pruneGen :: m a -> m a++  -- | See @Gen.@'Hedgehog.Gen.scale'+  --+  scaleGen :: (Size -> Size) -> m a -> m a++  -- | See @Gen.@'Hedgehog.Gen.freeze'+  --+  freezeGen :: m a -> m (a, m a)++instance Monad m => MonadGen (GenT m) where+  liftGen gen =+    hoist generalize gen++  shrinkGen =+    mapGenT . Tree.expand++  pruneGen =+    mapGenT Tree.prune++  scaleGen f gen =+    GenT $ \size0 seed ->+      let+        size =+          f size0+      in+        if size < 0 then+          error "Hedgehog.Gen.scale: negative size"+        else+          runGenT size seed gen++  freezeGen gen =+    GenT $ \size seed -> do+      mx <- Trans.lift . Trans.lift . runMaybeT . runTree $ runGenT size seed gen+      case mx of+        Nothing ->+          mzero+        Just (Node x xs) ->+          pure (x, liftTree . Tree.fromNode $ Node x xs)++instance MonadGen m => MonadGen (IdentityT m) where+  liftGen =+    Trans.lift . liftGen++  shrinkGen f =+    mapIdentityT (shrink f)++  pruneGen =+    hoist prune++  scaleGen f =+    hoist (scale f)++  freezeGen =+    mapIdentityT $+      fmap (second Trans.lift) . freeze++shrinkMaybe :: (a -> [a]) -> Maybe a -> [Maybe a]+shrinkMaybe f = \case+  Nothing ->+    pure Nothing+  Just x ->+    fmap Just (f x)++shrinkEither :: (a -> [a]) -> Either x a -> [Either x a]+shrinkEither f = \case+  Left x ->+    pure $ Left x+  Right x ->+    fmap Right (f x)++shrink2 :: (a -> [a]) -> (a, b) -> [(a, b)]+shrink2 f (x, y) =+  fmap (, y) (f x)++shrink3 :: (a -> [a]) -> (a, b, c) -> [(a, b, c)]+shrink3 f (x, y, z) =+  fmap (, y, z) (f x)++instance MonadGen m => MonadGen (MaybeT m) where+  liftGen =+    Trans.lift . liftGen++  shrinkGen f =+    mapMaybeT $+      shrink (shrinkMaybe f)++  pruneGen =+    hoist prune++  scaleGen f =+    hoist (scale f)++  freezeGen =+    mapMaybeT $ \m0 -> do+      (mx, m) <- freeze m0+      pure $ fmap (, MaybeT m) mx++instance MonadGen m => MonadGen (ExceptT x m) where+  liftGen =+    Trans.lift . liftGen++  shrinkGen f =+    mapExceptT $+      shrink (shrinkEither f)++  pruneGen =+    hoist prune++  scaleGen f =+    hoist (scale f)++  freezeGen =+    mapExceptT $ \m0 -> do+      (mx, m) <- freeze m0+      pure $ fmap (, ExceptT m) mx++instance MonadGen m => MonadGen (ReaderT r m) where+  liftGen =+    Trans.lift . liftGen++  shrinkGen f =+    mapReaderT (shrink f)++  pruneGen =+    hoist prune++  scaleGen f =+    hoist (scale f)++  freezeGen =+    mapReaderT $+      fmap (second Trans.lift) . freeze++instance MonadGen m => MonadGen (Lazy.StateT s m) where+  liftGen =+    Trans.lift . liftGen++  shrinkGen f =+    Lazy.mapStateT $+      shrink (shrink2 f)++  pruneGen =+    hoist prune++  scaleGen f =+    hoist (scale f)++  freezeGen m0 =+    Lazy.StateT $ \s0 -> do+      ((x, s), m) <- freeze (Lazy.runStateT m0 s0)+      pure ((x, Lazy.StateT (const m)), s)++instance MonadGen m => MonadGen (Strict.StateT s m) where+  liftGen =+    Trans.lift . liftGen++  shrinkGen f =+    Strict.mapStateT $+      shrink (shrink2 f)++  pruneGen =+    hoist prune++  scaleGen f =+    hoist (scale f)++  freezeGen m0 =+    Strict.StateT $ \s0 -> do+      ((x, s), m) <- freeze (Strict.runStateT m0 s0)+      pure ((x, Strict.StateT (const m)), s)++instance (MonadGen m, Monoid w) => MonadGen (Lazy.WriterT w m) where+  liftGen =+    Trans.lift . liftGen++  shrinkGen f =+    Lazy.mapWriterT $+      shrink (shrink2 f)++  pruneGen =+    hoist prune++  scaleGen f =+    hoist (scale f)++  freezeGen m0 =+    Lazy.WriterT $ do+      ((x, w), m) <- freeze (Lazy.runWriterT m0)+      pure ((x, Lazy.WriterT m), w)++instance (MonadGen m, Monoid w) => MonadGen (Strict.WriterT w m) where+  liftGen =+    Trans.lift . liftGen++  shrinkGen f =+    Strict.mapWriterT $+      shrink (shrink2 f)++  pruneGen =+    hoist prune++  scaleGen f =+    hoist (scale f)++  freezeGen m0 =+    Strict.WriterT $ do+      ((x, w), m) <- freeze (Strict.runWriterT m0)+      pure ((x, Strict.WriterT m), w)++instance (MonadGen m, Monoid w) => MonadGen (Lazy.RWST r w s m) where+  liftGen =+    Trans.lift . liftGen++  shrinkGen f =+    Lazy.mapRWST $+      shrink (shrink3 f)++  pruneGen =+    hoist prune++  scaleGen f =+    hoist (scale f)++  freezeGen m0 =+    Lazy.RWST $ \r s0 -> do+      ((x, s, w), m) <- freeze (Lazy.runRWST m0 r s0)+      pure ((x, Lazy.RWST (\_ _ -> m)), s, w)++instance (MonadGen m, Monoid w) => MonadGen (Strict.RWST r w s m) where+  liftGen =+    Trans.lift . liftGen++  shrinkGen f =+    Strict.mapRWST $+      shrink (shrink3 f)++  pruneGen =+    hoist prune++  scaleGen f =+    hoist (scale f)++  freezeGen m0 =+    Strict.RWST $ \r s0 -> do+      ((x, s, w), m) <- freeze (Strict.runRWST m0 r s0)+      pure ((x, Strict.RWST (\_ _ -> m)), s, w)++------------------------------------------------------------------------+-- GenT instances++instance Functor m => Functor (GenT m) where   fmap f gen =-    Gen $ \seed size ->-      fmap f (runGen seed size gen)+    GenT $ \seed size ->+      fmap f (runGenT seed size gen) -instance Monad m => Applicative (Gen m) where+instance Monad m => Applicative (GenT m) where   pure =     return   (<*>) =     ap -instance Monad m => Monad (Gen m) where+instance Monad m => Monad (GenT m) where   return =     liftTree . pure    (>>=) m k =-    Gen $ \size seed ->+    GenT $ \size seed ->       case Seed.split seed of         (sk, sm) ->-          runGen size sk . k =<<-          runGen size sm m+          runGenT size sk . k =<<+          runGenT size sm m -instance Monad m => Alternative (Gen m) where+instance Monad m => Alternative (GenT m) where   empty =     mzero   (<|>) =     mplus -instance Monad m => MonadPlus (Gen m) where+instance Monad m => MonadPlus (GenT m) where   mzero =     liftTree mzero    mplus x y =-    Gen $ \size seed ->+    GenT $ \size seed ->       case Seed.split seed of         (sx, sy) ->-          runGen size sx x `mplus`-          runGen size sy y+          runGenT size sx x `mplus`+          runGenT size sy y -instance MonadTrans Gen where+instance MonadTrans GenT where   lift =-    liftTree . lift . lift+    liftTree . Trans.lift . Trans.lift -instance MFunctor Gen where+instance MFunctor GenT where   hoist f =-    mapGen (hoist (hoist f))+    mapGenT (hoist (hoist f))  embedMaybe ::      MonadTrans t@@ -308,32 +575,32 @@   -> MaybeT m b   -> t (MaybeT n) b embedMaybe f m =-  lift . MaybeT . pure =<< f (runMaybeT m)+  Trans.lift . MaybeT . pure =<< f (runMaybeT m)  embedTree :: Monad n => (forall a. m a -> Tree (MaybeT n) a) -> Tree (MaybeT m) b -> Tree (MaybeT n) b embedTree f tree =   embed (embedMaybe f) tree -embedGen :: Monad n => (forall a. m a -> Gen n a) -> Gen m b -> Gen n b+embedGen :: Monad n => (forall a. m a -> GenT n a) -> GenT m b -> GenT n b embedGen f gen =-  Gen $ \size seed ->+  GenT $ \size seed ->     case Seed.split seed of       (sf, sg) ->-        (runGen size sf . f) `embedTree`-        (runGen size sg gen)+        (runGenT size sf . f) `embedTree`+        (runGenT size sg gen) -instance MMonad Gen where+instance MMonad GenT where   embed =     embedGen -distributeGen :: Transformer t Gen m => Gen (t m) a -> t (Gen m) a+distributeGen :: Transformer t GenT m => GenT (t m) a -> t (GenT m) a distributeGen x =-  join . lift . Gen $ \size seed ->-    pure . hoist liftTree . distribute . hoist distribute $ runGen size seed x+  join . Trans.lift . GenT $ \size seed ->+    pure . hoist liftTree . distribute . hoist distribute $ runGenT size seed x -instance Distributive Gen where-  type Transformer t Gen m = (-      Monad (t (Gen m))+instance Distributive GenT where+  type Transformer t GenT m = (+      Monad (t (GenT m))     , Transformer t MaybeT m     , Transformer t Tree (MaybeT m)     )@@ -341,119 +608,129 @@   distribute =     distributeGen -instance PrimMonad m => PrimMonad (Gen m) where-  type PrimState (Gen m) =+instance PrimMonad m => PrimMonad (GenT m) where+  type PrimState (GenT m) =     PrimState m   primitive =-    lift . primitive+    Trans.lift . primitive -instance MonadIO m => MonadIO (Gen m) where+instance MonadIO m => MonadIO (GenT m) where   liftIO =-    lift . liftIO+    Trans.lift . liftIO -instance MonadBase b m => MonadBase b (Gen m) where+instance MonadBase b m => MonadBase b (GenT m) where   liftBase =-    lift . liftBase+    Trans.lift . liftBase -instance MonadThrow m => MonadThrow (Gen m) where+instance MonadThrow m => MonadThrow (GenT m) where   throwM =-    lift . throwM+    Trans.lift . throwM -instance MonadCatch m => MonadCatch (Gen m) where+instance MonadCatch m => MonadCatch (GenT m) where   catch m onErr =-    Gen $ \size seed ->+    GenT $ \size seed ->       case Seed.split seed of         (sm, se) ->-          (runGen size sm m) `catch`-          (runGen size se . onErr)+          (runGenT size sm m) `catch`+          (runGenT size se . onErr) -instance MonadReader r m => MonadReader r (Gen m) where+instance MonadReader r m => MonadReader r (GenT m) where   ask =-    lift ask+    Trans.lift ask   local f m =-    mapGen (local f) m+    mapGenT (local f) m -instance MonadState s m => MonadState s (Gen m) where+instance MonadState s m => MonadState s (GenT m) where   get =-    lift get+    Trans.lift get   put =-    lift . put+    Trans.lift . put   state =-    lift . state+    Trans.lift . state -instance MonadWriter w m => MonadWriter w (Gen m) where+instance MonadWriter w m => MonadWriter w (GenT m) where   writer =-    lift . writer+    Trans.lift . writer   tell =-    lift . tell+    Trans.lift . tell   listen =-    mapGen listen+    mapGenT listen   pass =-    mapGen pass+    mapGenT pass -instance MonadError e m => MonadError e (Gen m) where+instance MonadError e m => MonadError e (GenT m) where   throwError =-    lift . throwError+    Trans.lift . throwError   catchError m onErr =-    Gen $ \size seed ->+    GenT $ \size seed ->       case Seed.split seed of         (sm, se) ->-          (runGen size sm m) `catchError`-          (runGen size se . onErr)+          (runGenT size sm m) `catchError`+          (runGenT size se . onErr) -instance MonadResource m => MonadResource (Gen m) where+instance MonadResource m => MonadResource (GenT m) where   liftResourceT =-    lift . liftResourceT+    Trans.lift . liftResourceT  --------------------------------------------------------------------------- Shrinking+-- Combinators +-- | Lift a vanilla 'Gen' in to a 'MonadGen'.+--+lift :: MonadGen m => Gen a -> m a+lift =+  liftGen++-- | Generate a value with no shrinks from a 'Size' and a 'Seed'.+--+generate :: MonadGen m => (Size -> Seed -> a) -> m a+generate f =+  liftGen . GenT $ \size seed ->+    pure (f size seed)++------------------------------------------------------------------------+-- Combinators - Shrinking+ -- | Apply a shrinking function to a generator. -- --   This will give the generator additional shrinking options, while keeping --   the existing shrinks intact. ---shrink :: Monad m => (a -> [a]) -> Gen m a -> Gen m a+shrink :: MonadGen m => (a -> [a]) -> m a -> m a shrink =-  mapGen . Tree.expand+  shrinkGen  -- | Throw away a generator's shrink tree. ---prune :: Monad m => Gen m a -> Gen m a+prune :: MonadGen m => m a -> m a prune =-  mapGen Tree.prune+  pruneGen  ------------------------------------------------------------------------ -- Combinators - Size  -- | Construct a generator that depends on the size parameter. ---sized :: (Size -> Gen m a) -> Gen m a-sized f =-  Gen $ \size seed ->-    runGen size seed (f size)+sized :: MonadGen m => (Size -> m a) -> m a+sized f = do+  f =<< generate (\size _ -> size)  -- | Override the size parameter. Returns a generator which uses the given size --   instead of the runtime-size parameter. ---resize :: Size -> Gen m a -> Gen m a+resize :: MonadGen m => Size -> m a -> m a resize size gen =-  if size < 0 then-    error "Hedgehog.Random.resize: negative size"-  else-    Gen $ \_ seed ->-      runGen size seed gen+  scale (const size) gen  -- | Adjust the size parameter by transforming it with the given function. ---scale :: (Size -> Size) -> Gen m a -> Gen m a-scale f gen =-  sized $ \n ->-    resize (f n) gen+scale :: MonadGen m => (Size -> Size) -> m a -> m a+scale =+  scaleGen  -- | Make a generator smaller by scaling its size parameter. ---small :: Gen m a -> Gen m a+small :: MonadGen m => m a -> m a small =   scale golden @@ -502,7 +779,7 @@ --   > 2058 --   > 2060 ---integral :: (Monad m, Integral a) => Range a -> Gen m a+integral :: (MonadGen m, Integral a) => Range a -> m a integral range =   shrink (Shrink.towards $ Range.origin range) (integral_ range) @@ -510,7 +787,7 @@ -- --   /This generator does not shrink./ ---integral_ :: (Monad m, Integral a) => Range a -> Gen m a+integral_ :: (MonadGen m, Integral a) => Range a -> m a integral_ range =   generate $ \size seed ->     let@@ -524,7 +801,7 @@ -- --   /This is a specialization of 'integral', offered for convenience./ ---int :: Monad m => Range Int -> Gen m Int+int :: MonadGen m => Range Int -> m Int int =   integral @@ -532,7 +809,7 @@ -- --   /This is a specialization of 'integral', offered for convenience./ ---int8 :: Monad m => Range Int8 -> Gen m Int8+int8 :: MonadGen m => Range Int8 -> m Int8 int8 =   integral @@ -540,7 +817,7 @@ -- --   /This is a specialization of 'integral', offered for convenience./ ---int16 :: Monad m => Range Int16 -> Gen m Int16+int16 :: MonadGen m => Range Int16 -> m Int16 int16 =   integral @@ -548,7 +825,7 @@ -- --   /This is a specialization of 'integral', offered for convenience./ ---int32 :: Monad m => Range Int32 -> Gen m Int32+int32 :: MonadGen m => Range Int32 -> m Int32 int32 =   integral @@ -556,7 +833,7 @@ -- --   /This is a specialization of 'integral', offered for convenience./ ---int64 :: Monad m => Range Int64 -> Gen m Int64+int64 :: MonadGen m => Range Int64 -> m Int64 int64 =   integral @@ -564,7 +841,7 @@ -- --   /This is a specialization of 'integral', offered for convenience./ ---word :: Monad m => Range Word -> Gen m Word+word :: MonadGen m => Range Word -> m Word word =   integral @@ -572,7 +849,7 @@ -- --   /This is a specialization of 'integral', offered for convenience./ ---word8 :: Monad m => Range Word8 -> Gen m Word8+word8 :: MonadGen m => Range Word8 -> m Word8 word8 =   integral @@ -580,7 +857,7 @@ -- --   /This is a specialization of 'integral', offered for convenience./ ---word16 :: Monad m => Range Word16 -> Gen m Word16+word16 :: MonadGen m => Range Word16 -> m Word16 word16 =   integral @@ -588,7 +865,7 @@ -- --   /This is a specialization of 'integral', offered for convenience./ ---word32 :: Monad m => Range Word32 -> Gen m Word32+word32 :: MonadGen m => Range Word32 -> m Word32 word32 =   integral @@ -596,7 +873,7 @@ -- --   /This is a specialization of 'integral', offered for convenience./ ---word64 :: Monad m => Range Word64 -> Gen m Word64+word64 :: MonadGen m => Range Word64 -> m Word64 word64 =   integral @@ -607,7 +884,7 @@ -- --   This generator works the same as 'integral', but for floating point numbers. ---realFloat :: (Monad m, RealFloat a) => Range a -> Gen m a+realFloat :: (MonadGen m, RealFloat a) => Range a -> m a realFloat range =   shrink (Shrink.towardsFloat $ Range.origin range) (realFrac_ range) @@ -615,7 +892,7 @@ -- --   /This generator does not shrink./ ---realFrac_ :: (Monad m, RealFrac a) => Range a -> Gen m a+realFrac_ :: (MonadGen m, RealFrac a) => Range a -> m a realFrac_ range =   generate $ \size seed ->     let@@ -629,7 +906,7 @@ -- --   /This is a specialization of 'realFloat', offered for convenience./ ---float :: Monad m => Range Float -> Gen m Float+float :: MonadGen m => Range Float -> m Float float =  realFloat @@ -637,7 +914,7 @@ -- --   /This is a specialization of 'realFloat', offered for convenience./ ---double :: Monad m => Range Double -> Gen m Double+double :: MonadGen m => Range Double -> m Double double =  realFloat @@ -654,7 +931,7 @@ -- enum \'a' \'z' :: 'Gen' 'Char' -- @ ---enum :: (Monad m, Enum a) => a -> a -> Gen m a+enum :: (MonadGen m, Enum a) => a -> a -> m a enum lo hi =   fmap toEnum . integral $     Range.constant (fromEnum lo) (fromEnum hi)@@ -669,7 +946,7 @@ -- enumBounded :: 'Gen' 'Bool' -- @ ---enumBounded :: (Monad m, Enum a, Bounded a) => Gen m a+enumBounded :: (MonadGen m, Enum a, Bounded a) => m a enumBounded =   enum minBound maxBound @@ -679,7 +956,7 @@ -- --   /This is a specialization of 'enumBounded', offered for convenience./ ---bool :: Monad m => Gen m Bool+bool :: MonadGen m => m Bool bool =   enumBounded @@ -687,7 +964,7 @@ -- --   /This generator does not shrink./ ---bool_ :: Monad m => Gen m Bool+bool_ :: MonadGen m => m Bool bool_ =   generate $ \_ seed ->     (/= 0) . fst $ Seed.nextInteger 0 1 seed@@ -697,78 +974,78 @@  -- | Generates an ASCII binit: @'0'..'1'@ ---binit :: Monad m => Gen m Char+binit :: MonadGen m => m Char binit =   enum '0' '1'  -- | Generates an ASCII octit: @'0'..'7'@ ---octit :: Monad m => Gen m Char+octit :: MonadGen m => m Char octit =   enum '0' '7'  -- | Generates an ASCII digit: @'0'..'9'@ ---digit :: Monad m => Gen m Char+digit :: MonadGen m => m Char digit =   enum '0' '9'  -- | Generates an ASCII hexit: @'0'..'9', \'a\'..\'f\', \'A\'..\'F\'@ ---hexit :: Monad m => Gen m Char+hexit :: MonadGen m => m Char hexit =   -- FIXME optimize lookup, use a SmallArray or something.   element "0123456789aAbBcCdDeEfF"  -- | Generates an ASCII lowercase letter: @\'a\'..\'z\'@ ---lower :: Monad m => Gen m Char+lower :: MonadGen m => m Char lower =   enum 'a' 'z'  -- | Generates an ASCII uppercase letter: @\'A\'..\'Z\'@ ---upper :: Monad m => Gen m Char+upper :: MonadGen m => m Char upper =   enum 'A' 'Z'  -- | Generates an ASCII letter: @\'a\'..\'z\', \'A\'..\'Z\'@ ---alpha :: Monad m => Gen m Char+alpha :: MonadGen m => m Char alpha =   -- FIXME optimize lookup, use a SmallArray or something.   element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"  -- | Generates an ASCII letter or digit: @\'a\'..\'z\', \'A\'..\'Z\', \'0\'..\'9\'@ ---alphaNum :: Monad m => Gen m Char+alphaNum :: MonadGen m => m Char alphaNum =   -- FIXME optimize lookup, use a SmallArray or something.   element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"  -- | Generates an ASCII character: @'\0'..'\127'@ ---ascii :: Monad m => Gen m Char+ascii :: MonadGen m => m Char ascii =   enum '\0' '\127'  -- | Generates a Latin-1 character: @'\0'..'\255'@ ---latin1 :: Monad m => Gen m Char+latin1 :: MonadGen m => m Char latin1 =   enum '\0' '\255'  -- | Generates a Unicode character, excluding invalid standalone surrogates: --   @'\0'..'\1114111' (excluding '\55296'..'\57343')@ ---unicode :: Monad m => Gen m Char+unicode :: MonadGen m => m Char unicode =   filter (not . isSurrogate) unicodeAll  -- | Generates a Unicode character, including invalid standalone surrogates: --   @'\0'..'\1114111'@ ---unicodeAll :: Monad m => Gen m Char+unicodeAll :: MonadGen m => m Char unicodeAll =   enumBounded @@ -785,26 +1062,26 @@ -- --   /This is a specialization of 'list', offered for convenience./ ---string :: Monad m => Range Int -> Gen m Char -> Gen m String+string :: MonadGen m => Range Int -> m Char -> m String string =   list  -- | Generates a string using 'Range' to determine the length. ---text :: Monad m => Range Int -> Gen m Char -> Gen m Text+text :: MonadGen m => Range Int -> m Char -> m Text text range =   fmap Text.pack . string range  -- | Generates a UTF-8 encoded string, using 'Range' to determine the length. ---utf8 :: Monad m => Range Int -> Gen m Char -> Gen m ByteString+utf8 :: MonadGen m => Range Int -> m Char -> m ByteString utf8 range =   fmap Text.encodeUtf8 . text range  -- | Generates a random 'ByteString', using 'Range' to determine the --   length. ---bytes :: Monad m => Range Int -> Gen m ByteString+bytes :: MonadGen m => Range Int -> m ByteString bytes range =   fmap ByteString.pack $   choice [@@ -823,7 +1100,7 @@ -- | Trivial generator that always produces the same element. -- --   /This is another name for 'pure' \/ 'return'./-constant :: Monad m => a -> Gen m a+constant :: MonadGen m => a -> m a constant =   pure @@ -833,7 +1110,7 @@ -- --   /The input list must be non-empty./ ---element :: Monad m => [a] -> Gen m a+element :: MonadGen m => [a] -> m a element = \case   [] ->     error "Hedgehog.Gen.element: used with empty list"@@ -847,7 +1124,7 @@ -- --   /The input list must be non-empty./ ---choice :: Monad m => [Gen m a] -> Gen m a+choice :: MonadGen m => [m a] -> m a choice = \case   [] ->     error "Hedgehog.Gen.choice: used with empty list"@@ -862,7 +1139,7 @@ -- --   /The input list must be non-empty./ ---frequency :: Monad m => [(Int, Gen m a)] -> Gen m a+frequency :: MonadGen m => [(Int, m a)] -> m a frequency = \case   [] ->     error "Hedgehog.Gen.frequency: used with empty list"@@ -901,10 +1178,10 @@ --   | App Expr Expr -- -- -- Assuming we have a name generator--- genName :: 'Monad' m => 'Gen' m String+-- genName :: 'MonadGen' m => m String -- -- -- We can write a generator for expressions--- genExpr :: 'Monad' m => 'Gen' m Expr+-- genExpr :: 'MonadGen' m => m Expr -- genExpr = --   Gen.'recursive' Gen.'choice' [ --       -- non-recursive generators@@ -920,7 +1197,7 @@ --   would fail to terminate. This is because for every call to @genExpr@, --   there is a 2 in 3 chance that we will recurse again. ---recursive :: ([Gen m a] -> Gen m a) -> [Gen m a] -> [Gen m a] -> Gen m a+recursive :: MonadGen m => ([m a] -> m a) -> [m a] -> [m a] -> m a recursive f nonrec rec =   sized $ \n ->     if n <= 1 then@@ -933,12 +1210,21 @@  -- | Discards the whole generator. -----   /This is another name for 'empty' \/ 'mzero'./----discard :: Monad m => Gen m a+discard :: MonadGen m => m a discard =-  mzero+  liftGen mzero +-- | Discards the generator if the generated value does not satisfy the+--   predicate.+--+ensure :: MonadGen m => (a -> Bool) -> m a -> m a+ensure p gen = do+  x <- gen+  if p x then+    pure x+  else+    discard+ -- | Generates a value that satisfies a predicate. -- --   This is essentially:@@ -950,14 +1236,18 @@ --   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 :: Monad m => (a -> Bool) -> Gen m a -> Gen m a+filter :: MonadGen m => (a -> Bool) -> m a -> m a filter p gen =   let     try k =       if k > 100 then-        empty-      else-        mfilter p (scale (2 * k +) gen) <|> try (k + 1)+        discard+      else do+        x <- scale (2 * k +) gen+        if p x then+          pure x+        else+          try (k + 1)   in     try 0 @@ -965,7 +1255,7 @@ -- --   This is implemented using 'filter' and has the same caveats. ---just :: Monad m => Gen m (Maybe a) -> Gen m a+just :: MonadGen m => m (Maybe a) -> m a just g = do   mx <- filter Maybe.isJust g   case mx of@@ -979,7 +1269,7 @@  -- | Generates a 'Nothing' some of the time. ---maybe :: Monad m => Gen m a -> Gen m (Maybe a)+maybe :: MonadGen m => m a -> m (Maybe a) maybe gen =   sized $ \n ->     frequency [@@ -989,24 +1279,24 @@  -- | Generates a list using a 'Range' to determine the length. ---list :: Monad m => Range Int -> Gen m a -> Gen m [a]+list :: MonadGen m => Range Int -> m a -> m [a] list range gen =   sized $ \size ->     (traverse snd =<<) .-    mfilter (atLeast $ Range.lowerBound size range) .+    ensure (atLeast $ Range.lowerBound size range) .     shrink Shrink.list $ do       k <- integral_ range       replicateM k (freeze gen)  -- | Generates a seq using a 'Range' to determine the length. ---seq :: Monad m => Range Int -> Gen m a -> Gen m (Seq a)+seq :: MonadGen m => Range Int -> m a -> m (Seq a) seq range gen =   Seq.fromList <$> list range gen  -- | Generates a non-empty list using a 'Range' to determine the length. ---nonEmpty :: Monad m => Range Int -> Gen m a -> Gen m (NonEmpty a)+nonEmpty :: MonadGen m => Range Int -> m a -> m (NonEmpty a) nonEmpty range gen = do   xs <- list (fmap (max 1) range) gen   case xs of@@ -1021,7 +1311,7 @@ --   /cannot produce a large enough number of unique items to satify/ --   /the required set size./ ---set :: (Monad m, Ord a) => Range Int -> Gen m a -> Gen m (Set a)+set :: (MonadGen m, Ord a) => Range Int -> m a -> m (Set a) set range gen =   fmap Map.keysSet . map range $ fmap (, ()) gen @@ -1031,10 +1321,10 @@ --   /generator do not account for a large enough number of unique/ --   /items to satify the required map size./ ---map :: (Monad m, Ord k) => Range Int -> Gen m (k, v) -> Gen m (Map k v)+map :: (MonadGen m, Ord k) => Range Int -> m (k, v) -> m (Map k v) map range gen =   sized $ \size ->-    mfilter ((>= Range.lowerBound size range) . Map.size) .+    ensure ((>= Range.lowerBound size range) . Map.size) .     fmap Map.fromList .     (sequence =<<) .     shrink Shrink.list $ do@@ -1043,12 +1333,12 @@  -- | Generate exactly 'n' unique generators. ---uniqueByKey :: (Monad m, Ord k) => Int -> Gen m (k, v) -> Gen m [Gen m (k, v)]+uniqueByKey :: (MonadGen m, Ord k) => Int -> m (k, v) -> m [m (k, v)] uniqueByKey n gen =   let     try k xs0 =       if k > 100 then-        mzero+        discard       else         replicateM n (freeze gen) >>= \kvs ->         case uniqueInsert n xs0 (fmap (first fst) kvs) of@@ -1101,6 +1391,16 @@ deriving instance Foldable (Vec n) deriving instance Traversable (Vec n) +-- | Freeze the size and seed used by a generator, so we can inspect the value+--   which it will produce.+--+--   This is used for implementing `list` and `subtermMVec`. It allows us to+--   shrink the list itself before trying to shrink the values inside the list.+--+freeze :: MonadGen m => m a -> m (a, m a)+freeze =+  freezeGen+ shrinkSubterms :: Subterms n a -> [Subterms n a] shrinkSubterms = \case   One _ ->@@ -1108,7 +1408,7 @@   All xs ->     fmap One $ toList xs -genSubterms :: Monad m => Vec n (Gen m a) -> Gen m (Subterms n a)+genSubterms :: MonadGen m => Vec n (m a) -> m (Subterms n a) genSubterms =   (sequence =<<) .   shrink shrinkSubterms .@@ -1126,7 +1426,7 @@ -- --   /Shrinks to one of the sub-terms if possible./ ---subtermMVec :: Monad m => Vec n (Gen m a) -> (Vec n a -> Gen m a) -> Gen m a+subtermMVec :: MonadGen m => Vec n (m a) -> (Vec n a -> m a) -> m a subtermMVec gs f =   fromSubterms f =<< genSubterms gs @@ -1134,7 +1434,7 @@ -- --   /Shrinks to the sub-term if possible./ ---subtermM :: Monad m => Gen m a -> (a -> Gen m a) -> Gen m a+subtermM :: MonadGen m => m a -> (a -> m a) -> m a subtermM gx f =   subtermMVec (gx :. Nil) $ \(x :. Nil) ->     f x@@ -1143,7 +1443,7 @@ -- --   /Shrinks to the sub-term if possible./ ---subterm :: Monad m => Gen m a -> (a -> a) -> Gen m a+subterm :: MonadGen m => m a -> (a -> a) -> m a subterm gx f =   subtermM gx $ \x ->     pure (f x)@@ -1152,7 +1452,7 @@ -- --   /Shrinks to one of the sub-terms if possible./ ---subtermM2 :: Monad m => Gen m a -> Gen m a -> (a -> a -> Gen m a) -> Gen m a+subtermM2 :: MonadGen m => m a -> m a -> (a -> a -> m a) -> m a subtermM2 gx gy f =   subtermMVec (gx :. gy :. Nil) $ \(x :. y :. Nil) ->     f x y@@ -1161,7 +1461,7 @@ -- --   /Shrinks to one of the sub-terms if possible./ ---subterm2 :: Monad m => Gen m a -> Gen m a -> (a -> a -> a) -> Gen m a+subterm2 :: MonadGen m => m a -> m a -> (a -> a -> a) -> m a subterm2 gx gy f =   subtermM2 gx gy $ \x y ->     pure (f x y)@@ -1170,7 +1470,7 @@ -- --   /Shrinks to one of the sub-terms if possible./ ---subtermM3 :: Monad m => Gen m a -> Gen m a -> Gen m a -> (a -> a -> a -> Gen m a) -> Gen m a+subtermM3 :: MonadGen m => m a -> m a -> m a -> (a -> a -> a -> m a) -> m a subtermM3 gx gy gz f =   subtermMVec (gx :. gy :. gz :. Nil) $ \(x :. y :. z :. Nil) ->     f x y z@@ -1179,7 +1479,7 @@ -- --   /Shrinks to one of the sub-terms if possible./ ---subterm3 :: Monad m => Gen m a -> Gen m a -> Gen m a -> (a -> a -> a -> a) -> Gen m a+subterm3 :: MonadGen m => m a -> m a -> m a -> (a -> a -> a -> a) -> m a subterm3 gx gy gz f =   subtermM3 gx gy gz $ \x y z ->     pure (f x y z)@@ -1189,7 +1489,7 @@  -- | Generates a random subsequence of a list. ---subsequence :: Monad m => [a] -> Gen m [a]+subsequence :: MonadGen m => [a] -> m [a] subsequence xs =   shrink Shrink.list $ filterM (const bool_) xs @@ -1198,7 +1498,7 @@ --   This shrinks towards the order of the list being identical to the input --   list. ---shuffle :: Monad m => [a] -> Gen m [a]+shuffle :: MonadGen m => [a] -> m [a] shuffle = \case   [] ->     pure []@@ -1208,44 +1508,61 @@       (xs, y : ys) ->         (y :) <$> shuffle (xs ++ ys)       (_, []) ->-        error "Hedgehog.shuffle: internal error, split generated empty list"+        error "Hedgehog.Gen.shuffle: internal error, split generated empty list"  ------------------------------------------------------------------------ -- Sampling --- | Generate a random sample of data from the a generator.+-- | Generate a sample from a generator. ---sample :: MonadIO m => Gen m a -> m [a]+sample :: MonadIO m => Gen a -> m a sample gen =-  fmap (fmap nodeValue . Maybe.catMaybes) .-  replicateM 10 $ do-    seed <- liftIO Seed.random-    runMaybeT . runTree $ runGen 30 seed gen+  liftIO $+    let+      loop n =+        if n <= 0 then+          error "Hedgehog.Gen.sample: too many discards, could not generate a sample"+        else do+          seed <- Seed.random+          case runIdentity . runMaybeT . runTree $ runGenT 30 seed gen of+            Nothing ->+              loop (n - 1)+            Just x ->+              pure $ nodeValue x+    in+      loop (100 :: Int)  -- | Print the value produced by a generator, and the first level of shrinks, --   for the given size and seed. -- --   Use 'print' to generate a value from a random seed. ---printWith :: (MonadIO m, Show a) => Size -> Seed -> Gen m a -> m ()-printWith size seed gen = do-  Node x ss <- runTree $ renderNodes size seed gen-  liftIO $ putStrLn "=== Outcome ==="-  liftIO $ putStrLn x-  liftIO $ putStrLn "=== Shrinks ==="-  for_ ss $ \s -> do-    Node y _ <- runTree s-    liftIO $ putStrLn y+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 m a -> m ()+printTreeWith :: (MonadIO m, Show a) => Size -> Seed -> Gen a -> m () printTreeWith size seed gen = do-  s <- Tree.render $ renderNodes size seed gen-  liftIO $ putStr s+  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.@@ -1261,7 +1578,7 @@ --   > 'b' --   > 'c' ---print :: (MonadIO m, Show a) => Gen m a -> m ()+print :: (MonadIO m, Show a) => Gen a -> m () print gen = do   seed <- liftIO Seed.random   printWith 30 seed gen@@ -1283,16 +1600,16 @@ -- --   /This may not terminate when the tree is very large./ ---printTree :: (MonadIO m, Show a) => Gen m a -> m ()+printTree :: (MonadIO m, Show a) => Gen a -> m () printTree gen = do   seed <- liftIO Seed.random   printTreeWith 30 seed gen  -- | Render a generator as a tree of strings. ---renderNodes :: (Monad m, Show a) => Size -> Seed -> Gen m a -> Tree m String+renderNodes :: (Monad m, Show a) => Size -> Seed -> Gen a -> Tree m String renderNodes size seed =-  fmap (Maybe.maybe "<discard>" show) . runDiscardEffect . runGen size seed+  fmap (Maybe.maybe "<discard>" show) . runDiscardEffect . runGenT size seed . lift  ------------------------------------------------------------------------ -- Internal

@@ -11,8 +11,10 @@ --   For example: -- -- @---   data Ref v =---     Ref (v (Opaque (IORef Int)))+--   data State v =+--     State {+--         stateRefs :: [Var (Opaque (IORef Int)) v]+--       } deriving (Eq, Show) -- @ -- newtype Opaque a =

@@ -8,66 +8,79 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-} -- MonadBase+{-# LANGUAGE UndecidableInstances #-} -- Distributive module Hedgehog.Internal.Property (   -- * Property     Property(..)+  , PropertyT(..)   , PropertyName(..)   , PropertyConfig(..)   , TestLimit(..)   , DiscardLimit(..)   , ShrinkLimit(..)-  , property+  , ShrinkRetries(..)   , withTests   , withDiscards   , withShrinks+  , withRetries+  , property+  , test+  , forAll+  , forAllT+  , forAllWith+  , forAllWithT+  , discard    -- * Group   , Group(..)   , GroupName(..) -  -- * Test-  , Test(..)+  -- * TestT+  , MonadTest(..)+  , Test+  , TestT(..)   , Log(..)   , Failure(..)   , Diff(..)-  , forAll-  , forAllWith   , annotate   , annotateShow   , footnote   , footnoteShow-  , discard   , failure   , success   , assert   , (===) -  , liftCatch-  , liftCatchIO-  , liftEither-  , liftExceptT--  , withCatch-  , withExceptT-  , withResourceT+  , eval+  , evalM+  , evalIO+  , evalEither+  , evalExceptT    -- * Internal   -- $internal   , defaultConfig   , mapConfig+  , failDiff+  , failException   , failWith   , writeLog++  , mkTest+  , mkTestT   , runTest+  , runTestT   ) where  import           Control.Applicative (Alternative(..)) import           Control.Monad (MonadPlus(..)) import           Control.Monad.Base (MonadBase(..)) import           Control.Monad.Catch (MonadThrow(..), MonadCatch(..))+import           Control.Monad.Catch (SomeException(..), displayException) import           Control.Monad.Error.Class (MonadError(..)) import           Control.Monad.IO.Class (MonadIO(..)) import           Control.Monad.Morph (MFunctor(..))@@ -75,18 +88,32 @@ import           Control.Monad.Reader.Class (MonadReader(..)) import           Control.Monad.State.Class (MonadState(..)) import           Control.Monad.Trans.Class (MonadTrans(..))+import           Control.Monad.Trans.Cont (ContT)+import           Control.Monad.Trans.Control (ComposeSt, defaultLiftBaseWith, defaultRestoreM)+import           Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..)) import           Control.Monad.Trans.Except (ExceptT(..), runExceptT)-import           Control.Monad.Trans.Resource (MonadResource(..), MonadResourceBase)-import           Control.Monad.Trans.Resource (ResourceT, runResourceT)-import           Control.Monad.Trans.Writer.Lazy (WriterT(..))-import           Control.Monad.Writer.Class (MonadWriter(..))+import           Control.Monad.Trans.Identity (IdentityT)+import           Control.Monad.Trans.Maybe (MaybeT)+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import           Control.Monad.Trans.Reader (ReaderT)+import           Control.Monad.Trans.Resource (MonadResource(..))+import           Control.Monad.Trans.Resource (ResourceT)+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict +import qualified Data.Char as Char+import           Data.Functor.Identity (Identity(..))+import qualified Data.List as List import           Data.Semigroup (Semigroup) import           Data.String (IsString)+import           Data.Typeable (typeOf)  import           Hedgehog.Internal.Distributive import           Hedgehog.Internal.Exception-import           Hedgehog.Internal.Gen (Gen)+import           Hedgehog.Internal.Gen (Gen, GenT) import qualified Hedgehog.Internal.Gen as Gen import           Hedgehog.Internal.Show import           Hedgehog.Internal.Source@@ -95,24 +122,63 @@  ------------------------------------------------------------------------ --- | A property test to check, along with some configurable limits like how---   many times to run the test.+-- | A property test, along with some configurable limits like how many times+--   to run the test. -- data Property =   Property {       propertyConfig :: !PropertyConfig-    , propertyTest :: Test IO ()+    , propertyTest :: PropertyT IO ()     } --- | A property test.+-- | The property monad transformer allows both the generation of test inputs+--   and the assertion of expectations. ---newtype Test m a =-  Test {-      unTest :: ExceptT Failure (WriterT [Log] (Gen m)) a-    } deriving (Functor, Applicative)+newtype PropertyT m a =+  PropertyT {+      unPropertyT :: TestT (GenT m) a+    } deriving (+      Functor+    , Applicative+    , Monad+    , MonadIO+    , MonadBase b+    , MonadThrow+    , MonadCatch+    , MonadReader r+    , MonadState s+    , MonadError e+    ) +-- | A test monad allows the assertion of expectations.+--+type Test =+  TestT Identity++-- | A test monad transformer allows the assertion of expectations.+--+newtype TestT m a =+  TestT {+      unTest :: ExceptT Failure (Lazy.WriterT [Log] m) a+    } deriving (+      Functor+    , Applicative+    , MonadIO+    , MonadBase b+    , MonadThrow+    , MonadCatch+    , MonadReader r+    , MonadState s+    )+ -- | The name of a property. --+--   Can be constructed using `OverloadedStrings`:+--+-- @+--   "apples" :: PropertyName+-- @+-- newtype PropertyName =   PropertyName {       unPropertyName :: String@@ -125,25 +191,64 @@       propertyTestLimit :: !TestLimit     , propertyDiscardLimit :: !DiscardLimit     , propertyShrinkLimit :: !ShrinkLimit+    , propertyShrinkRetries :: !ShrinkRetries     } deriving (Eq, Ord, Show)  -- | The number of successful tests that need to be run before a property test --   is considered successful. --+--   Can be constructed using numeric literals:+--+-- @+--   200 :: TestLimit+-- @+-- newtype TestLimit =   TestLimit Int   deriving (Eq, Ord, Show, Num, Enum, Real, Integral) +-- | The number of discards to allow before giving up.+--+--   Can be constructed using numeric literals:+--+-- @+--   10000 :: DiscardLimit+-- @+--+--+newtype DiscardLimit =+  DiscardLimit Int+  deriving (Eq, Ord, Show, Num, Enum, Real, Integral)+ -- | The number of shrinks to try before giving up on shrinking. --+--   Can be constructed using numeric literals:+--+-- @+--   1000 :: ShrinkLimit+-- @+-- newtype ShrinkLimit =   ShrinkLimit Int   deriving (Eq, Ord, Show, Num, Enum, Real, Integral) --- | The number of discards to allow before giving up.+-- | The number of times to re-run a test during shrinking. This is useful if+--   you are testing something which fails non-deterministically and you want to+--   increase the change of getting a good shrink. ---newtype DiscardLimit =-  DiscardLimit Int+--   If you are doing parallel state machine testing, you should probably set+--   shrink retries to something like @10@. This will mean that during+--   shrinking, a parallel test case requires 10 successful runs before it is+--   passes and we try a different shrink.+--+--   Can be constructed using numeric literals:+--+-- @+--   0 :: ShrinkRetries+-- @+--+newtype ShrinkRetries =+  ShrinkRetries Int   deriving (Eq, Ord, Show, Num, Enum, Real, Integral)  -- | A named collection of property tests.@@ -156,6 +261,12 @@  -- | The name of a group of properties. --+--   Can be constructed using `OverloadedStrings`:+--+-- @+--   "fruit" :: GroupName+-- @+-- newtype GroupName =   GroupName {       unGroupName :: String@@ -192,246 +303,238 @@     , diffValue :: ValueDiff     } deriving (Eq, Show) -instance Monad m => Monad (Test m) where+------------------------------------------------------------------------+-- TestT++instance Monad m => Monad (TestT m) where   return =-    Test . return+    TestT . return    (>>=) m k =-    Test $+    TestT $       unTest m >>=       unTest . k    fail err =-    Test . ExceptT . pure . Left $ Failure Nothing err Nothing--instance Monad m => MonadPlus (Test m) where-  mzero =-    discard--  mplus x y =-    Test . ExceptT . WriterT $-      mplus (runTest x) (runTest y)--instance Monad m => Alternative (Test m) where-  empty =-    mzero-  (<|>) =-    mplus+    TestT . ExceptT . pure . Left $ Failure Nothing err Nothing -instance MonadTrans Test where+instance MonadTrans TestT where   lift =-    Test . lift . lift . lift+    TestT . lift . lift -instance MFunctor Test where+instance MFunctor TestT where   hoist f =-    Test . hoist (hoist (hoist f)) . unTest--distributeTest :: Transformer t Test m => Test (t m) a -> t (Test m) a-distributeTest =-  hoist Test .-  distribute .-  hoist distribute .-  hoist (hoist distribute) .-  unTest+    TestT . hoist (hoist f) . unTest -instance Distributive Test where-  type Transformer t Test m = (-      Transformer t Gen m-    , Transformer t (WriterT [Log]) (Gen m)-    , Transformer t (ExceptT Failure) (WriterT [Log] (Gen m))+instance Distributive TestT where+  type Transformer t TestT m = (+      Transformer t (Lazy.WriterT [Log]) m+    , Transformer t (ExceptT Failure) (Lazy.WriterT [Log] m)     )    distribute =-    distributeTest+    hoist TestT .+    distribute .+    hoist distribute .+    unTest -instance PrimMonad m => PrimMonad (Test m) where-  type PrimState (Test m) =+instance PrimMonad m => PrimMonad (TestT m) where+  type PrimState (TestT m) =     PrimState m   primitive =     lift . primitive -instance MonadIO m => MonadIO (Test m) where-  liftIO =-    lift . liftIO--instance MonadBase b m => MonadBase b (Test m) where-  liftBase =-    lift . liftBase--instance MonadThrow m => MonadThrow (Test m) where-  throwM =-    lift . throwM--instance MonadCatch m => MonadCatch (Test m) where-  catch m onErr =-    Test $-      (unTest m) `catch`-      (unTest . onErr)--instance MonadReader r m => MonadReader r (Test m) where-  ask =-    lift ask-  local f m =-    Test $-      local f (unTest m)--instance MonadState s m => MonadState s (Test m) where-  get =-    lift get-  put =-    lift . put-  state =-    lift . state---- FIXME instance MonadWriter Test+-- FIXME instance MonadWriter w m => MonadWriter w (TestT m) -instance MonadError e m => MonadError e (Test m) where+instance MonadError e m => MonadError e (TestT m) where   throwError =     lift . throwError   catchError m onErr =-    Test . ExceptT $+    TestT . ExceptT $       (runExceptT $ unTest m) `catchError`       (runExceptT . unTest . onErr) -instance MonadResource m => MonadResource (Test m) where+instance MonadResource m => MonadResource (TestT m) where   liftResourceT =     lift . liftResourceT ---------------------------------------------------------------------------- Property+instance MonadTransControl TestT where+  type StT TestT a =+    (Either Failure a, [Log]) --- | The default configuration for a property test.----defaultConfig :: PropertyConfig-defaultConfig =-  PropertyConfig {-      propertyTestLimit =-        100-    , propertyDiscardLimit =-        100-    , propertyShrinkLimit =-        1000-    }+  liftWith f =+    mkTestT . fmap (, []) . fmap Right $ f $ runTestT --- | Map a config modification function over a property.----mapConfig :: (PropertyConfig -> PropertyConfig) -> Property -> Property-mapConfig f (Property cfg t) =-  Property (f cfg) t+  restoreT =+    mkTestT --- | Set the number times a property should be executed before it is considered---   successful.----withTests :: TestLimit -> Property -> Property-withTests n =-  mapConfig $ \config -> config { propertyTestLimit = n }+instance MonadBaseControl b m => MonadBaseControl b (TestT m) where+  type StM (TestT m) a =+    ComposeSt TestT m a --- | Set the number times a property is allowed to discard before the test---   runner gives up.----withDiscards :: DiscardLimit -> Property -> Property-withDiscards n =-  mapConfig $ \config -> config { propertyDiscardLimit = n }+  liftBaseWith =+    defaultLiftBaseWith --- | Set the number times a property is allowed to shrink before the test---   runner gives up and prints the counterexample.----withShrinks :: ShrinkLimit -> Property -> Property-withShrinks n =-  mapConfig $ \config -> config { propertyShrinkLimit = n }+  restoreM =+    defaultRestoreM --- | Creates a property to check.----property :: Test IO () -> Property-property =-  Property defaultConfig+class Monad m => MonadTest m where+  liftTest :: Test a -> m a ---------------------------------------------------------------------------- Test+instance Monad m => MonadTest (TestT m) where+  liftTest =+    hoist (pure . runIdentity) -runTest :: Test m a -> Gen m (Either Failure a, [Log])-runTest =-  runWriterT . runExceptT . unTest+instance MonadTest m => MonadTest (IdentityT m) where+  liftTest =+    lift . liftTest -writeLog :: Monad m => Log -> Test m ()-writeLog =-  Test . lift . tell . pure+instance MonadTest m => MonadTest (MaybeT m) where+  liftTest =+    lift . liftTest --- | Generates a random input for the test by running the provided generator.----forAll :: (Monad m, Show a, HasCallStack) => Gen m a -> Test m a-forAll gen =-  withFrozenCallStack $ forAllWith showPretty gen+instance MonadTest m => MonadTest (ExceptT x m) where+  liftTest =+    lift . liftTest --- | Generates a random input for the test by running the provided generator.+instance MonadTest m => MonadTest (ReaderT r m) where+  liftTest =+    lift . liftTest++instance MonadTest m => MonadTest (Lazy.StateT s m) where+  liftTest =+    lift . liftTest++instance MonadTest m => MonadTest (Strict.StateT s m) where+  liftTest =+    lift . liftTest++instance (MonadTest m, Monoid w) => MonadTest (Lazy.WriterT w m) where+  liftTest =+    lift . liftTest++instance (MonadTest m, Monoid w) => MonadTest (Strict.WriterT w m) where+  liftTest =+    lift . liftTest++instance (MonadTest m, Monoid w) => MonadTest (Lazy.RWST r w s m) where+  liftTest =+    lift . liftTest++instance (MonadTest m, Monoid w) => MonadTest (Strict.RWST r w s m) where+  liftTest =+    lift . liftTest++instance MonadTest m => MonadTest (ContT r m) where+  liftTest =+    lift . liftTest++instance MonadTest m => MonadTest (ResourceT m) where+  liftTest =+    lift . liftTest++mkTestT :: m (Either Failure a, [Log]) -> TestT m a+mkTestT =+  TestT . ExceptT . Lazy.WriterT++mkTest :: (Either Failure a, [Log]) -> Test a+mkTest =+  mkTestT . Identity++runTestT :: TestT m a -> m (Either Failure a, [Log])+runTestT =+  Lazy.runWriterT . runExceptT . unTest++runTest :: Test a -> (Either Failure a, [Log])+runTest =+  runIdentity . runTestT++-- | Log some information which might be relevant to a potential test failure. -----   /This is a the same as 'forAll' but allows the user to provide a custom/---   /rendering function. This is useful for values which don't have a/---   /'Show' instance./+writeLog :: MonadTest m => Log -> m ()+writeLog x =+  liftTest $ mkTest (pure (), [x])++-- | Fail the test with an error message, useful for building other failure+--   combinators. ---forAllWith :: (Monad m, HasCallStack) => (a -> String) -> Gen m a -> Test m a-forAllWith render gen = do-  x <- Test . lift $ lift gen-  withFrozenCallStack $ annotate (render x)-  return x+failWith :: (MonadTest m, HasCallStack) => Maybe Diff -> String -> m a+failWith diff msg =+  liftTest $ mkTest (Left $ Failure (getCaller callStack) msg diff, [])  -- | Annotates the source code with a message that might be useful for --   debugging a test failure. ---annotate :: (Monad m, HasCallStack) => String -> Test m ()+annotate :: (MonadTest m, HasCallStack) => String -> m () annotate x = do   writeLog $ Annotation (getCaller callStack) x  -- | Annotates the source code with a value that might be useful for --   debugging a test failure. ---annotateShow :: (Monad m, Show a, HasCallStack) => a -> Test m ()+annotateShow :: (MonadTest m, Show a, HasCallStack) => a -> m () annotateShow x = do   withFrozenCallStack $ annotate (showPretty x)  -- | Logs a message to be displayed as additional information in the footer of --   the failure report. ---footnote :: Monad m => String -> Test m ()+footnote :: MonadTest m => String -> m () footnote =   writeLog . Footnote  -- | Logs a value to be displayed as additional information in the footer of --   the failure report. ---footnoteShow :: (Monad m, Show a) => a -> Test m ()+footnoteShow :: (MonadTest m, Show a) => a -> m () footnoteShow =   writeLog . Footnote . showPretty --- | Discards a test entirely.+-- | Fails with an error which shows the difference between two values. ---discard :: Monad m => Test m a-discard =-  Test . lift $ lift Gen.discard+failDiff :: (MonadTest m, Show a, Show b, HasCallStack) => a -> b -> m ()+failDiff x y =+  case valueDiff <$> mkValue x <*> mkValue y of+    Nothing ->+      withFrozenCallStack $+        failWith Nothing $ unlines [+            "━━━ Not Equal ━━━"+          , showPretty x+          , showPretty y+          ]+    Just diff ->+      withFrozenCallStack $+        failWith (Just $ Diff "Failed (" "- lhs" "=/=" "+ rhs" ")" diff) "" --- | Fail with an error message, useful for building other failure combinators.+-- | Fails with an error which renders the type of an exception and its error+--   message. ---failWith :: (Monad m, HasCallStack) => Maybe Diff -> String -> Test m a-failWith diff msg =-  Test . ExceptT . pure . Left $ Failure (getCaller callStack) msg diff+failException :: (MonadTest m, HasCallStack) => SomeException -> m a+failException (SomeException x) =+  withFrozenCallStack $+    failWith Nothing $ unlines [+        "━━━ Exception: " ++ show (typeOf x) ++ " ━━━"+      , List.dropWhileEnd Char.isSpace (displayException x)+      ]  -- | Causes a test to fail. ---failure :: (Monad m, HasCallStack) => Test m a+failure :: (MonadTest m, HasCallStack) => m a failure =   withFrozenCallStack $ failWith Nothing ""  -- | Another name for @pure ()@. ---success :: Monad m => Test m ()+success :: MonadTest m => m () success =-  Test $ pure ()+  pure ()  -- | Fails the test if the condition provided is 'False'. ---assert :: (Monad m, HasCallStack) => Bool -> Test m ()-assert b =-  if b then+assert :: (MonadTest m, HasCallStack) => Bool -> m ()+assert b = do+  ok <- withFrozenCallStack $ eval b+  if ok then     success   else     withFrozenCallStack failure@@ -440,28 +543,44 @@  -- | Fails the test if the two arguments provided are not equal. ---(===) :: (Monad m, Eq a, Show a, HasCallStack) => a -> a -> Test m ()-(===) x y =-  if x == y then+(===) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()+(===) x y = do+  ok <- withFrozenCallStack $ eval (x == y)+  if ok then     success   else-    case valueDiff <$> mkValue x <*> mkValue y of-      Nothing ->-        withFrozenCallStack $-          failWith Nothing $ unlines [-              "━━━ Not Equal ━━━"-            , showPretty x-            , showPretty y-            ]-      Just diff ->-        withFrozenCallStack $-          failWith (Just $ Diff "Failed (" "- lhs" "=/=" "+ rhs" ")" diff) ""+    withFrozenCallStack $ failDiff x y +-- | Fails the test if the value throws an exception when evaluated to weak+--   head normal form (WHNF).+--+eval :: (MonadTest m, HasCallStack) => a -> m a+eval x =+  either (withFrozenCallStack failException) pure (tryEvaluate x)++-- | Fails the test if the action throws an exception.+--+--   /The benefit of using this over simply letting the exception bubble up is/+--   /that the location of the closest 'evalM' will be shown in the output./+--+evalM :: (MonadTest m, MonadCatch m, HasCallStack) => m a -> m a+evalM m =+  either (withFrozenCallStack failException) pure =<< tryAll m++-- | Fails the test if the 'IO' action throws an exception.+--+--   /The benefit of using this over 'liftIO' is that the location of the/+--   /exception will be shown in the output./+--+evalIO :: (MonadTest m, MonadIO m, HasCallStack) => IO a -> m a+evalIO m =+  either (withFrozenCallStack failException) pure =<< liftIO (tryAll m)+ -- | Fails the test if the 'Either' is 'Left', otherwise returns the value in --   the 'Right'. ---liftEither :: (Monad m, Show x, HasCallStack) => Either x a -> Test m a-liftEither = \case+evalEither :: (MonadTest m, Show x, HasCallStack) => Either x a -> m a+evalEither = \case   Left x ->     withFrozenCallStack $ failWith Nothing $ showPretty x   Right x ->@@ -470,63 +589,190 @@ -- | Fails the test if the 'ExceptT' is 'Left', otherwise returns the value in --   the 'Right'. ---liftExceptT :: (Monad m, Show x, HasCallStack) => ExceptT x m a -> Test m a-liftExceptT m =-  withFrozenCallStack liftEither =<< lift (runExceptT m)+evalExceptT :: (MonadTest m, Show x, HasCallStack) => ExceptT x m a -> m a+evalExceptT m =+  withFrozenCallStack evalEither =<< runExceptT m --- | Fails the test if the action throws an exception.+------------------------------------------------------------------------+-- PropertyT++instance MonadTrans PropertyT where+  lift =+    PropertyT . lift . lift++instance MFunctor PropertyT where+  hoist f =+    PropertyT . hoist (hoist f) . unPropertyT++instance Distributive PropertyT where+  type Transformer t PropertyT m = (+      Transformer t GenT m+    , Transformer t TestT (GenT m)+    )++  distribute =+    hoist PropertyT .+    distribute .+    hoist distribute .+    unPropertyT++instance PrimMonad m => PrimMonad (PropertyT m) where+  type PrimState (PropertyT m) =+    PrimState m+  primitive =+    lift . primitive++---- FIXME instance MonadWriter w m => MonadWriter w (PropertyT m)++instance Monad m => MonadTest (PropertyT m) where+  liftTest =+    PropertyT . hoist (pure . runIdentity)++instance MonadPlus m => MonadPlus (PropertyT m) where+  mzero =+    discard++  mplus (PropertyT x) (PropertyT y) =+    PropertyT . mkTestT $+      mplus (runTestT x) (runTestT y)++instance MonadPlus m => Alternative (PropertyT m) where+  empty =+    mzero+  (<|>) =+    mplus++-- | Generates a random input for the test by running the provided generator. -----   /The benefit of using this over 'lift' is that the location of the---   exception will be shown in the output./+--   /This is a the same as 'forAllT' but allows the user to provide a custom/+--   /rendering function. This is useful for values which don't have a/+--   /'Show' instance./ ---liftCatch :: (MonadCatch m, HasCallStack) => m a -> Test m a-liftCatch m =-  withFrozenCallStack liftEither =<< lift (tryAll m)+forAllWithT :: (Monad m, HasCallStack) => (a -> String) -> GenT m a -> PropertyT m a+forAllWithT render gen = do+  x <- PropertyT $ lift gen+  withFrozenCallStack $ annotate (render x)+  return x --- | Fails the test if the action throws an exception.+-- | Generates a random input for the test by running the provided generator. -----   /The benefit of using this over 'liftIO' is that the location of the---   exception will be shown in the output./+--   /This is a the same as 'forAll' but allows the user to provide a custom/+--   /rendering function. This is useful for values which don't have a/+--   /'Show' instance./ ---liftCatchIO :: (MonadIO m, HasCallStack) => IO a -> Test m a-liftCatchIO m =-  withFrozenCallStack liftEither =<< liftIO (tryAll m)+forAllWith :: (Monad m, HasCallStack) => (a -> String) -> Gen a -> PropertyT m a+forAllWith render gen =+  withFrozenCallStack $ forAllWithT render $ Gen.lift gen --- | Fails the test if the 'ExceptT' is 'Left', otherwise returns the value in---   the 'Right'.+-- | Generates a random input for the test by running the provided generator. ---withExceptT :: (Monad m, Show x, HasCallStack) => Test (ExceptT x m) a -> Test m a-withExceptT m =-  withFrozenCallStack liftEither =<< runExceptT (distribute m)+forAllT :: (Monad m, Show a, HasCallStack) => GenT m a -> PropertyT m a+forAllT gen =+  withFrozenCallStack $ forAllWithT showPretty gen --- | Fails the test if the action throws an exception.+-- | Generates a random input for the test by running the provided generator. -----   /The benefit of using this over simply letting the exception bubble up is---   that the location of the closest 'withCatch' will be shown in the output./+forAll :: (Monad m, Show a, HasCallStack) => Gen a -> PropertyT m a+forAll gen =+  withFrozenCallStack $ forAllWith showPretty gen++-- | Discards the current test entirely. ---withCatch :: (MonadCatch m, HasCallStack) => Test m a -> Test m a-withCatch m =-  withFrozenCallStack liftEither =<< tryAll m+discard :: Monad m => PropertyT m a+discard =+  PropertyT $ lift Gen.discard --- | Run a computation which requires resource acquisition / release.+-- | Lift a test in to a property. -----   /Note that if you 'Control.Monad.Trans.Resource.allocate' anything before/---   /a 'forAll' you will likely encounter unexpected behaviour, due to the way/---   /'ResourceT' interacts with the control flow introduced by shrinking./+--   Because both 'TestT' and 'PropertyT' have 'MonadTest' instances, this+--   function is not often required. It can however be useful for writing+--   functions directly in 'TestT' and thus gaining a 'MonadTransControl'+--   instance at the expense of not being able to generate additional inputs+--   using 'forAll'. ---withResourceT :: MonadResourceBase m => Test (ResourceT m) a -> Test m a-withResourceT =-  hoist runResourceT+--   One use case for this is writing tests which use 'ResourceT':+--+-- @+--   property $ do+--     n <- forAll $ Gen.int64 Range.linearBounded+--     test . runResourceT $ do+--       -- test with resource usage here+-- @+--+test :: Monad m => TestT m a -> PropertyT m a+test =+  PropertyT . hoist lift  ------------------------------------------------------------------------+-- Property++-- | The default configuration for a property test.+--+defaultConfig :: PropertyConfig+defaultConfig =+  PropertyConfig {+      propertyTestLimit =+        100+    , propertyDiscardLimit =+        100+    , propertyShrinkLimit =+        1000+    , propertyShrinkRetries =+        0+    }++-- | Map a config modification function over a property.+--+mapConfig :: (PropertyConfig -> PropertyConfig) -> Property -> Property+mapConfig f (Property cfg t) =+  Property (f cfg) t++-- | Set the number times a property should be executed before it is considered+--   successful.+--+withTests :: TestLimit -> Property -> Property+withTests n =+  mapConfig $ \config -> config { propertyTestLimit = n }++-- | Set the number times a property is allowed to discard before the test+--   runner gives up.+--+withDiscards :: DiscardLimit -> Property -> Property+withDiscards n =+  mapConfig $ \config -> config { propertyDiscardLimit = n }++-- | Set the number times a property is allowed to shrink before the test+--   runner gives up and prints the counterexample.+--+withShrinks :: ShrinkLimit -> Property -> Property+withShrinks n =+  mapConfig $ \config -> config { propertyShrinkLimit = n }++-- | Set the number times a property will be executed for each shrink before+--   the test runner gives up and tries a different shrink. See 'ShrinkRetries'+--   for more information.+--+withRetries :: ShrinkRetries -> Property -> Property+withRetries n =+  mapConfig $ \config -> config { propertyShrinkRetries = n }++-- | Creates a property with the default configuration.+--+property :: HasCallStack => PropertyT IO () -> Property+property m =+  Property defaultConfig $+    withFrozenCallStack (evalM m)++------------------------------------------------------------------------ -- FIXME Replace with DeriveLift when we drop 7.10 support.  $(deriveLift ''GroupName) $(deriveLift ''PropertyName) $(deriveLift ''PropertyConfig) $(deriveLift ''TestLimit)-$(deriveLift ''ShrinkLimit) $(deriveLift ''DiscardLimit)+$(deriveLift ''ShrinkLimit)+$(deriveLift ''ShrinkRetries)  ------------------------------------------------------------------------ -- Internal

@@ -6,7 +6,7 @@    , runTasks   , finalizeTask- +   , runActiveFinalizers   , dequeueMVar 

@@ -1,8 +1,8 @@ module Hedgehog.Internal.Region (     Region(..)   , newEmptyRegion-  , newRegion-  , forceRegion+  , newOpenRegion+  , openRegion   , setRegion   , displayRegions   , displayRegion@@ -10,7 +10,7 @@   , finishRegion   ) where -import           Control.Concurrent.STM (STM, TVar, atomically)+import           Control.Concurrent.STM (STM, TVar) import qualified Control.Concurrent.STM.TMVar as TMVar import qualified Control.Concurrent.STM.TVar as TVar import           Control.Monad.Catch (MonadMask(..), bracket)@@ -20,59 +20,61 @@ import qualified System.Console.Regions as Console  +data Body =+    Empty+  | Open ConsoleRegion+  | Closed+ newtype Region =   Region {-      unRegion :: TVar (Maybe ConsoleRegion)+      unRegion :: TVar Body     }  newEmptyRegion :: LiftRegion m => m Region newEmptyRegion =   liftRegion $ do-    ref <- TVar.newTVar Nothing+    ref <- TVar.newTVar Empty     pure $ Region ref -newRegion :: LiftRegion m => m Region-newRegion =+newOpenRegion :: LiftRegion m => m Region+newOpenRegion =   liftRegion $ do     region <- Console.openConsoleRegion Linear-    ref <- TVar.newTVar $ Just region+    ref <- TVar.newTVar $ Open region     pure $ Region ref -forceRegion :: LiftRegion m => Region -> String -> m ()-forceRegion (Region var) content =+openRegion :: LiftRegion m => Region -> String -> m ()+openRegion (Region var) content =   liftRegion $ do-    mregion <- TVar.readTVar var-    case mregion of-      Nothing -> do+    body <- TVar.readTVar var+    case body of+      Empty -> do         region <- Console.openConsoleRegion Linear-        TVar.writeTVar var $ Just region+        TVar.writeTVar var $ Open region         Console.setConsoleRegion region content -      Just region ->+      Open region ->         Console.setConsoleRegion region content +      Closed ->+        pure ()+ setRegion :: LiftRegion m => Region -> String -> m () setRegion (Region var) content =   liftRegion $ do-    mregion <- TVar.readTVar var-    case mregion of-      Nothing -> do+    body <- TVar.readTVar var+    case body of+      Empty ->         pure () -      Just region ->+      Open region ->         Console.setConsoleRegion region content -displayRegions :: (MonadIO m, MonadMask m) => m a -> m a-displayRegions io = do-  liftIO . atomically $ do-    -- clear old regions-    mxs <- TMVar.tryTakeTMVar Console.regionList-    case mxs of-      Nothing ->+      Closed ->         pure ()-      Just _xs ->-        TMVar.putTMVar Console.regionList [] +displayRegions :: (MonadIO m, MonadMask m) => m a -> m a+displayRegions io =   Console.displayConsoleRegions io  displayRegion ::@@ -82,29 +84,44 @@   => (Region -> m a)   -> m a displayRegion =-  displayRegions . bracket newRegion finishRegion+  displayRegions . bracket newOpenRegion finishRegion -moveToBottom :: ConsoleRegion -> STM ()-moveToBottom region = do-  mxs <- TMVar.tryTakeTMVar Console.regionList-  case mxs of-    Nothing ->-      pure ()-    Just xs0 ->-      let-        xs1 =-          filter (/= region) xs0-      in-        TMVar.putTMVar Console.regionList (region : xs1)+moveToBottom :: Region -> STM ()+moveToBottom (Region var) =+  liftRegion $ do+    body <- TVar.readTVar var+    case body of+      Empty ->+        pure () +      Open region -> do+        mxs <- TMVar.tryTakeTMVar Console.regionList+        case mxs of+          Nothing ->+            pure ()++          Just xs0 ->+            let+              xs1 =+                filter (/= region) xs0+            in+              TMVar.putTMVar Console.regionList (region : xs1)++      Closed ->+        pure ()+ finishRegion :: LiftRegion m => Region -> m () finishRegion (Region var) =   liftRegion $ do-    mregion <- TVar.readTVar var-    case mregion of-      Nothing ->-        pure ()+    body <- TVar.readTVar var+    case body of+      Empty -> do+        TVar.writeTVar var Closed -      Just region -> do+      Open region -> do         content <- Console.getConsoleRegion region         Console.finishConsoleRegion region content+        TVar.writeTVar var Closed++      Closed ->+        pure ()

@@ -29,11 +29,11 @@ import           Data.Semigroup ((<>))  import           Hedgehog.Internal.Config-import           Hedgehog.Internal.Gen (runGen, runDiscardEffect)+import           Hedgehog.Internal.Gen (runGenT, runDiscardEffect) import           Hedgehog.Internal.Property (Group(..), GroupName(..)) import           Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..))-import           Hedgehog.Internal.Property (ShrinkLimit, withTests)-import           Hedgehog.Internal.Property (Test, Log(..), Failure(..), runTest)+import           Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withTests)+import           Hedgehog.Internal.Property (PropertyT(..), Log(..), Failure(..), runTestT) import           Hedgehog.Internal.Queue import           Hedgehog.Internal.Region import           Hedgehog.Internal.Report@@ -44,10 +44,7 @@  import           Language.Haskell.TH.Lift (deriveLift) -import           System.Console.Regions (ConsoleRegion, RegionLayout(..))-import qualified System.Console.Regions as Console - -- | Configuration for a property test run. -- data RunnerConfig =@@ -85,16 +82,33 @@   _ ->     False +isSuccess :: Node m (Maybe (Either x a, b)) -> Bool+isSuccess =+  not . isFailure++runTreeN ::+     Monad m+  => ShrinkRetries+  -> Tree m (Maybe (Either x a, b))+  -> m (Node m (Maybe (Either x a, b)))+runTreeN n m = do+  o <- runTree m+  if n > 0 && isSuccess o then+    runTreeN (n - 1) m+  else+    pure o+ takeSmallest ::      MonadIO m   => Size   -> Seed   -> ShrinkCount   -> ShrinkLimit+  -> ShrinkRetries   -> (Progress -> m ())   -> Node m (Maybe (Either Failure (), [Log]))   -> m Result-takeSmallest size seed shrinks slimit updateUI = \case+takeSmallest size seed shrinks slimit retries updateUI = \case   Node Nothing _ ->     pure GaveUp @@ -112,9 +126,9 @@           pure $ Failed failure         else           findM xs (Failed failure) $ \m -> do-            o <- runTree m+            o <- runTreeN retries m             if isFailure o then-              Just <$> takeSmallest size seed (shrinks + 1) slimit updateUI o+              Just <$> takeSmallest size seed (shrinks + 1) slimit retries updateUI o             else               return Nothing @@ -128,7 +142,7 @@   => PropertyConfig   -> Size   -> Seed-  -> Test m ()+  -> PropertyT m ()   -> (Report Progress -> m ())   -> m (Report Result) checkReport cfg size0 seed0 test0 updateUI =@@ -156,7 +170,7 @@         case Seed.split seed of           (s0, s1) -> do             node@(Node x _) <--              runTree . runDiscardEffect $ runGen size s0 (runTest test)+              runTree . runDiscardEffect $ runGenT size s0 . runTestT $ unPropertyT test             case x of               Nothing ->                 loop tests (discards + 1) (size + 1) s1@@ -172,6 +186,7 @@                       seed                       0                       (propertyShrinkLimit cfg)+                      (propertyShrinkRetries cfg)                       (updateUI . mkReport)                       node @@ -198,14 +213,14 @@           Running ->             setRegion region ppprogress           Shrinking _ ->-            forceRegion region ppprogress+            openRegion region ppprogress      ppresult <- renderResult mcolor name result     case reportStatus result of       Failed _ ->-        forceRegion region ppresult+        openRegion region ppresult       GaveUp ->-        forceRegion region ppresult+        openRegion region ppresult       OK ->         setRegion region ppresult @@ -258,10 +273,10 @@       summaryFailed summary == 0 &&       summaryGaveUp summary == 0 -updateSummary :: ConsoleRegion -> TVar Summary -> Maybe UseColor -> (Summary -> Summary) -> IO ()+updateSummary :: Region -> TVar Summary -> Maybe UseColor -> (Summary -> Summary) -> IO () updateSummary sregion svar mcolor f = do   summary <- atomically (TVar.modifyTVar' svar f >> TVar.readTVar svar)-  Console.setConsoleRegion sregion =<< renderSummary mcolor summary+  setRegion sregion =<< renderSummary mcolor summary  checkGroupWith ::      WorkerCount@@ -270,8 +285,7 @@   -> [(PropertyName, Property)]   -> IO Summary checkGroupWith n verbosity mcolor props =-  displayRegions $ do-    sregion <- Console.openConsoleRegion Linear+  displayRegion $ \sregion -> do     svar <- atomically . TVar.newTVar $ mempty { summaryWaiting = PropertyCount (length props) }      let@@ -290,7 +304,7 @@                 Quiet ->                   newEmptyRegion                 Normal ->-                  newRegion+                  newOpenRegion              moveToBottom sregion @@ -314,8 +328,6 @@           pure result      updateSummary sregion svar mcolor (const summary)-    Console.finishConsoleRegion sregion =<< Console.getConsoleRegion sregion-     pure summary  -- | Check a group of properties sequentially.

@@ -3,6 +3,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-}@@ -14,8 +15,12 @@ module Hedgehog.Internal.State (   -- * Variables     Var(..)-  , Symbolic(..)+  , concrete+  , opaque+   , Concrete(..)+  , Symbolic(..)+  , Name(..)    -- * Environment   , Environment(..)@@ -33,49 +38,60 @@    -- * Actions   , Action(..)+  , Sequential(..)+  , Parallel(..)   , takeVariables   , variablesOK   , dropInvalid   , action-  , actions-  , execute+  , sequential+  , parallel   , executeSequential+  , executeParallel   ) where -import           Control.Monad (when, foldM_)+import qualified Control.Concurrent.Async.Lifted as Async+import           Control.Monad (foldM, foldM_) import           Control.Monad.Catch (MonadCatch)-import           Control.Monad.Morph (hoist)-import           Control.Monad.State.Class (get, put, modify)+import           Control.Monad.State.Class (MonadState, get, put, modify) import           Control.Monad.Trans.Class (lift)-import           Control.Monad.Trans.State (StateT, execState, evalStateT)+import           Control.Monad.Trans.Control (MonadBaseControl)+import           Control.Monad.Trans.State (State, runState, execState)+import           Control.Monad.Trans.State (StateT(..), evalStateT)  import           Data.Dynamic (Dynamic, toDyn, fromDynamic, dynTypeRep) import           Data.Foldable (traverse_)-import           Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..), showsPrec1)+import           Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..))+import           Data.Functor.Classes (eq1, compare1, showsPrec1) 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 (Gen)+import           Hedgehog.Internal.Gen (MonadGen) import qualified Hedgehog.Internal.Gen as Gen import           Hedgehog.Internal.HTraversable (HTraversable(..))-import           Hedgehog.Internal.Property (Test, liftEither, withCatch, success)-import qualified Hedgehog.Internal.Shrink as Shrink-import           Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack)+import           Hedgehog.Internal.Opaque (Opaque(..))+import           Hedgehog.Internal.Property (MonadTest(..), Test, evalEither, evalM, success, runTest, failWith) import           Hedgehog.Internal.Range (Range)+import           Hedgehog.Internal.Show (showPretty)+import           Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack)   -- | Symbolic variable names. ---newtype Var =-  Var Int-  deriving (Eq, Ord, Show, Num)+newtype Name =+  Name Int+  deriving (Eq, Ord, Num) +instance Show Name where+  showsPrec p (Name x) =+    showsPrec p x+ -- | Symbolic values. -- data Symbolic a where-  Symbolic :: Typeable a => Var -> Symbolic a+  Symbolic :: Typeable a => Name -> Symbolic a  deriving instance Eq (Symbolic a) deriving instance Ord (Symbolic a)@@ -119,19 +135,71 @@     comp x y  ------------------------------------------------------------------------++-- | Variables are the potential or actual result of executing an action. They+--   are parameterised by either `Symbolic` or `Concrete` depending on the+--   phase of the test.+--+--   `Symbolic` variables are the potential results of actions. These are used+--   when generating the sequence of actions to execute. They allow actions+--   which occur later in the sequence to make use of the result of an action+--   which came earlier in the sequence.+--+--   `Concrete` variables are the actual results of actions. These are used+--   during test execution. They provide access to the actual runtime value of+--   a variable.+--+--   The state update `Callback` for a command needs to be polymorphic in the+--   type of variable because it is used in both the generation and the+--   execution phase.+--+data Var a v =+  Var (v a)++-- | Take the value from a concrete variable.+--+concrete :: Var a Concrete -> a+concrete (Var (Concrete x)) =+  x++-- | Take the value from an opaque concrete variable.+--+opaque :: Var (Opaque a) Concrete -> a+opaque (Var (Concrete (Opaque x))) =+  x++instance (Eq a, Eq1 v) => Eq (Var a v) where+  (==) (Var x) (Var y) =+    eq1 x y++instance (Ord a, Ord1 v) => Ord (Var a v) where+  compare (Var x) (Var y) =+    compare1 x y++instance (Show a, Show1 v) => Show (Var a v) where+  showsPrec p (Var x) =+    showParen (p >= 11) $+      showString "Var " .+      showsPrec1 11 x++instance HTraversable (Var a) where+  htraverse f (Var v) =+    fmap Var (f v)++------------------------------------------------------------------------ -- Symbolic Environment  -- | A mapping of symbolic values to concrete values. -- newtype Environment =   Environment {-      unEnvironment :: Map Var Dynamic+      unEnvironment :: Map Name Dynamic     } deriving (Show)  -- | Environment errors. -- data EnvironmentError =-    EnvironmentValueNotFound !Var+    EnvironmentValueNotFound !Name   | EnvironmentTypeError !TypeRep !TypeRep     deriving (Eq, Ord, Show) @@ -179,7 +247,7 @@  -- | Optional command configuration. ---data Callback input output m state =+data Callback input output state =   -- | A pre-condition for a command that must be verified before the command   --   can be executed. This is mainly used during shrinking to ensure that it   --   is still OK to run a command despite the fact that some previously@@ -192,17 +260,20 @@   --   it must work over 'Symbolic' values when we are generating actions, and   --   'Concrete' values when we are executing them.   ---  | Update (forall v. Ord1 v => state v -> input v -> v output -> state v)+  | Update (forall v. Ord1 v => state v -> input v -> Var output v -> state v)    -- | A post-condition for a command that must be verified for the command to   --   be considered a success.   ---  | Ensure (state Concrete -> input Concrete -> output -> Test m ())+  --   This callback receives the state prior to execution as the first+  --   argument, and the state after execution as the second argument.+  --+  | Ensure (state Concrete -> state Concrete -> input Concrete -> output -> Test ())  callbackRequire1 ::      state Symbolic   -> input Symbolic-  -> Callback input output m state+  -> Callback input output state   -> Bool callbackRequire1 s i = \case   Require f ->@@ -216,8 +287,8 @@      Ord1 v   => state v   -> input v-  -> v output-  -> Callback input output m state+  -> Var output v+  -> Callback input output state   -> state v callbackUpdate1 s i o = \case   Require _ ->@@ -228,22 +299,22 @@     s  callbackEnsure1 ::-     Monad m-  => state Concrete+     state Concrete+  -> state Concrete   -> input Concrete   -> output-  -> Callback input output m state-  -> Test m ()-callbackEnsure1 s i o = \case+  -> Callback input output state+  -> Test ()+callbackEnsure1 s0 s i o = \case   Require _ ->     success   Update _ ->     success   Ensure f ->-    f s i o+    f s0 s i o  callbackRequire ::-     [Callback input output m state]+     [Callback input output state]   -> state Symbolic   -> input Symbolic   -> Bool@@ -252,23 +323,23 @@  callbackUpdate ::      Ord1 v-  => [Callback input output m state]+  => [Callback input output state]   -> state v   -> input v-  -> v output+  -> Var output v   -> state v callbackUpdate callbacks s0 i o =   foldl (\s -> callbackUpdate1 s i o) s0 callbacks  callbackEnsure ::-     Monad m-  => [Callback input output m state]+     [Callback input output state]   -> state Concrete+  -> state Concrete   -> input Concrete   -> output-  -> Test m ()-callbackEnsure callbacks s i o =-  traverse_ (callbackEnsure1 s i o) callbacks+  -> Test ()+callbackEnsure callbacks s0 s i o =+  traverse_ (callbackEnsure1 s0 s i o) callbacks  ------------------------------------------------------------------------ @@ -283,18 +354,18 @@     --   'Nothing'.     --       commandGen ::-        state Symbolic -> Maybe (Gen n (input Symbolic))+        state Symbolic -> Maybe (n (input Symbolic))      -- | Executes a command using the arguments generated by 'commandGen'.     --     , commandExecute ::-        input Concrete -> Test m output+        input Concrete -> m output      -- | A set of callbacks which provide optional command configuration such     --   as pre-condtions, post-conditions and state updates.     --     , commandCallbacks ::-        [Callback input output m state]+        [Callback input output state]     }  -- | Checks that input for a command can be executed in the given state.@@ -317,45 +388,46 @@         Symbolic output      , actionExecute ::-        input Concrete -> Test m output+        input Concrete -> m output      , actionRequire ::         state Symbolic -> input Symbolic -> Bool      , actionUpdate ::-        forall v. Ord1 v => state v -> input v -> v output -> state v+        forall v. Ord1 v => state v -> input v -> Var output v -> state v      , actionEnsure ::-        state Concrete -> input Concrete -> output -> Test m ()+        state Concrete -> state Concrete -> input Concrete -> output -> Test ()     }  instance Show (Action m state) where-  showsPrec p (Action input output _ _ _ _) =+  showsPrec p (Action input (Symbolic (Name output)) _ _ _ _) =     showParen (p > 10) $+      showString "Var " .       showsPrec 11 output .       showString " :<- " .       showsPrec 11 input  -- | Extract the variable name and the type from a symbolic value. ---takeSymbolic :: forall a. Symbolic a -> (Var, TypeRep)-takeSymbolic (Symbolic var) =-  (var, typeRep (Proxy :: Proxy a))+takeSymbolic :: forall a. Symbolic a -> (Name, TypeRep)+takeSymbolic (Symbolic name) =+  (name, typeRep (Proxy :: Proxy a))  -- | Insert a symbolic variable in to a map of variables to types. ---insertSymbolic :: Symbolic a -> Map Var TypeRep -> Map Var TypeRep+insertSymbolic :: Symbolic a -> Map Name TypeRep -> Map Name TypeRep insertSymbolic s =   let-    (var, typ) =+    (name, typ) =       takeSymbolic s   in-    Map.insert var typ+    Map.insert name typ  -- | Collects all the symbolic values in a data structure and produces a set of --   all the variables they refer to. ---takeVariables :: forall t. HTraversable t => t Symbolic -> Map Var TypeRep+takeVariables :: forall t. HTraversable t => t Symbolic -> Map Name TypeRep takeVariables xs =   let     go x = do@@ -367,7 +439,7 @@ -- | Checks that the symbolic values in the data structure refer only to the --   variables in the provided set, and that they are of the correct type. ---variablesOK :: HTraversable t => t Symbolic -> Map Var TypeRep -> Bool+variablesOK :: HTraversable t => t Symbolic -> Map Name TypeRep -> Bool variablesOK xs allowed =   let     vars =@@ -376,58 +448,87 @@     Map.null (vars `Map.difference` allowed) &&     and (Map.intersectionWith (==) vars allowed) +data Context state =+  Context {+      contextState :: state Symbolic+    , _contextVars :: Map Name TypeRep+    }++mkContext :: state Symbolic -> Context state+mkContext initial =+  Context initial Map.empty++contextUpdate :: MonadState (Context state) m => state Symbolic -> m ()+contextUpdate state = do+  Context _ vars <- get+  put $ Context state vars++contextNewVar :: (MonadState (Context state) m, Typeable a) => m (Symbolic a)+contextNewVar = do+  Context state vars <- get++  let+    var =+      case Map.maxViewWithKey vars of+        Nothing ->+          Symbolic 0+        Just ((name, _), _) ->+          Symbolic (name + 1)++  put $ Context state (insertSymbolic var vars)+  pure var+ -- | Drops invalid actions from the sequence. ---dropInvalid :: (forall v. state v) -> [Action m state] -> [Action m state]-dropInvalid initial =+dropInvalid :: [Action m state] -> State (Context state) [Action m state]+dropInvalid =   let     loop step@(Action input output _execute require update _ensure) = do-      ((state0, vars0), steps0) <- get+      Context state0 vars0 <- get -      when (require state0 input && variablesOK input vars0) $+      if require state0 input && variablesOK input vars0 then do         let           state =-            update state0 input output+            update state0 input (Var output)            vars =             insertSymbolic output vars0 -          steps =-            steps0 ++ [step]-        in-          put ((state, vars), steps)+        put $ Context state vars+        pure $ Just step+      else+        pure Nothing   in-    snd . flip execState ((initial, Map.empty), []) . traverse_ loop+    fmap Maybe.catMaybes . traverse loop  -- | Generates a single action from a set of possible commands. -- action ::-     (Monad n, Monad m)+     (MonadGen n, MonadTest m)   => [Command n m state]-  -> Gen (StateT (state Symbolic, Var) n) (Action m state)+  -> StateT (Context state) n (Action m state) action commands =   Gen.just $ do-    (state, var) <- get+    Context state0 _ <- get      Command mgenInput exec callbacks <--      Gen.element $ filter (\c -> commandGenOK c state) commands+      Gen.element $ filter (\c -> commandGenOK c state0) commands      input <--      case mgenInput state of+      case mgenInput state0 of         Nothing ->           error "genCommand: internal error, tried to use generator with invalid state."         Just g ->-          hoist lift g+          lift g -    if not $ callbackRequire callbacks state input then+    if not $ callbackRequire callbacks state0 input then       pure Nothing      else do-      let-        output =-          Symbolic var+      output <- contextNewVar -      put (callbackUpdate callbacks state input output, var + 1)+      contextUpdate $+        callbackUpdate callbacks state0 input (Var output)        pure . Just $         Action input output exec@@ -435,31 +536,139 @@           (callbackUpdate callbacks)           (callbackEnsure callbacks) +genActions ::+     (MonadGen n, MonadTest m)+  => Range Int+  -> [Command n m state]+  -> Context state+  -> n ([Action m state], Context state)+genActions range commands ctx = do+  xs <- Gen.list range (action commands) `evalStateT` ctx+  pure $+    dropInvalid xs `runState` ctx++-- | A sequence of actions to execute.+--+data Sequential m state =+  Sequential {+      -- | The sequence of actions.+      sequentialActions :: [Action m state]+    }++renderAction :: Action m state -> [String]+renderAction (Action input (Symbolic (Name output)) _ _ _ _) =+  let+    prefix0 =+      "Var " ++ show output ++ " = "++    prefix =+      replicate (length prefix0) ' '+  in+    case lines (showPretty input) of+      [] ->+        [prefix0 ++ "?"]+      x : xs ->+        (prefix0 ++ x) :+        fmap (prefix ++) xs++-- FIXME we should not abuse Show to get nice output for actions+instance Show (Sequential m state) where+  show (Sequential xs) =+    unlines $ concatMap renderAction xs+ -- | Generates a sequence of actions from an initial model state and set of commands. ---actions ::-     (Monad n, Monad m)+sequential ::+     (MonadGen n, MonadTest m)   => Range Int   -> (forall v. state v)   -> [Command n m state]-  -> Gen n [Action m state]-actions range initial =-  fmap (dropInvalid initial) .-  Gen.shrink Shrink.list .-  hoist (flip evalStateT (initial, 0)) .-  Gen.list range .-  action+  -> n (Sequential m state)+sequential range initial commands =+  fmap (Sequential . fst) $+    genActions range commands (mkContext initial) +-- | A sequential prefix of actions to execute, with two branches to execute in parallel.+--+data Parallel m state =+  Parallel {+      -- | The sequential prefix.+      parallelPrefix :: [Action m state]++      -- | The first branch.+    , parallelBranch1 :: [Action m state]++      -- | The second branch.+    , parallelBranch2 :: [Action m state]+    }++-- FIXME we should not abuse Show to get nice output for actions+instance Show (Parallel m state) where+  show (Parallel pre xs ys) =+    unlines $ concat [+        ["━━━ Prefix ━━━"]+      ,  (concatMap renderAction pre)+      , ["", "━━━ Branch 1 ━━━"]+      ,  (concatMap renderAction xs)+      , ["", "━━━ Branch 2 ━━━"]+      ,  (concatMap renderAction ys)+      ]++-- | Given the initial model state and set of commands, generates prefix+--   actions to be run sequentially, followed by two branches to be run in+--   parallel.+--+parallel ::+     (MonadGen n, MonadTest m)+  => Range Int+  -> Range Int+  -> (forall v. state v)+  -> [Command n m state]+  -> n (Parallel m state)+parallel prefixN parallelN initial commands = do+  (prefix, ctx0) <- genActions prefixN commands (mkContext initial)+  (branch1, ctx1) <- genActions parallelN commands ctx0+  (branch2, _ctx2) <- genActions parallelN commands ctx1 { contextState = contextState ctx0 }++  pure $ Parallel prefix branch1 branch2++data ActionCheck state =+  ActionCheck {+      checkUpdate :: state Concrete -> state Concrete+    , checkEnsure :: state Concrete -> state Concrete -> Test ()+    }++execute :: (MonadTest m, HasCallStack) => Action m state -> StateT Environment m (ActionCheck state)+execute (Action sinput soutput exec _require update ensure) =+  withFrozenCallStack $ do+    env0 <- get+    input <- evalEither $ reify env0 sinput+    output <- lift $ exec input++    let+      coutput =+        Concrete output++      env =+        insertConcrete soutput coutput env0++    put env++    pure $+      ActionCheck+        (\s0 -> update s0 input (Var coutput))+        (\s0 s -> ensure s0 s input output)+ -- | Executes a single action in the given evironment. ---execute ::-     (HasCallStack, Monad m)+executeUpdateEnsure ::+     (MonadTest m, HasCallStack)   => (state Concrete, Environment)   -> Action m state-  -> Test m (state Concrete, Environment)-execute (state0, env0) (Action sinput soutput exec _require update ensure) =+  -> m (state Concrete, Environment)+executeUpdateEnsure (state0, env0) (Action sinput soutput exec _require update ensure) =   withFrozenCallStack $ do-    input <- liftEither $ reify env0 sinput+    input <- evalEither $ reify env0 sinput     output <- exec input      let@@ -467,12 +676,12 @@         Concrete output        state =-        update state0 input coutput+        update state0 input (Var coutput)        env =         insertConcrete soutput coutput env0 -    ensure state input output+    liftTest $ ensure state0 state input output      pure (state, env) @@ -480,14 +689,84 @@ --   post-conditions are met and no exceptions are thrown. -- --   To generate a sequence of actions to execute, see the---   'Hedgehog.Gen.actions' combinator in the "Hedgehog.Gen" module.+--   'Hedgehog.Gen.sequential' combinator in the "Hedgehog.Gen" module. -- executeSequential ::-     forall m state.-     (HasCallStack, MonadCatch m)+     (MonadTest m, MonadCatch m, HasCallStack)   => (forall v. state v)-  -> [Action m state]-  -> Test m ()-executeSequential initial commands =+  -> Sequential m state+  -> m ()+executeSequential initial (Sequential xs) =+  withFrozenCallStack $ evalM $+    foldM_ executeUpdateEnsure (initial, emptyEnvironment) xs++successful :: Test () -> Bool+successful x =+  case runTest x of+    (Left _, _) ->+      False+    (Right _, _) ->+      True++interleave :: [a] -> [a] -> [[a]]+interleave xs00 ys00 =+  case (xs00, ys00) of+    ([], []) ->+      []+    (xs, []) ->+      [xs]+    ([], ys) ->+      [ys]+    (xs0@(x:xs), ys0@(y:ys)) ->+      [ x : zs | zs <- interleave xs ys0 ] +++      [ y : zs | zs <- interleave xs0 ys ]++checkActions :: state Concrete -> [ActionCheck state] -> Test ()+checkActions s0 = \case+  [] ->+    pure ()+  x : xs -> do+    let+      s =+        checkUpdate x s0++    checkEnsure x s0 s+    checkActions s xs++linearize :: MonadTest m => state Concrete -> [ActionCheck state] -> [ActionCheck state] -> m ()+linearize initial branch1 branch2 =   withFrozenCallStack $-    withCatch (foldM_ execute (initial, emptyEnvironment) commands)+    let+      ok =+        any successful .+        fmap (checkActions initial) $+        interleave branch1 branch2+    in+      if ok then+        pure ()+      else+        failWith Nothing "no valid interleaving"+++-- | Executes the prefix actions sequentially, then executes the two branches+--   in parallel, verifying that no exceptions are thrown and that there is at+--   least one sequential interleaving where all the post-conditions are met.+--+--   To generate parallel actions to execute, see the 'Hedgehog.Gen.parallel'+--   combinator in the "Hedgehog.Gen" module.+--+executeParallel ::+     (MonadTest m, MonadCatch m, MonadBaseControl IO m, HasCallStack)+  => (forall v. state v)+  -> Parallel m state+  -> m ()+executeParallel initial (Parallel prefix branch1 branch2) =+  withFrozenCallStack $ evalM $ do+    (s0, env0) <- foldM executeUpdateEnsure (initial, emptyEnvironment) prefix++    (xs, ys) <-+      Async.concurrently+        (evalStateT (traverse execute branch1) env0)+        (evalStateT (traverse execute branch2) env0)++    linearize s0 xs ys

@@ -10,16 +10,11 @@ -- | Test that a pair of encode / decode functions are compatible. -- tripping ::-     HasCallStack-  => Applicative f-  => Monad m-  => Show b-  => Show (f a)-  => Eq (f a)+     (MonadTest m, Applicative f, Show b, Show (f a), Eq (f a), HasCallStack)   => a   -> (a -> b)   -> (b -> f a)-  -> Test m ()+  -> m () tripping x encode decode =   let     mx =

@@ -12,11 +12,11 @@ import           Text.Read (readEither)  -genSize :: Monad m => Gen m Size+genSize :: Gen Size genSize =   Size <$> Gen.enumBounded -genOdd :: Monad m => Gen m Int64+genOdd :: Gen Int64 genOdd =   let     mkOdd x =@@ -27,19 +27,19 @@   in     mkOdd <$> Gen.int64 (Range.constant 1 maxBound) -genSeed :: Monad m => Gen m Seed+genSeed :: Gen Seed genSeed =   Seed <$> Gen.enumBounded <*> genOdd -genPrecedence :: Monad m => Gen m Int+genPrecedence :: Gen Int genPrecedence =   Gen.int (Range.constant 0 11) -genString :: Monad m => Gen m String+genString :: Gen String genString =   Gen.string (Range.constant 0 100) Gen.alpha -checkShowAppend :: (Typeable a, Show a) => Gen IO a -> Property+checkShowAppend :: (Typeable a, Show a) => Gen a -> Property checkShowAppend gen =   property $ do     prec <- forAll genPrecedence@@ -48,7 +48,7 @@     ysuffix <- forAll genString     showsPrec prec x xsuffix ++ ysuffix  === showsPrec prec x (xsuffix ++ ysuffix) -trippingReadShow :: (Eq a, Typeable a, Show a, Read a) => Gen IO a -> Property+trippingReadShow :: (Eq a, Typeable a, Show a, Read a) => Gen a -> Property trippingReadShow gen =   property $ do     prec <- forAll genPrecedence