hedgehog 0.3 → 0.4

raw patch · 15 files changed

+2524/−1747 lines, 15 filesdep ~transformersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• README.md +3/−1
• hedgehog.cabal +8/−2
• src/Hedgehog.hs +41/−5
• src/Hedgehog/Gen.hs +110/−1304
• src/Hedgehog/Internal/Distributive.hs +2/−0
• src/Hedgehog/Internal/Exception.hs +42/−0
• src/Hedgehog/Internal/Gen.hs +1304/−0
• src/Hedgehog/Internal/HTraversable.hs +10/−0
• src/Hedgehog/Internal/Opaque.hs +25/−0
• src/Hedgehog/Internal/Property.hs +34/−2
• src/Hedgehog/Internal/Range.hs +461/−0
• src/Hedgehog/Internal/Runner.hs +3/−4
• src/Hedgehog/Internal/State.hs +474/−0
• src/Hedgehog/Range.hs +2/−429

@@ -1,3 +1,8 @@+## 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)+ ## Version 0.3 (2017-06-11)  - Exponential range combinators (#43, @chris-martin)

@@ -57,6 +57,8 @@ to run manually instead:  ```hs+{-# LANGUAGE OverloadedStrings #-}+ tests :: IO Bool tests =   checkParallel $ Group "Test.Example" [@@ -74,7 +76,7 @@ ```   [hackage]: http://hackage.haskell.org/package/hedgehog- [hackage-shield]: https://img.shields.io/badge/hackage-v0.3-blue.svg+ [hackage-shield]: https://img.shields.io/badge/hackage-v0.4-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.3+  0.4 license:   BSD3 author:@@ -65,7 +65,7 @@     , text                            >= 1.1        && < 1.3     , th-lift                         >= 0.7        && < 0.8     , time                            >= 1.4        && < 1.9-    , transformers                    >= 0.3        && < 0.6+    , transformers                    >= 0.5        && < 0.6     , transformers-base               >= 0.4        && < 0.5     , wl-pprint-annotated             >= 0.0        && < 0.2 @@ -91,8 +91,13 @@     Hedgehog.Internal.Config     Hedgehog.Internal.Discovery     Hedgehog.Internal.Distributive+    Hedgehog.Internal.Exception+    Hedgehog.Internal.Gen+    Hedgehog.Internal.HTraversable+    Hedgehog.Internal.Opaque     Hedgehog.Internal.Property     Hedgehog.Internal.Queue+    Hedgehog.Internal.Range     Hedgehog.Internal.Region     Hedgehog.Internal.Report     Hedgehog.Internal.Runner@@ -100,6 +105,7 @@     Hedgehog.Internal.Show     Hedgehog.Internal.Shrink     Hedgehog.Internal.Source+    Hedgehog.Internal.State     Hedgehog.Internal.TH     Hedgehog.Internal.Tree     Hedgehog.Internal.Tripping

@@ -29,6 +29,8 @@ -- If you prefer to avoid macros, you can specify the group of properties to -- run manually instead: --+-- > {-# LANGUAGE OverloadedStrings #-}+-- > -- > tests :: IO Bool -- > tests = -- >   checkParallel $ Group "Test.Example" [@@ -82,33 +84,67 @@   , assert   , (===) +  , liftCatch+  , liftCatchIO   , liftEither   , liftExceptT++  , withCatch   , withExceptT   , withResourceT    , tripping +  -- * Abstract State Machine+  , Command(..)+  , Callback(..)+  , Action+  , executeSequential++  , Concrete(..)+  , Symbolic(..)+  , Var+  , Opaque(..)+   -- * Transformers   , distribute++  -- * Functors+  , HTraversable(..)++  , Eq1+  , eq1++  , Ord1+  , compare1++  , Show1+  , showsPrec1   ) where -import           Hedgehog.Gen (Gen)-import           Hedgehog.Internal.Distributive (distribute)+import           Data.Functor.Classes (Eq1, eq1, Ord1, compare1, Show1, showsPrec1)++import           Hedgehog.Internal.Distributive (Distributive(..))+import           Hedgehog.Internal.Gen (Gen)+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 (footnote, footnoteShow) import           Hedgehog.Internal.Property (forAll, forAllWith)-import           Hedgehog.Internal.Property (liftEither, liftExceptT)+import           Hedgehog.Internal.Property (liftCatch, liftCatchIO, liftEither, liftExceptT) import           Hedgehog.Internal.Property (Property, PropertyName, Group(..), GroupName) import           Hedgehog.Internal.Property (ShrinkLimit, withShrinks) import           Hedgehog.Internal.Property (Test, property) import           Hedgehog.Internal.Property (TestLimit, withTests)-import           Hedgehog.Internal.Property (withExceptT, withResourceT)+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.TH (discover) import           Hedgehog.Internal.Tripping (tripping)-import           Hedgehog.Range (Range, Size(..))

@@ -1,1304 +1,110 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-} -- MonadBase-module Hedgehog.Gen (-  -- * Transformer-    Gen(..)--  -- * Combinators-  -- ** Shrinking-  , shrink-  , prune--  -- ** Size-  , small-  , scale-  , resize-  , sized--  -- ** Integral-  , integral-  , integral_--  , int-  , int8-  , int16-  , int32-  , int64--  , word-  , word8-  , word16-  , word32-  , word64--  -- ** Floating-point-  , realFloat-  , realFrac_-  , float-  , double--  -- ** Enumeration-  , enum-  , enumBounded-  , bool-  , bool_--  -- ** Characters-  , binit-  , octit-  , digit-  , hexit-  , lower-  , upper-  , alpha-  , alphaNum-  , ascii-  , latin1-  , unicode-  , unicodeAll--  -- ** Strings-  , string-  , text-  , utf8-  , bytes--  -- ** Choice-  , constant-  , element-  , choice-  , frequency-  , recursive--  -- ** Conditional-  , discard-  , filter-  , just--  -- ** Collections-  , maybe-  , list-  , seq-  , nonEmpty-  , set-  , map--  -- ** Subterms-  , subterm-  , subtermM-  , subterm2-  , subtermM2-  , subterm3-  , subtermM3--  -- ** Combinations & Permutations-  , subsequence-  , shuffle--  -- * Sampling Generators-  , sample-  , print-  , printTree-  , printWith-  , printTreeWith--  -- * Internal-  -- $internal--  -- ** Transfomer-  , runGen-  , mapGen-  , generate-  , liftTree-  , runDiscardEffect--  -- ** Size-  , golden--  -- ** Shrinking-  , atLeast--  -- ** Characters-  , isSurrogate--  -- ** Subterms-  , Vec(..)-  , Nat(..)-  , subtermMVec-  , freeze--  -- ** Sampling-  , renderNodes-  ) where--import           Control.Applicative (Alternative(..))-import           Control.Monad (MonadPlus(..), mfilter, 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.Primitive (PrimMonad(..))-import           Control.Monad.Reader.Class (MonadReader(..))-import           Control.Monad.State.Class (MonadState(..))-import           Control.Monad.Trans.Class (MonadTrans(..))-import           Control.Monad.Trans.Maybe (MaybeT(..))-import           Control.Monad.Trans.Resource (MonadResource(..))-import           Control.Monad.Writer.Class (MonadWriter(..))--import           Data.Bifunctor (first)-import           Data.ByteString (ByteString)-import qualified Data.ByteString as ByteString-import qualified Data.Char as Char-import           Data.Foldable (for_, toList)-import           Data.Int (Int8, Int16, Int32, Int64)-import           Data.List.NonEmpty (NonEmpty)-import qualified Data.List.NonEmpty as NonEmpty-import           Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.Maybe as Maybe-import           Data.Sequence (Seq)-import qualified Data.Sequence as Seq-import           Data.Set (Set)-import           Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import           Data.Word (Word8, Word16, Word32, Word64)--import           Hedgehog.Internal.Distributive (Distributive(..))-import           Hedgehog.Internal.Seed (Seed)-import qualified Hedgehog.Internal.Seed as Seed-import qualified Hedgehog.Internal.Shrink as Shrink-import           Hedgehog.Internal.Tree (Tree(..), Node(..))-import qualified Hedgehog.Internal.Tree as Tree-import           Hedgehog.Range (Size, Range)-import qualified Hedgehog.Range as Range--import           Prelude hiding (filter, print, maybe, map, seq)------------------------------------------------------------------------------ Generator transformer---- | Generator for random values of @a@.----newtype Gen m a =-  Gen {-      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) =-  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)---- | Lift a predefined shrink tree in to a generator, ignoring the seed and the---   size.----liftTree :: Tree (MaybeT m) a -> Gen m a-liftTree x =-  Gen (\_ _ -> x)---- | Run the discard effects through the tree and reify them as 'Maybe' values---   at the nodes. 'Nothing' means discarded, 'Just' means we have a value.----runDiscardEffect :: Monad m => Tree (MaybeT m) a -> Tree m (Maybe a)-runDiscardEffect =-  runMaybeT . distribute----------------------------------------------------------------------------- Gen instances--instance Functor m => Functor (Gen m) where-  fmap f gen =-    Gen $ \seed size ->-      fmap f (runGen seed size gen)--instance Monad m => Applicative (Gen m) where-  pure =-    return-  (<*>) =-    ap--instance Monad m => Monad (Gen m) where-  return =-    liftTree . pure--  (>>=) m k =-    Gen $ \size seed ->-      case Seed.split seed of-        (sk, sm) ->-          runGen size sk . k =<<-          runGen size sm m--instance Monad m => Alternative (Gen m) where-  empty =-    mzero-  (<|>) =-    mplus--instance Monad m => MonadPlus (Gen m) where-  mzero =-    liftTree mzero--  mplus x y =-    Gen $ \size seed ->-      case Seed.split seed of-        (sx, sy) ->-          runGen size sx x `mplus`-          runGen size sy y--instance MonadTrans Gen where-  lift =-    liftTree . lift . lift--instance MFunctor Gen where-  hoist f =-    mapGen (hoist (hoist f))--embedMaybe ::-     MonadTrans t-  => Monad n-  => Monad (t (MaybeT n))-  => (forall a. m a -> t (MaybeT n) a)-  -> MaybeT m b-  -> t (MaybeT n) b-embedMaybe f m =-  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 f gen =-  Gen $ \size seed ->-    case Seed.split seed of-      (sf, sg) ->-        (runGen size sf . f) `embedTree`-        (runGen size sg gen)--instance MMonad Gen where-  embed =-    embedGen--distributeGen :: Transformer t Gen m => Gen (t m) a -> t (Gen m) a-distributeGen x =-  join . lift . Gen $ \size seed ->-    pure . hoist liftTree . distribute . hoist distribute $ runGen size seed x--instance Distributive Gen where-  type Transformer t Gen m = (-      Monad (t (Gen m))-    , Transformer t MaybeT m-    , Transformer t Tree (MaybeT m)-    )--  distribute =-    distributeGen--instance PrimMonad m => PrimMonad (Gen m) where-  type PrimState (Gen m) =-    PrimState m-  primitive =-    lift . primitive--instance MonadIO m => MonadIO (Gen m) where-  liftIO =-    lift . liftIO--instance MonadBase b m => MonadBase b (Gen m) where-  liftBase =-    lift . liftBase--instance MonadThrow m => MonadThrow (Gen m) where-  throwM =-    lift . throwM--instance MonadCatch m => MonadCatch (Gen m) where-  catch m onErr =-    Gen $ \size seed ->-      case Seed.split seed of-        (sm, se) ->-          (runGen size sm m) `catch`-          (runGen size se . onErr)--instance MonadReader r m => MonadReader r (Gen m) where-  ask =-    lift ask-  local f m =-    mapGen (local f) m--instance MonadState s m => MonadState s (Gen m) where-  get =-    lift get-  put =-    lift . put-  state =-    lift . state--instance MonadWriter w m => MonadWriter w (Gen m) where-  writer =-    lift . writer-  tell =-    lift . tell-  listen =-    mapGen listen-  pass =-    mapGen pass--instance MonadError e m => MonadError e (Gen m) where-  throwError =-    lift . throwError-  catchError m onErr =-    Gen $ \size seed ->-      case Seed.split seed of-        (sm, se) ->-          (runGen size sm m) `catchError`-          (runGen size se . onErr)--instance MonadResource m => MonadResource (Gen m) where-  liftResourceT =-    lift . liftResourceT----------------------------------------------------------------------------- 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 =-  mapGen . Tree.expand---- | Throw away a generator's shrink tree.----prune :: Monad m => Gen m a -> Gen m a-prune =-  mapGen Tree.prune----------------------------------------------------------------------------- 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)---- | 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 size gen =-  if size < 0 then-    error "Hedgehog.Random.resize: negative size"-  else-    Gen $ \_ seed ->-      runGen size seed 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---- | Make a generator smaller by scaling its size parameter.----small :: Gen m a -> Gen m a-small =-  scale golden---- | Scale a size using the golden ratio.------   > golden x = x / φ---   > golden x = x / 1.61803..----golden :: Size -> Size-golden x =-  round (fromIntegral x * 0.61803398875 :: Double)----------------------------------------------------------------------------- Combinators - Integral---- | Generates a random integral number in the given @[inclusive,inclusive]@ range.------   When the generator tries to shrink, it will shrink towards the---   'Range.origin' of the specified 'Range'.------   For example, the following generator will produce a number between @1970@---   and @2100@, but will shrink towards @2000@:------ @--- integral (Range.'Range.constantFrom' 2000 1970 2100) :: 'Gen' 'Int'--- @------   Some sample outputs from this generator might look like:------   > === Outcome ===---   > 1973---   > === Shrinks ===---   > 2000---   > 1987---   > 1980---   > 1976---   > 1974------   > === Outcome ===---   > 2061---   > === Shrinks ===---   > 2000---   > 2031---   > 2046---   > 2054---   > 2058---   > 2060----integral :: (Monad m, Integral a) => Range a -> Gen m a-integral range =-  shrink (Shrink.towards $ Range.origin range) (integral_ range)---- | Generates a random integral number in the [inclusive,inclusive] range.------   /This generator does not shrink./----integral_ :: (Monad m, Integral a) => Range a -> Gen m a-integral_ range =-  generate $ \size seed ->-    let-      (x, y) =-        Range.bounds size range-    in-      fromInteger . fst $-        Seed.nextInteger (toInteger x) (toInteger y) seed---- | Generates a random machine integer in the given @[inclusive,inclusive]@ range.------   /This is a specialization of 'integral', offered for convenience./----int :: Monad m => Range Int -> Gen m Int-int =-  integral---- | Generates a random 8-bit integer in the given @[inclusive,inclusive]@ range.------   /This is a specialization of 'integral', offered for convenience./----int8 :: Monad m => Range Int8 -> Gen m Int8-int8 =-  integral---- | Generates a random 16-bit integer in the given @[inclusive,inclusive]@ range.------   /This is a specialization of 'integral', offered for convenience./----int16 :: Monad m => Range Int16 -> Gen m Int16-int16 =-  integral---- | Generates a random 32-bit integer in the given @[inclusive,inclusive]@ range.------   /This is a specialization of 'integral', offered for convenience./----int32 :: Monad m => Range Int32 -> Gen m Int32-int32 =-  integral---- | Generates a random 64-bit integer in the given @[inclusive,inclusive]@ range.------   /This is a specialization of 'integral', offered for convenience./----int64 :: Monad m => Range Int64 -> Gen m Int64-int64 =-  integral---- | Generates a random machine word in the given @[inclusive,inclusive]@ range.------   /This is a specialization of 'integral', offered for convenience./----word :: Monad m => Range Word -> Gen m Word-word =-  integral---- | Generates a random byte in the given @[inclusive,inclusive]@ range.------   /This is a specialization of 'integral', offered for convenience./----word8 :: Monad m => Range Word8 -> Gen m Word8-word8 =-  integral---- | Generates a random 16-bit word in the given @[inclusive,inclusive]@ range.------   /This is a specialization of 'integral', offered for convenience./----word16 :: Monad m => Range Word16 -> Gen m Word16-word16 =-  integral---- | Generates a random 32-bit word in the given @[inclusive,inclusive]@ range.------   /This is a specialization of 'integral', offered for convenience./----word32 :: Monad m => Range Word32 -> Gen m Word32-word32 =-  integral---- | Generates a random 64-bit word in the given @[inclusive,inclusive]@ range.------   /This is a specialization of 'integral', offered for convenience./----word64 :: Monad m => Range Word64 -> Gen m Word64-word64 =-  integral----------------------------------------------------------------------------- Combinators - Fractional / Floating-Point---- | Generates a random floating-point number in the @[inclusive,exclusive)@ range.------   This generator works the same as 'integral', but for floating point numbers.----realFloat :: (Monad m, RealFloat a) => Range a -> Gen m a-realFloat range =-  shrink (Shrink.towardsFloat $ Range.origin range) (realFrac_ range)---- | Generates a random fractional number in the [inclusive,exclusive) range.------   /This generator does not shrink./----realFrac_ :: (Monad m, RealFrac a) => Range a -> Gen m a-realFrac_ range =-  generate $ \size seed ->-    let-      (x, y) =-        Range.bounds size range-    in-      realToFrac . fst $-        Seed.nextDouble (realToFrac x) (realToFrac y) seed---- | Generates a random floating-point number in the @[inclusive,exclusive)@ range.------   /This is a specialization of 'realFloat', offered for convenience./----float :: Monad m => Range Float -> Gen m Float-float =- realFloat---- | Generates a random floating-point number in the @[inclusive,exclusive)@ range.------   /This is a specialization of 'realFloat', offered for convenience./----double :: Monad m => Range Double -> Gen m Double-double =- realFloat----------------------------------------------------------------------------- Combinators - Enumeration---- | Generates an element from an enumeration.------   This generator shrinks towards the first argument.------   For example:------ @--- enum \'a' \'z' :: 'Gen' 'Char'--- @----enum :: (Monad m, Enum a) => a -> a -> Gen m a-enum lo hi =-  fmap toEnum . integral $-    Range.constant (fromEnum lo) (fromEnum hi)---- | Generates a random value from a bounded enumeration.------   This generator shrinks towards 'minBound'.------   For example:------ @--- enumBounded :: 'Gen' 'Bool'--- @----enumBounded :: (Monad m, Enum a, Bounded a) => Gen m a-enumBounded =-  enum minBound maxBound---- | Generates a random boolean.------   This generator shrinks to 'False'.------   /This is a specialization of 'enumBounded', offered for convenience./----bool :: Monad m => Gen m Bool-bool =-  enumBounded---- | Generates a random boolean.------   /This generator does not shrink./----bool_ :: Monad m => Gen m Bool-bool_ =-  generate $ \_ seed ->-    (/= 0) . fst $ Seed.nextInteger 0 1 seed----------------------------------------------------------------------------- Combinators - Characters---- | Generates an ASCII binit: @'0'..'1'@----binit :: Monad m => Gen m Char-binit =-  enum '0' '1'---- | Generates an ASCII octit: @'0'..'7'@----octit :: Monad m => Gen m Char-octit =-  enum '0' '7'---- | Generates an ASCII digit: @'0'..'9'@----digit :: Monad m => Gen m Char-digit =-  enum '0' '9'---- | Generates an ASCII hexit: @'0'..'9', \'a\'..\'f\', \'A\'..\'F\'@----hexit :: Monad m => Gen 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 =-  enum 'a' 'z'---- | Generates an ASCII uppercase letter: @\'A\'..\'Z\'@----upper :: Monad m => Gen m Char-upper =-  enum 'A' 'Z'---- | Generates an ASCII letter: @\'a\'..\'z\', \'A\'..\'Z\'@----alpha :: Monad m => Gen 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 =-  -- FIXME optimize lookup, use a SmallArray or something.-  element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"---- | Generates an ASCII character: @'\0'..'\127'@----ascii :: Monad m => Gen m Char-ascii =-  enum '\0' '\127'---- | Generates a Latin-1 character: @'\0'..'\255'@----latin1 :: Monad m => Gen 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 =-  filter (not . isSurrogate) unicodeAll---- | Generates a Unicode character, including invalid standalone surrogates:---   @'\0'..'\1114111'@----unicodeAll :: Monad m => Gen m Char-unicodeAll =-  enumBounded---- | Check if a character is in the surrogate category.----isSurrogate :: Char -> Bool-isSurrogate x =-  x >= '\55296' && x <= '\57343'----------------------------------------------------------------------------- Combinators - Strings---- | Generates a string using 'Range' to determine the length.------   /This is a specialization of 'list', offered for convenience./----string :: Monad m => Range Int -> Gen m Char -> Gen 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 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 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 range =-  fmap ByteString.pack $-  choice [-      list range . word8 $-        Range.constant-          (fromIntegral $ Char.ord 'a')-          (fromIntegral $ Char.ord 'z')--    , list range . word8 $-        Range.constant minBound maxBound-    ]----------------------------------------------------------------------------- Combinators - Choice---- | Trivial generator that always produces the same element.------   /This is another name for 'pure' \/ 'return'./-constant :: Monad m => a -> Gen m a-constant =-  pure---- | Randomly selects one of the elements in the list.------   This generator shrinks towards the first element in the list.------   /The input list must be non-empty./----element :: Monad m => [a] -> Gen m a-element = \case-  [] ->-    error "Hedgehog.Gen.element: used with empty list"-  xs -> do-    n <- integral $ Range.constant 0 (length xs - 1)-    pure $ xs !! n---- | Randomly selects one of the generators in the list.------   This generator shrinks towards the first generator in the list.------   /The input list must be non-empty./----choice :: Monad m => [Gen m a] -> Gen m a-choice = \case-  [] ->-    error "Hedgehog.Gen.choice: used with empty list"-  xs -> do-    n <- integral $ Range.constant 0 (length xs - 1)-    xs !! n---- | Uses a weighted distribution to randomly select one of the generators in---   the list.------   This generator shrinks towards the first generator in the list.------   /The input list must be non-empty./----frequency :: Monad m => [(Int, Gen m a)] -> Gen m a-frequency = \case-  [] ->-    error "Hedgehog.Gen.frequency: used with empty list"-  xs0 -> do-    let-      pick n = \case-        [] ->-          error "Hedgehog.Gen.frequency/pick: used with empty list"-        (k, x) : xs ->-          if n <= k then-            x-          else-            pick (n - k) xs--      total =-        sum (fmap fst xs0)--    n <- integral $ Range.constant 1 total-    pick n xs0---- | Modifies combinators which choose from a list of generators, like 'choice'---   or 'frequency', so that they can be used in recursive scenarios.------   This combinator modifies its target to select one of the generators in---   either the non-recursive or the recursive list. When a selection is made---   from the recursive list, the 'Size' is halved. When the 'Size' gets to one---   or less, selections are no longer made from the recursive list, this---   ensures termination.------   A good example of where this might be useful is abstract syntax trees:------ @--- data Expr =---     Var String---   | Lam String Expr---   | App Expr Expr------ -- Assuming we have a name generator--- genName :: 'Monad' m => 'Gen' m String------ -- We can write a generator for expressions--- genExpr :: 'Monad' m => 'Gen' m Expr--- genExpr =---   Gen.'recursive' Gen.'choice' [---       -- non-recursive generators---       Var '<$>' genName---     ] [---       -- recursive generators---       Gen.'subtermM' genExpr (\x -> Lam '<$>' genName '<*>' pure x)---     , Gen.'subterm2' genExpr genExpr App---     ]--- @------   If we wrote the above example using only 'choice', it is likely that it---   would fail to terminate. This is because for every call to @genExpr@,---   there is a 2 in 3 chance that we will recurse again.----recursive :: ([Gen m a] -> Gen m a) -> [Gen m a] -> [Gen m a] -> Gen m a-recursive f nonrec rec =-  sized $ \n ->-    if n <= 1 then-      f nonrec-    else-      f $ nonrec ++ fmap small rec----------------------------------------------------------------------------- Combinators - Conditional---- | Discards the whole generator.------   /This is another name for 'empty' \/ 'mzero'./----discard :: Monad m => Gen m a-discard =-  mzero---- | Generates a value that satisfies a predicate.------   This is essentially:------ @--- filter p gen = 'mfilter' p gen '<|>' filter p gen--- @------   It differs from the above in that we keep some state to avoid looping---   forever. If we trigger these limits then the whole generator is discarded.----filter :: Monad m => (a -> Bool) -> Gen m a -> Gen m a-filter p gen =-  let-    try k =-      if k > 100 then-        empty-      else-        mfilter p (scale (2 * k +) gen) <|> try (k + 1)-  in-    try 0---- | Runs a 'Maybe' generator until it produces a 'Just'.------   This is implemented using 'filter' and has the same caveats.----just :: Monad m => Gen m (Maybe a) -> Gen m a-just g = do-  mx <- filter Maybe.isJust g-  case mx of-    Just x ->-      pure x-    Nothing ->-      error "Hedgehog.Gen.just: internal error, unexpected Nothing"----------------------------------------------------------------------------- Combinators - Collections---- | Generates a 'Nothing' some of the time.----maybe :: Monad m => Gen m a -> Gen m (Maybe a)-maybe gen =-  sized $ \n ->-    frequency [-        (2, pure Nothing)-      , (1 + fromIntegral n, Just <$> gen)-      ]---- | Generates a list using a 'Range' to determine the length.----list :: Monad m => Range Int -> Gen m a -> Gen m [a]-list range gen =-  sized $ \size ->-    (traverse snd =<<) .-    mfilter (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 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 range gen = do-  xs <- list (fmap (max 1) range) gen-  case xs of-    [] ->-      error "Hedgehog.Gen.nonEmpty: internal error, generated empty list"-    _ ->-      pure $ NonEmpty.fromList xs---- | Generates a set using a 'Range' to determine the length.------   /This may fail to generate anything if the element generator/---   /cannot produce a large enough number of unique items to satify/---   /the required set size./----set :: (Monad m, Ord a) => Range Int -> Gen m a -> Gen m (Set a)-set range gen =-  fmap Map.keysSet . map range $ fmap (, ()) gen---- | Generates a map using a 'Range' to determine the length.------   /This may fail to generate anything if the keys produced by the/---   /generator do not account for a large enough number of unique/---   /items to satify the required map size./----map :: (Monad m, Ord k) => Range Int -> Gen m (k, v) -> Gen m (Map k v)-map range gen =-  sized $ \size ->-    mfilter ((>= Range.lowerBound size range) . Map.size) .-    fmap Map.fromList .-    (sequence =<<) .-    shrink Shrink.list $ do-      k <- integral_ range-      uniqueByKey k gen---- | Generate exactly 'n' unique generators.----uniqueByKey :: (Monad m, Ord k) => Int -> Gen m (k, v) -> Gen m [Gen m (k, v)]-uniqueByKey n gen =-  let-    try k xs0 =-      if k > 100 then-        mzero-      else-        replicateM n (freeze gen) >>= \kvs ->-        case uniqueInsert n xs0 (fmap (first fst) kvs) of-          Left xs ->-            pure $ Map.elems xs-          Right xs ->-            try (k + 1) xs-  in-    try (0 :: Int) Map.empty--uniqueInsert :: Ord k => Int -> Map k v -> [(k, v)] -> Either (Map k v) (Map k v)-uniqueInsert n xs kvs0 =-  if Map.size xs >= n then-    Left xs-  else-    case kvs0 of-      [] ->-        Right xs-      (k, v) : kvs ->-        uniqueInsert n (Map.insertWith (\x _ -> x) k v xs) kvs---- | Check that list contains at least a certain number of elements.----atLeast :: Int -> [a] -> Bool-atLeast n =-  if n == 0 then-    const True-  else-    not . null . drop (n - 1)----------------------------------------------------------------------------- Combinators - Subterms--data Subterms n a =-    One a-  | All (Vec n a)-    deriving (Functor, Foldable, Traversable)--data Nat =-    Z-  | S Nat--data Vec n a where-  Nil :: Vec 'Z a-  (:.) :: a -> Vec n a -> Vec ('S n) a--infixr 5 :.--deriving instance Functor (Vec n)-deriving instance Foldable (Vec n)-deriving instance Traversable (Vec n)--shrinkSubterms :: Subterms n a -> [Subterms n a]-shrinkSubterms = \case-  One _ ->-    []-  All xs ->-    fmap One $ toList xs--genSubterms :: Monad m => Vec n (Gen m a) -> Gen m (Subterms n a)-genSubterms =-  (sequence =<<) .-  shrink shrinkSubterms .-  fmap All .-  mapM (fmap snd . freeze)--fromSubterms :: Applicative m => (Vec n a -> m a) -> Subterms n a -> m a-fromSubterms f = \case-  One x ->-    pure x-  All xs ->-    f xs---- | Constructs a generator from a number of sub-term generators.------   /Shrinks to one of the sub-terms if possible./----subtermMVec :: Monad m => Vec n (Gen m a) -> (Vec n a -> Gen m a) -> Gen m a-subtermMVec gs f =-  fromSubterms f =<< genSubterms gs---- | Constructs a generator from a sub-term generator.------   /Shrinks to the sub-term if possible./----subtermM :: Monad m => Gen m a -> (a -> Gen m a) -> Gen m a-subtermM gx f =-  subtermMVec (gx :. Nil) $ \(x :. Nil) ->-    f x---- | Constructs a generator from a sub-term generator.------   /Shrinks to the sub-term if possible./----subterm :: Monad m => Gen m a -> (a -> a) -> Gen m a-subterm gx f =-  subtermM gx $ \x ->-    pure (f x)---- | Constructs a generator from two sub-term generators.------   /Shrinks to one of the sub-terms if possible./----subtermM2 :: Monad m => Gen m a -> Gen m a -> (a -> a -> Gen m a) -> Gen m a-subtermM2 gx gy f =-  subtermMVec (gx :. gy :. Nil) $ \(x :. y :. Nil) ->-    f x y---- | Constructs a generator from two sub-term generators.------   /Shrinks to one of the sub-terms if possible./----subterm2 :: Monad m => Gen m a -> Gen m a -> (a -> a -> a) -> Gen m a-subterm2 gx gy f =-  subtermM2 gx gy $ \x y ->-    pure (f x y)---- | Constructs a generator from three sub-term generators.------   /Shrinks to one of the sub-terms if possible./----subtermM3 :: Monad m => Gen m a -> Gen m a -> Gen m a -> (a -> a -> a -> Gen m a) -> Gen m a-subtermM3 gx gy gz f =-  subtermMVec (gx :. gy :. gz :. Nil) $ \(x :. y :. z :. Nil) ->-    f x y z---- | Constructs a generator from three sub-term generators.------   /Shrinks to one of the sub-terms if possible./----subterm3 :: Monad m => Gen m a -> Gen m a -> Gen m a -> (a -> a -> a -> a) -> Gen m a-subterm3 gx gy gz f =-  subtermM3 gx gy gz $ \x y z ->-    pure (f x y z)----------------------------------------------------------------------------- Combinators - Combinations & Permutations---- | Generates a random subsequence of a list.----subsequence :: Monad m => [a] -> Gen m [a]-subsequence xs =-  shrink Shrink.list $ filterM (const bool_) xs---- | Generates a random permutation of a list.------   This shrinks towards the order of the list being identical to the input---   list.----shuffle :: Monad m => [a] -> Gen m [a]-shuffle = \case-  [] ->-    pure []-  xs0 -> do-    n <- integral $ Range.constant 0 (length xs0 - 1)-    case splitAt n xs0 of-      (xs, y : ys) ->-        (y :) <$> shuffle (xs ++ ys)-      (_, []) ->-        error "Hedgehog.shuffle: internal error, split generated empty list"----------------------------------------------------------------------------- Sampling---- | Generate a random sample of data from the a generator.----sample :: MonadIO m => Gen m a -> m [a]-sample gen =-  fmap (fmap nodeValue . Maybe.catMaybes) .-  replicateM 10 $ do-    seed <- liftIO Seed.random-    runMaybeT . runTree $ runGen 30 seed gen---- | Print the value produced by a generator, and the first level of shrinks,---   for the given size and seed.------   Use 'print' to generate a value from a random seed.----printWith :: (MonadIO m, Show a) => Size -> Seed -> Gen 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---- | 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 size seed gen = do-  s <- Tree.render $ renderNodes size seed gen-  liftIO $ putStr s---- | Run a generator with a random seed and print the outcome, and the first---   level of shrinks.------ @--- Gen.print (Gen.'enum' \'a\' \'f\')--- @------   > === Outcome ===---   > 'd'---   > === Shrinks ===---   > 'a'---   > 'b'---   > 'c'----print :: (MonadIO m, Show a) => Gen m a -> m ()-print gen = do-  seed <- liftIO Seed.random-  printWith 30 seed gen---- | Run a generator with a random seed and print the resulting shrink tree.------ @--- Gen.printTree (Gen.'enum' \'a\' \'f\')--- @------   > 'd'---   >  ├╼'a'---   >  ├╼'b'---   >  │  └╼'a'---   >  └╼'c'---   >     ├╼'a'---   >     └╼'b'---   >        └╼'a'------   /This may not terminate when the tree is very large./----printTree :: (MonadIO m, Show a) => Gen m 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 size seed =-  fmap (Maybe.maybe "<discard>" show) . runDiscardEffect . runGen size seed----------------------------------------------------------------------------- Internal---- $internal------ These functions are exported in case you need them in a pinch, but are not--- part of the public API and may change at any time, even as part of a minor--- update.+module Hedgehog.Gen (+  -- * Transformer+    Gen++  -- * Combinators+  -- ** Shrinking+  , shrink+  , prune++  -- ** Size+  , small+  , scale+  , resize+  , sized++  -- ** Integral+  , integral+  , integral_++  , int+  , int8+  , int16+  , int32+  , int64++  , word+  , word8+  , word16+  , word32+  , word64++  -- ** Floating-point+  , realFloat+  , realFrac_+  , float+  , double++  -- ** Enumeration+  , enum+  , enumBounded+  , bool+  , bool_++  -- ** Characters+  , binit+  , octit+  , digit+  , hexit+  , lower+  , upper+  , alpha+  , alphaNum+  , ascii+  , latin1+  , unicode+  , unicodeAll++  -- ** Strings+  , string+  , text+  , utf8+  , bytes++  -- ** Choice+  , constant+  , element+  , choice+  , frequency+  , recursive++  -- ** Conditional+  , discard+  , filter+  , just++  -- ** Collections+  , maybe+  , list+  , seq+  , nonEmpty+  , set+  , map++  -- ** Subterms+  , subterm+  , subtermM+  , subterm2+  , subtermM2+  , subterm3+  , subtermM3++  -- ** Combinations & Permutations+  , subsequence+  , shuffle++  -- ** Abstract State Machine+  , actions++  -- * Sampling Generators+  , sample+  , print+  , printTree+  , printWith+  , printTreeWith+  ) where++import           Hedgehog.Internal.Gen+import           Hedgehog.Internal.State (actions)++import           Prelude hiding (filter, print, maybe, map, seq)

@@ -31,6 +31,8 @@       , MFunctor f       ) +  -- | Distribute one monad transformer over another.+  --   distribute :: Transformer f g m => g (f m) a -> f (g m) a  instance Distributive MaybeT where

@@ -0,0 +1,42 @@+module Hedgehog.Internal.Exception (+    TypedException(..)+  , tryAll+  ) where++import           Control.Exception (Exception(..), AsyncException, SomeException(..))+import           Control.Monad.Catch (MonadCatch(..), throwM)++import           Data.Typeable (typeOf)+++-- | 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 m =+  catch (fmap Right m) $ \exception ->+    case fromException exception :: Maybe AsyncException of+      Nothing ->+        pure . Left $ TypedException exception+      Just async ->+        throwM async

@@ -0,0 +1,1304 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- MonadBase+module Hedgehog.Internal.Gen (+  -- * Transformer+    Gen(..)++  -- * Combinators+  -- ** Shrinking+  , shrink+  , prune++  -- ** Size+  , small+  , scale+  , resize+  , sized++  -- ** Integral+  , integral+  , integral_++  , int+  , int8+  , int16+  , int32+  , int64++  , word+  , word8+  , word16+  , word32+  , word64++  -- ** Floating-point+  , realFloat+  , realFrac_+  , float+  , double++  -- ** Enumeration+  , enum+  , enumBounded+  , bool+  , bool_++  -- ** Characters+  , binit+  , octit+  , digit+  , hexit+  , lower+  , upper+  , alpha+  , alphaNum+  , ascii+  , latin1+  , unicode+  , unicodeAll++  -- ** Strings+  , string+  , text+  , utf8+  , bytes++  -- ** Choice+  , constant+  , element+  , choice+  , frequency+  , recursive++  -- ** Conditional+  , discard+  , filter+  , just++  -- ** Collections+  , maybe+  , list+  , seq+  , nonEmpty+  , set+  , map++  -- ** Subterms+  , freeze+  , subterm+  , subtermM+  , subterm2+  , subtermM2+  , subterm3+  , subtermM3++  -- ** Combinations & Permutations+  , subsequence+  , shuffle++  -- * Sampling Generators+  , sample+  , print+  , printTree+  , printWith+  , printTreeWith++  -- * Internal+  -- $internal++  -- ** Transfomer+  , runGen+  , mapGen+  , generate+  , liftTree+  , runDiscardEffect++  -- ** Size+  , golden++  -- ** Shrinking+  , atLeast++  -- ** Characters+  , isSurrogate++  -- ** Subterms+  , Vec(..)+  , Nat(..)+  , subtermMVec++  -- ** Sampling+  , renderNodes+  ) where++import           Control.Applicative (Alternative(..))+import           Control.Monad (MonadPlus(..), mfilter, 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.Primitive (PrimMonad(..))+import           Control.Monad.Reader.Class (MonadReader(..))+import           Control.Monad.State.Class (MonadState(..))+import           Control.Monad.Trans.Class (MonadTrans(..))+import           Control.Monad.Trans.Maybe (MaybeT(..))+import           Control.Monad.Trans.Resource (MonadResource(..))+import           Control.Monad.Writer.Class (MonadWriter(..))++import           Data.Bifunctor (first)+import           Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.Char as Char+import           Data.Foldable (for_, toList)+import           Data.Int (Int8, Int16, Int32, Int64)+import           Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import           Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import           Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import           Data.Set (Set)+import           Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import           Data.Word (Word8, Word16, Word32, Word64)++import           Hedgehog.Internal.Distributive (Distributive(..))+import           Hedgehog.Internal.Seed (Seed)+import qualified Hedgehog.Internal.Seed as Seed+import qualified Hedgehog.Internal.Shrink as Shrink+import           Hedgehog.Internal.Tree (Tree(..), Node(..))+import qualified Hedgehog.Internal.Tree as Tree+import           Hedgehog.Range (Size, Range)+import qualified Hedgehog.Range as Range++import           Prelude hiding (filter, print, maybe, map, seq)+++------------------------------------------------------------------------+-- Generator transformer++-- | Generator for random values of @a@.+--+newtype Gen m a =+  Gen {+      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) =+  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)++-- | Lift a predefined shrink tree in to a generator, ignoring the seed and the+--   size.+--+liftTree :: Tree (MaybeT m) a -> Gen m a+liftTree x =+  Gen (\_ _ -> x)++-- | Run the discard effects through the tree and reify them as 'Maybe' values+--   at the nodes. 'Nothing' means discarded, 'Just' means we have a value.+--+runDiscardEffect :: Monad m => Tree (MaybeT m) a -> Tree m (Maybe a)+runDiscardEffect =+  runMaybeT . distribute++------------------------------------------------------------------------+-- Gen instances++instance Functor m => Functor (Gen m) where+  fmap f gen =+    Gen $ \seed size ->+      fmap f (runGen seed size gen)++instance Monad m => Applicative (Gen m) where+  pure =+    return+  (<*>) =+    ap++instance Monad m => Monad (Gen m) where+  return =+    liftTree . pure++  (>>=) m k =+    Gen $ \size seed ->+      case Seed.split seed of+        (sk, sm) ->+          runGen size sk . k =<<+          runGen size sm m++instance Monad m => Alternative (Gen m) where+  empty =+    mzero+  (<|>) =+    mplus++instance Monad m => MonadPlus (Gen m) where+  mzero =+    liftTree mzero++  mplus x y =+    Gen $ \size seed ->+      case Seed.split seed of+        (sx, sy) ->+          runGen size sx x `mplus`+          runGen size sy y++instance MonadTrans Gen where+  lift =+    liftTree . lift . lift++instance MFunctor Gen where+  hoist f =+    mapGen (hoist (hoist f))++embedMaybe ::+     MonadTrans t+  => Monad n+  => Monad (t (MaybeT n))+  => (forall a. m a -> t (MaybeT n) a)+  -> MaybeT m b+  -> t (MaybeT n) b+embedMaybe f m =+  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 f gen =+  Gen $ \size seed ->+    case Seed.split seed of+      (sf, sg) ->+        (runGen size sf . f) `embedTree`+        (runGen size sg gen)++instance MMonad Gen where+  embed =+    embedGen++distributeGen :: Transformer t Gen m => Gen (t m) a -> t (Gen m) a+distributeGen x =+  join . lift . Gen $ \size seed ->+    pure . hoist liftTree . distribute . hoist distribute $ runGen size seed x++instance Distributive Gen where+  type Transformer t Gen m = (+      Monad (t (Gen m))+    , Transformer t MaybeT m+    , Transformer t Tree (MaybeT m)+    )++  distribute =+    distributeGen++instance PrimMonad m => PrimMonad (Gen m) where+  type PrimState (Gen m) =+    PrimState m+  primitive =+    lift . primitive++instance MonadIO m => MonadIO (Gen m) where+  liftIO =+    lift . liftIO++instance MonadBase b m => MonadBase b (Gen m) where+  liftBase =+    lift . liftBase++instance MonadThrow m => MonadThrow (Gen m) where+  throwM =+    lift . throwM++instance MonadCatch m => MonadCatch (Gen m) where+  catch m onErr =+    Gen $ \size seed ->+      case Seed.split seed of+        (sm, se) ->+          (runGen size sm m) `catch`+          (runGen size se . onErr)++instance MonadReader r m => MonadReader r (Gen m) where+  ask =+    lift ask+  local f m =+    mapGen (local f) m++instance MonadState s m => MonadState s (Gen m) where+  get =+    lift get+  put =+    lift . put+  state =+    lift . state++instance MonadWriter w m => MonadWriter w (Gen m) where+  writer =+    lift . writer+  tell =+    lift . tell+  listen =+    mapGen listen+  pass =+    mapGen pass++instance MonadError e m => MonadError e (Gen m) where+  throwError =+    lift . throwError+  catchError m onErr =+    Gen $ \size seed ->+      case Seed.split seed of+        (sm, se) ->+          (runGen size sm m) `catchError`+          (runGen size se . onErr)++instance MonadResource m => MonadResource (Gen m) where+  liftResourceT =+    lift . liftResourceT++------------------------------------------------------------------------+-- 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 =+  mapGen . Tree.expand++-- | Throw away a generator's shrink tree.+--+prune :: Monad m => Gen m a -> Gen m a+prune =+  mapGen Tree.prune++------------------------------------------------------------------------+-- 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)++-- | 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 size gen =+  if size < 0 then+    error "Hedgehog.Random.resize: negative size"+  else+    Gen $ \_ seed ->+      runGen size seed 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++-- | Make a generator smaller by scaling its size parameter.+--+small :: Gen m a -> Gen m a+small =+  scale golden++-- | Scale a size using the golden ratio.+--+--   > golden x = x / φ+--   > golden x = x / 1.61803..+--+golden :: Size -> Size+golden x =+  round (fromIntegral x * 0.61803398875 :: Double)++------------------------------------------------------------------------+-- Combinators - Integral++-- | Generates a random integral number in the given @[inclusive,inclusive]@ range.+--+--   When the generator tries to shrink, it will shrink towards the+--   'Range.origin' of the specified 'Range'.+--+--   For example, the following generator will produce a number between @1970@+--   and @2100@, but will shrink towards @2000@:+--+-- @+-- integral (Range.'Range.constantFrom' 2000 1970 2100) :: 'Gen' 'Int'+-- @+--+--   Some sample outputs from this generator might look like:+--+--   > === Outcome ===+--   > 1973+--   > === Shrinks ===+--   > 2000+--   > 1987+--   > 1980+--   > 1976+--   > 1974+--+--   > === Outcome ===+--   > 2061+--   > === Shrinks ===+--   > 2000+--   > 2031+--   > 2046+--   > 2054+--   > 2058+--   > 2060+--+integral :: (Monad m, Integral a) => Range a -> Gen m a+integral range =+  shrink (Shrink.towards $ Range.origin range) (integral_ range)++-- | Generates a random integral number in the [inclusive,inclusive] range.+--+--   /This generator does not shrink./+--+integral_ :: (Monad m, Integral a) => Range a -> Gen m a+integral_ range =+  generate $ \size seed ->+    let+      (x, y) =+        Range.bounds size range+    in+      fromInteger . fst $+        Seed.nextInteger (toInteger x) (toInteger y) seed++-- | Generates a random machine integer in the given @[inclusive,inclusive]@ range.+--+--   /This is a specialization of 'integral', offered for convenience./+--+int :: Monad m => Range Int -> Gen m Int+int =+  integral++-- | Generates a random 8-bit integer in the given @[inclusive,inclusive]@ range.+--+--   /This is a specialization of 'integral', offered for convenience./+--+int8 :: Monad m => Range Int8 -> Gen m Int8+int8 =+  integral++-- | Generates a random 16-bit integer in the given @[inclusive,inclusive]@ range.+--+--   /This is a specialization of 'integral', offered for convenience./+--+int16 :: Monad m => Range Int16 -> Gen m Int16+int16 =+  integral++-- | Generates a random 32-bit integer in the given @[inclusive,inclusive]@ range.+--+--   /This is a specialization of 'integral', offered for convenience./+--+int32 :: Monad m => Range Int32 -> Gen m Int32+int32 =+  integral++-- | Generates a random 64-bit integer in the given @[inclusive,inclusive]@ range.+--+--   /This is a specialization of 'integral', offered for convenience./+--+int64 :: Monad m => Range Int64 -> Gen m Int64+int64 =+  integral++-- | Generates a random machine word in the given @[inclusive,inclusive]@ range.+--+--   /This is a specialization of 'integral', offered for convenience./+--+word :: Monad m => Range Word -> Gen m Word+word =+  integral++-- | Generates a random byte in the given @[inclusive,inclusive]@ range.+--+--   /This is a specialization of 'integral', offered for convenience./+--+word8 :: Monad m => Range Word8 -> Gen m Word8+word8 =+  integral++-- | Generates a random 16-bit word in the given @[inclusive,inclusive]@ range.+--+--   /This is a specialization of 'integral', offered for convenience./+--+word16 :: Monad m => Range Word16 -> Gen m Word16+word16 =+  integral++-- | Generates a random 32-bit word in the given @[inclusive,inclusive]@ range.+--+--   /This is a specialization of 'integral', offered for convenience./+--+word32 :: Monad m => Range Word32 -> Gen m Word32+word32 =+  integral++-- | Generates a random 64-bit word in the given @[inclusive,inclusive]@ range.+--+--   /This is a specialization of 'integral', offered for convenience./+--+word64 :: Monad m => Range Word64 -> Gen m Word64+word64 =+  integral++------------------------------------------------------------------------+-- Combinators - Fractional / Floating-Point++-- | Generates a random floating-point number in the @[inclusive,exclusive)@ range.+--+--   This generator works the same as 'integral', but for floating point numbers.+--+realFloat :: (Monad m, RealFloat a) => Range a -> Gen m a+realFloat range =+  shrink (Shrink.towardsFloat $ Range.origin range) (realFrac_ range)++-- | Generates a random fractional number in the [inclusive,exclusive) range.+--+--   /This generator does not shrink./+--+realFrac_ :: (Monad m, RealFrac a) => Range a -> Gen m a+realFrac_ range =+  generate $ \size seed ->+    let+      (x, y) =+        Range.bounds size range+    in+      realToFrac . fst $+        Seed.nextDouble (realToFrac x) (realToFrac y) seed++-- | Generates a random floating-point number in the @[inclusive,exclusive)@ range.+--+--   /This is a specialization of 'realFloat', offered for convenience./+--+float :: Monad m => Range Float -> Gen m Float+float =+ realFloat++-- | Generates a random floating-point number in the @[inclusive,exclusive)@ range.+--+--   /This is a specialization of 'realFloat', offered for convenience./+--+double :: Monad m => Range Double -> Gen m Double+double =+ realFloat++------------------------------------------------------------------------+-- Combinators - Enumeration++-- | Generates an element from an enumeration.+--+--   This generator shrinks towards the first argument.+--+--   For example:+--+-- @+-- enum \'a' \'z' :: 'Gen' 'Char'+-- @+--+enum :: (Monad m, Enum a) => a -> a -> Gen m a+enum lo hi =+  fmap toEnum . integral $+    Range.constant (fromEnum lo) (fromEnum hi)++-- | Generates a random value from a bounded enumeration.+--+--   This generator shrinks towards 'minBound'.+--+--   For example:+--+-- @+-- enumBounded :: 'Gen' 'Bool'+-- @+--+enumBounded :: (Monad m, Enum a, Bounded a) => Gen m a+enumBounded =+  enum minBound maxBound++-- | Generates a random boolean.+--+--   This generator shrinks to 'False'.+--+--   /This is a specialization of 'enumBounded', offered for convenience./+--+bool :: Monad m => Gen m Bool+bool =+  enumBounded++-- | Generates a random boolean.+--+--   /This generator does not shrink./+--+bool_ :: Monad m => Gen m Bool+bool_ =+  generate $ \_ seed ->+    (/= 0) . fst $ Seed.nextInteger 0 1 seed++------------------------------------------------------------------------+-- Combinators - Characters++-- | Generates an ASCII binit: @'0'..'1'@+--+binit :: Monad m => Gen m Char+binit =+  enum '0' '1'++-- | Generates an ASCII octit: @'0'..'7'@+--+octit :: Monad m => Gen m Char+octit =+  enum '0' '7'++-- | Generates an ASCII digit: @'0'..'9'@+--+digit :: Monad m => Gen m Char+digit =+  enum '0' '9'++-- | Generates an ASCII hexit: @'0'..'9', \'a\'..\'f\', \'A\'..\'F\'@+--+hexit :: Monad m => Gen 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 =+  enum 'a' 'z'++-- | Generates an ASCII uppercase letter: @\'A\'..\'Z\'@+--+upper :: Monad m => Gen m Char+upper =+  enum 'A' 'Z'++-- | Generates an ASCII letter: @\'a\'..\'z\', \'A\'..\'Z\'@+--+alpha :: Monad m => Gen 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 =+  -- FIXME optimize lookup, use a SmallArray or something.+  element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"++-- | Generates an ASCII character: @'\0'..'\127'@+--+ascii :: Monad m => Gen m Char+ascii =+  enum '\0' '\127'++-- | Generates a Latin-1 character: @'\0'..'\255'@+--+latin1 :: Monad m => Gen 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 =+  filter (not . isSurrogate) unicodeAll++-- | Generates a Unicode character, including invalid standalone surrogates:+--   @'\0'..'\1114111'@+--+unicodeAll :: Monad m => Gen m Char+unicodeAll =+  enumBounded++-- | Check if a character is in the surrogate category.+--+isSurrogate :: Char -> Bool+isSurrogate x =+  x >= '\55296' && x <= '\57343'++------------------------------------------------------------------------+-- Combinators - Strings++-- | Generates a string using 'Range' to determine the length.+--+--   /This is a specialization of 'list', offered for convenience./+--+string :: Monad m => Range Int -> Gen m Char -> Gen 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 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 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 range =+  fmap ByteString.pack $+  choice [+      list range . word8 $+        Range.constant+          (fromIntegral $ Char.ord 'a')+          (fromIntegral $ Char.ord 'z')++    , list range . word8 $+        Range.constant minBound maxBound+    ]++------------------------------------------------------------------------+-- Combinators - Choice++-- | Trivial generator that always produces the same element.+--+--   /This is another name for 'pure' \/ 'return'./+constant :: Monad m => a -> Gen m a+constant =+  pure++-- | Randomly selects one of the elements in the list.+--+--   This generator shrinks towards the first element in the list.+--+--   /The input list must be non-empty./+--+element :: Monad m => [a] -> Gen m a+element = \case+  [] ->+    error "Hedgehog.Gen.element: used with empty list"+  xs -> do+    n <- integral $ Range.constant 0 (length xs - 1)+    pure $ xs !! n++-- | Randomly selects one of the generators in the list.+--+--   This generator shrinks towards the first generator in the list.+--+--   /The input list must be non-empty./+--+choice :: Monad m => [Gen m a] -> Gen m a+choice = \case+  [] ->+    error "Hedgehog.Gen.choice: used with empty list"+  xs -> do+    n <- integral $ Range.constant 0 (length xs - 1)+    xs !! n++-- | Uses a weighted distribution to randomly select one of the generators in+--   the list.+--+--   This generator shrinks towards the first generator in the list.+--+--   /The input list must be non-empty./+--+frequency :: Monad m => [(Int, Gen m a)] -> Gen m a+frequency = \case+  [] ->+    error "Hedgehog.Gen.frequency: used with empty list"+  xs0 -> do+    let+      pick n = \case+        [] ->+          error "Hedgehog.Gen.frequency/pick: used with empty list"+        (k, x) : xs ->+          if n <= k then+            x+          else+            pick (n - k) xs++      total =+        sum (fmap fst xs0)++    n <- integral $ Range.constant 1 total+    pick n xs0++-- | Modifies combinators which choose from a list of generators, like 'choice'+--   or 'frequency', so that they can be used in recursive scenarios.+--+--   This combinator modifies its target to select one of the generators in+--   either the non-recursive or the recursive list. When a selection is made+--   from the recursive list, the 'Size' is halved. When the 'Size' gets to one+--   or less, selections are no longer made from the recursive list, this+--   ensures termination.+--+--   A good example of where this might be useful is abstract syntax trees:+--+-- @+-- data Expr =+--     Var String+--   | Lam String Expr+--   | App Expr Expr+--+-- -- Assuming we have a name generator+-- genName :: 'Monad' m => 'Gen' m String+--+-- -- We can write a generator for expressions+-- genExpr :: 'Monad' m => 'Gen' m Expr+-- genExpr =+--   Gen.'recursive' Gen.'choice' [+--       -- non-recursive generators+--       Var '<$>' genName+--     ] [+--       -- recursive generators+--       Gen.'subtermM' genExpr (\x -> Lam '<$>' genName '<*>' pure x)+--     , Gen.'subterm2' genExpr genExpr App+--     ]+-- @+--+--   If we wrote the above example using only 'choice', it is likely that it+--   would fail to terminate. This is because for every call to @genExpr@,+--   there is a 2 in 3 chance that we will recurse again.+--+recursive :: ([Gen m a] -> Gen m a) -> [Gen m a] -> [Gen m a] -> Gen m a+recursive f nonrec rec =+  sized $ \n ->+    if n <= 1 then+      f nonrec+    else+      f $ nonrec ++ fmap small rec++------------------------------------------------------------------------+-- Combinators - Conditional++-- | Discards the whole generator.+--+--   /This is another name for 'empty' \/ 'mzero'./+--+discard :: Monad m => Gen m a+discard =+  mzero++-- | Generates a value that satisfies a predicate.+--+--   This is essentially:+--+-- @+-- filter p gen = 'mfilter' p gen '<|>' filter p gen+-- @+--+--   It differs from the above in that we keep some state to avoid looping+--   forever. If we trigger these limits then the whole generator is discarded.+--+filter :: Monad m => (a -> Bool) -> Gen m a -> Gen m a+filter p gen =+  let+    try k =+      if k > 100 then+        empty+      else+        mfilter p (scale (2 * k +) gen) <|> try (k + 1)+  in+    try 0++-- | Runs a 'Maybe' generator until it produces a 'Just'.+--+--   This is implemented using 'filter' and has the same caveats.+--+just :: Monad m => Gen m (Maybe a) -> Gen m a+just g = do+  mx <- filter Maybe.isJust g+  case mx of+    Just x ->+      pure x+    Nothing ->+      error "Hedgehog.Gen.just: internal error, unexpected Nothing"++------------------------------------------------------------------------+-- Combinators - Collections++-- | Generates a 'Nothing' some of the time.+--+maybe :: Monad m => Gen m a -> Gen m (Maybe a)+maybe gen =+  sized $ \n ->+    frequency [+        (2, pure Nothing)+      , (1 + fromIntegral n, Just <$> gen)+      ]++-- | Generates a list using a 'Range' to determine the length.+--+list :: Monad m => Range Int -> Gen m a -> Gen m [a]+list range gen =+  sized $ \size ->+    (traverse snd =<<) .+    mfilter (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 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 range gen = do+  xs <- list (fmap (max 1) range) gen+  case xs of+    [] ->+      error "Hedgehog.Gen.nonEmpty: internal error, generated empty list"+    _ ->+      pure $ NonEmpty.fromList xs++-- | Generates a set using a 'Range' to determine the length.+--+--   /This may fail to generate anything if the element generator/+--   /cannot produce a large enough number of unique items to satify/+--   /the required set size./+--+set :: (Monad m, Ord a) => Range Int -> Gen m a -> Gen m (Set a)+set range gen =+  fmap Map.keysSet . map range $ fmap (, ()) gen++-- | Generates a map using a 'Range' to determine the length.+--+--   /This may fail to generate anything if the keys produced by the/+--   /generator do not account for a large enough number of unique/+--   /items to satify the required map size./+--+map :: (Monad m, Ord k) => Range Int -> Gen m (k, v) -> Gen m (Map k v)+map range gen =+  sized $ \size ->+    mfilter ((>= Range.lowerBound size range) . Map.size) .+    fmap Map.fromList .+    (sequence =<<) .+    shrink Shrink.list $ do+      k <- integral_ range+      uniqueByKey k gen++-- | Generate exactly 'n' unique generators.+--+uniqueByKey :: (Monad m, Ord k) => Int -> Gen m (k, v) -> Gen m [Gen m (k, v)]+uniqueByKey n gen =+  let+    try k xs0 =+      if k > 100 then+        mzero+      else+        replicateM n (freeze gen) >>= \kvs ->+        case uniqueInsert n xs0 (fmap (first fst) kvs) of+          Left xs ->+            pure $ Map.elems xs+          Right xs ->+            try (k + 1) xs+  in+    try (0 :: Int) Map.empty++uniqueInsert :: Ord k => Int -> Map k v -> [(k, v)] -> Either (Map k v) (Map k v)+uniqueInsert n xs kvs0 =+  if Map.size xs >= n then+    Left xs+  else+    case kvs0 of+      [] ->+        Right xs+      (k, v) : kvs ->+        uniqueInsert n (Map.insertWith (\x _ -> x) k v xs) kvs++-- | Check that list contains at least a certain number of elements.+--+atLeast :: Int -> [a] -> Bool+atLeast n =+  if n == 0 then+    const True+  else+    not . null . drop (n - 1)++------------------------------------------------------------------------+-- Combinators - Subterms++data Subterms n a =+    One a+  | All (Vec n a)+    deriving (Functor, Foldable, Traversable)++data Nat =+    Z+  | S Nat++data Vec n a where+  Nil :: Vec 'Z a+  (:.) :: a -> Vec n a -> Vec ('S n) a++infixr 5 :.++deriving instance Functor (Vec n)+deriving instance Foldable (Vec n)+deriving instance Traversable (Vec n)++shrinkSubterms :: Subterms n a -> [Subterms n a]+shrinkSubterms = \case+  One _ ->+    []+  All xs ->+    fmap One $ toList xs++genSubterms :: Monad m => Vec n (Gen m a) -> Gen m (Subterms n a)+genSubterms =+  (sequence =<<) .+  shrink shrinkSubterms .+  fmap All .+  mapM (fmap snd . freeze)++fromSubterms :: Applicative m => (Vec n a -> m a) -> Subterms n a -> m a+fromSubterms f = \case+  One x ->+    pure x+  All xs ->+    f xs++-- | Constructs a generator from a number of sub-term generators.+--+--   /Shrinks to one of the sub-terms if possible./+--+subtermMVec :: Monad m => Vec n (Gen m a) -> (Vec n a -> Gen m a) -> Gen m a+subtermMVec gs f =+  fromSubterms f =<< genSubterms gs++-- | Constructs a generator from a sub-term generator.+--+--   /Shrinks to the sub-term if possible./+--+subtermM :: Monad m => Gen m a -> (a -> Gen m a) -> Gen m a+subtermM gx f =+  subtermMVec (gx :. Nil) $ \(x :. Nil) ->+    f x++-- | Constructs a generator from a sub-term generator.+--+--   /Shrinks to the sub-term if possible./+--+subterm :: Monad m => Gen m a -> (a -> a) -> Gen m a+subterm gx f =+  subtermM gx $ \x ->+    pure (f x)++-- | Constructs a generator from two sub-term generators.+--+--   /Shrinks to one of the sub-terms if possible./+--+subtermM2 :: Monad m => Gen m a -> Gen m a -> (a -> a -> Gen m a) -> Gen m a+subtermM2 gx gy f =+  subtermMVec (gx :. gy :. Nil) $ \(x :. y :. Nil) ->+    f x y++-- | Constructs a generator from two sub-term generators.+--+--   /Shrinks to one of the sub-terms if possible./+--+subterm2 :: Monad m => Gen m a -> Gen m a -> (a -> a -> a) -> Gen m a+subterm2 gx gy f =+  subtermM2 gx gy $ \x y ->+    pure (f x y)++-- | Constructs a generator from three sub-term generators.+--+--   /Shrinks to one of the sub-terms if possible./+--+subtermM3 :: Monad m => Gen m a -> Gen m a -> Gen m a -> (a -> a -> a -> Gen m a) -> Gen m a+subtermM3 gx gy gz f =+  subtermMVec (gx :. gy :. gz :. Nil) $ \(x :. y :. z :. Nil) ->+    f x y z++-- | Constructs a generator from three sub-term generators.+--+--   /Shrinks to one of the sub-terms if possible./+--+subterm3 :: Monad m => Gen m a -> Gen m a -> Gen m a -> (a -> a -> a -> a) -> Gen m a+subterm3 gx gy gz f =+  subtermM3 gx gy gz $ \x y z ->+    pure (f x y z)++------------------------------------------------------------------------+-- Combinators - Combinations & Permutations++-- | Generates a random subsequence of a list.+--+subsequence :: Monad m => [a] -> Gen m [a]+subsequence xs =+  shrink Shrink.list $ filterM (const bool_) xs++-- | Generates a random permutation of a list.+--+--   This shrinks towards the order of the list being identical to the input+--   list.+--+shuffle :: Monad m => [a] -> Gen m [a]+shuffle = \case+  [] ->+    pure []+  xs0 -> do+    n <- integral $ Range.constant 0 (length xs0 - 1)+    case splitAt n xs0 of+      (xs, y : ys) ->+        (y :) <$> shuffle (xs ++ ys)+      (_, []) ->+        error "Hedgehog.shuffle: internal error, split generated empty list"++------------------------------------------------------------------------+-- Sampling++-- | Generate a random sample of data from the a generator.+--+sample :: MonadIO m => Gen m a -> m [a]+sample gen =+  fmap (fmap nodeValue . Maybe.catMaybes) .+  replicateM 10 $ do+    seed <- liftIO Seed.random+    runMaybeT . runTree $ runGen 30 seed gen++-- | Print the value produced by a generator, and the first level of shrinks,+--   for the given size and seed.+--+--   Use 'print' to generate a value from a random seed.+--+printWith :: (MonadIO m, Show a) => Size -> Seed -> Gen 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++-- | 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 size seed gen = do+  s <- Tree.render $ renderNodes size seed gen+  liftIO $ putStr s++-- | Run a generator with a random seed and print the outcome, and the first+--   level of shrinks.+--+-- @+-- Gen.print (Gen.'enum' \'a\' \'f\')+-- @+--+--   > === Outcome ===+--   > 'd'+--   > === Shrinks ===+--   > 'a'+--   > 'b'+--   > 'c'+--+print :: (MonadIO m, Show a) => Gen m a -> m ()+print gen = do+  seed <- liftIO Seed.random+  printWith 30 seed gen++-- | Run a generator with a random seed and print the resulting shrink tree.+--+-- @+-- Gen.printTree (Gen.'enum' \'a\' \'f\')+-- @+--+--   > 'd'+--   >  ├╼'a'+--   >  ├╼'b'+--   >  │  └╼'a'+--   >  └╼'c'+--   >     ├╼'a'+--   >     └╼'b'+--   >        └╼'a'+--+--   /This may not terminate when the tree is very large./+--+printTree :: (MonadIO m, Show a) => Gen m 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 size seed =+  fmap (Maybe.maybe "<discard>" show) . runDiscardEffect . runGen size seed++------------------------------------------------------------------------+-- Internal++-- $internal+--+-- These functions are exported in case you need them in a pinch, but are not+-- part of the public API and may change at any time, even as part of a minor+-- update.

@@ -0,0 +1,10 @@+{-# LANGUAGE RankNTypes #-}+module Hedgehog.Internal.HTraversable (+    HTraversable(..)+  ) where+++-- | Higher-order traversable functors.+--+class HTraversable t where+  htraverse :: Applicative f => (forall a. g a -> f (h a)) -> t g -> f (t h)

@@ -0,0 +1,25 @@+module Hedgehog.Internal.Opaque (+    Opaque(..)+  ) where+++-- | Opaque values.+--+--   Useful if you want to put something without a 'Show' instance inside+--   something which you'd like to be able to display.+--+--   For example:+--+-- @+--   data Ref v =+--     Ref (v (Opaque (IORef Int)))+-- @+--+newtype Opaque a =+  Opaque {+      unOpaque :: a+    } deriving (Eq, Ord)++instance Show (Opaque a) where+  showsPrec _ (Opaque _) =+    showString "Opaque"

@@ -46,8 +46,12 @@   , assert   , (===) +  , liftCatch+  , liftCatchIO   , liftEither   , liftExceptT++  , withCatch   , withExceptT   , withResourceT @@ -80,9 +84,10 @@ import           Data.Semigroup (Semigroup) import           Data.String (IsString) -import           Hedgehog.Gen (Gen)-import qualified Hedgehog.Gen as Gen import           Hedgehog.Internal.Distributive+import           Hedgehog.Internal.Exception+import           Hedgehog.Internal.Gen (Gen)+import qualified Hedgehog.Internal.Gen as Gen import           Hedgehog.Internal.Show import           Hedgehog.Internal.Source @@ -469,12 +474,39 @@ liftExceptT m =   withFrozenCallStack liftEither =<< lift (runExceptT m) +-- | Fails the test if the action throws an exception.+--+--   /The benefit of using this over 'lift' is that the location of the+--   exception will be shown in the output./+--+liftCatch :: (MonadCatch m, HasCallStack) => m a -> Test m a+liftCatch m =+  withFrozenCallStack liftEither =<< lift (tryAll m)++-- | Fails the test if the action throws an exception.+--+--   /The benefit of using this over 'liftIO' is that the location of the+--   exception will be shown in the output./+--+liftCatchIO :: (MonadIO m, HasCallStack) => IO a -> Test m a+liftCatchIO m =+  withFrozenCallStack liftEither =<< liftIO (tryAll m)+ -- | Fails the test if the 'ExceptT' is 'Left', otherwise returns the value in --   the 'Right'. -- withExceptT :: (Monad m, Show x, HasCallStack) => Test (ExceptT x m) a -> Test m a withExceptT m =   withFrozenCallStack liftEither =<< runExceptT (distribute m)++-- | 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 'withCatch' will be shown in the output./+--+withCatch :: (MonadCatch m, HasCallStack) => Test m a -> Test m a+withCatch m =+  withFrozenCallStack liftEither =<< tryAll m  -- | Run a computation which requires resource acquisition / release. --

@@ -0,0 +1,461 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Hedgehog.Internal.Range (+  -- * Size+    Size(..)++  -- * Range+  , Range(..)+  , origin+  , bounds+  , lowerBound+  , upperBound++  -- * Constant+  , singleton+  , constant+  , constantFrom+  , constantBounded++  -- * Linear+  , linear+  , linearFrom+  , linearFrac+  , linearFracFrom+  , linearBounded++  -- * Exponential+  , exponential+  , exponentialFrom+  , exponentialBounded+  , exponentialFloat+  , exponentialFloatFrom++  -- * Internal+  -- $internal+  , clamp+  , scaleLinear+  , scaleLinearFrac+  , scaleExponential+  , scaleExponentialFloat+  ) where++import           Data.Bifunctor (bimap)++import           Prelude hiding (minimum, maximum)++-- $setup+-- >>> import Data.Int (Int8)+-- >>> let x = 3++-- | Tests are parameterized by the size of the randomly-generated data, the+--   meaning of which depends on the particular generator used.+--+newtype Size =+  Size {+      unSize :: Int+    } deriving (Eq, Ord, Num, Real, Enum, Integral)++instance Show Size where+  showsPrec p (Size x) =+    showParen (p > 10) $+      showString "Size " .+      showsPrec 11 x++instance Read Size where+  readsPrec p =+    readParen (p > 10) $ \r0 -> do+      ("Size", r1) <- lex r0+      (s, r2) <- readsPrec 11 r1+      pure (Size s, r2)++-- | A range describes the bounds of a number to generate, which may or may not+--   be dependent on a 'Size'.+--+data Range a =+  Range !a (Size -> (a, a))++instance Functor Range where+  fmap f (Range z g) =+    Range (f z) $ \sz ->+      bimap f f (g sz)++-- | Get the origin of a range. This might be the mid-point or the lower bound,+--   depending on what the range represents.+--+--   The 'bounds' of a range are scaled around this value when using the+--   'linear' family of combinators.+--+--   When using a 'Range' to generate numbers, the shrinking function will+--   shrink towards the origin.+--+origin :: Range a -> a+origin (Range z _) =+  z++-- | Get the extents of a range, for a given size.+--+bounds :: Size -> Range a -> (a, a)+bounds sz (Range _ f) =+  f sz++-- | Get the lower bound of a range for the given size.+--+lowerBound :: Ord a => Size -> Range a -> a+lowerBound sz range =+  let+    (x, y) =+      bounds sz range+  in+    min x y++-- | Get the upper bound of a range for the given size.+--+upperBound :: Ord a => Size -> Range a -> a+upperBound sz range =+  let+    (x, y) =+      bounds sz range+  in+    max x y++-- | Construct a range which represents a constant single value.+--+--   >>> bounds x $ singleton 5+--   (5,5)+--+--   >>> origin $ singleton 5+--   5+--+singleton :: a -> Range a+singleton x =+  Range x $ \_ -> (x, x)++-- | Construct a range which is unaffected by the size parameter.+--+--   A range from @0@ to @10@, with the origin at @0@:+--+--   >>> bounds x $ constant 0 10+--   (0,10)+--+--   >>> origin $ constant 0 10+--   0+--+constant :: a -> a -> Range a+constant x y =+  constantFrom x x y++-- | Construct a range which is unaffected by the size parameter with a origin+--   point which may differ from the bounds.+--+--   A range from @-10@ to @10@, with the origin at @0@:+--+--   >>> bounds x $ constantFrom 0 (-10) 10+--   (-10,10)+--+--   >>> origin $ constantFrom 0 (-10) 10+--   0+--+--   A range from @1970@ to @2100@, with the origin at @2000@:+--+--   >>> bounds x $ constantFrom 2000 1970 2100+--   (1970,2100)+--+--   >>> origin $ constantFrom 2000 1970 2100+--   2000+--+constantFrom :: a -> a -> a -> Range a+constantFrom z x y =+  Range z $ \_ -> (x, y)++-- | Construct a range which is unaffected by the size parameter using the full+--   range of a data type.+--+--   A range from @-128@ to @127@, with the origin at @0@:+--+--   >>> bounds x (constantBounded :: Range Int8)+--   (-128,127)+--+--   >>> origin (constantBounded :: Range Int8)+--   0+--+constantBounded :: (Bounded a, Num a) => Range a+constantBounded =+  constantFrom 0 minBound maxBound++-- | Construct a range which scales the second bound relative to the size+--   parameter.+--+--   >>> bounds 0 $ linear 0 10+--   (0,0)+--+--   >>> bounds 50 $ linear 0 10+--   (0,5)+--+--   >>> bounds 99 $ linear 0 10+--   (0,10)+--+linear :: Integral a => a -> a -> Range a+linear x y =+  linearFrom x x y++-- | Construct a range which scales the bounds relative to the size parameter.+--+--   >>> bounds 0 $ linearFrom 0 (-10) 10+--   (0,0)+--+--   >>> bounds 50 $ linearFrom 0 (-10) 20+--   (-5,10)+--+--   >>> bounds 99 $ linearFrom 0 (-10) 20+--   (-10,20)+--+linearFrom :: Integral a => a -> a -> a -> Range a+linearFrom z x y =+  Range z $ \sz ->+    let+      x_sized =+        clamp x y $ scaleLinear sz z x++      y_sized =+        clamp x y $ scaleLinear sz z y+    in+      (x_sized, y_sized)++-- | Construct a range which is scaled relative to the size parameter and uses+--   the full range of a data type.+--+--   >>> bounds 0 (linearBounded :: Range Int8)+--   (0,0)+--+--   >>> bounds 50 (linearBounded :: Range Int8)+--   (-64,64)+--+--   >>> bounds 99 (linearBounded :: Range Int8)+--   (-128,127)+--+linearBounded :: (Bounded a, Integral a) => Range a+linearBounded =+  linearFrom 0 minBound maxBound++-- | Construct a range which scales the second bound relative to the size+--   parameter.+--+--   This works the same as 'linear', but for fractional values.+--+linearFrac :: (Fractional a, Ord a) => a -> a -> Range a+linearFrac x y =+  linearFracFrom x x y++-- | Construct a range which scales the bounds relative to the size parameter.+--+--   This works the same as 'linearFrom', but for fractional values.+--+linearFracFrom :: (Fractional a, Ord a) => a -> a -> a -> Range a+linearFracFrom z x y =+  Range z $ \sz ->+    let+      x_sized =+        clamp x y $ scaleLinearFrac sz z x++      y_sized =+        clamp x y $ scaleLinearFrac sz z y+    in+      (x_sized, y_sized)++-- | Truncate a value so it stays within some range.+--+--   >>> clamp 5 10 15+--   10+--+--   >>> clamp 5 10 0+--   5+--+clamp :: Ord a => a -> a -> a -> a+clamp x y n =+  if x > y then+    min x (max y n)+  else+    min y (max x n)++-- | Scale an integral linearly with the size parameter.+--+scaleLinear :: Integral a => Size -> a -> a -> a+scaleLinear sz0 z0 n0 =+  let+    sz =+      max 0 (min 99 sz0)++    z =+      toInteger z0++    n =+      toInteger n0++    diff =+      ((n - z) * fromIntegral sz) `quot` 99+  in+    fromInteger $ z + diff++-- | Scale a fractional number linearly with the size parameter.+--+scaleLinearFrac :: Fractional a => Size -> a -> a -> a+scaleLinearFrac sz0 z n =+  let+    sz =+      max 0 (min 99 sz0)++    diff =+      (n - z) * (fromIntegral sz / 99)+  in+    z + diff++-- | Construct a range which scales the second bound exponentially relative to+--   the size parameter.+--+--   >>> bounds 0 $ exponential 1 512+--   (1,1)+--+--   >>> bounds 11 $ exponential 1 512+--   (1,2)+--+--   >>> bounds 22 $ exponential 1 512+--   (1,4)+--+--   >>> bounds 77 $ exponential 1 512+--   (1,128)+--+--   >>> bounds 88 $ exponential 1 512+--   (1,256)+--+--   >>> bounds 99 $ exponential 1 512+--   (1,512)+--+exponential :: Integral a => a -> a -> Range a+exponential x y =+  exponentialFrom x x y++-- | Construct a range which scales the bounds exponentially relative to the+-- size parameter.+--+--   >>> bounds 0 $ exponentialFrom 0 (-128) 512+--   (0,0)+--+--   >>> bounds 25 $ exponentialFrom 0 (-128) 512+--   (-2,4)+--+--   >>> bounds 50 $ exponentialFrom 0 (-128) 512+--   (-11,22)+--+--   >>> bounds 75 $ exponentialFrom 0 (-128) 512+--   (-39,112)+--+--   >>> bounds 99 $ exponentialFrom x (-128) 512+--   (-128,512)+--+exponentialFrom :: Integral a => a -> a -> a -> Range a+exponentialFrom z x y =+  Range z $ \sz ->+    let+      sized_x =+        clamp x y $ scaleExponential sz z x++      sized_y =+        clamp x y $ scaleExponential sz z y+    in+      (sized_x, sized_y)++-- | Construct a range which is scaled exponentially relative to the size+--   parameter and uses the full range of a data type.+--+--   >>> bounds 0 (exponentialBounded :: Range Int8)+--   (0,0)+--+--   >>> bounds 50 (exponentialBounded :: Range Int8)+--   (-11,11)+--+--   >>> bounds 99 (exponentialBounded :: Range Int8)+--   (-128,127)+--+exponentialBounded :: (Bounded a, Integral a) => Range a+exponentialBounded =+  exponentialFrom 0 minBound maxBound++-- | Construct a range which scales the second bound exponentially relative to+--   the size parameter.+--+--   This works the same as 'exponential', but for floating-point values.+--+--   >>> bounds 0 $ exponentialFloat 0 10+--   (0.0,0.0)+--+--   >>> bounds 50 $ exponentialFloat 0 10+--   (0.0,2.357035250656098)+--+--   >>> bounds 99 $ exponentialFloat 0 10+--   (0.0,10.0)+--+exponentialFloat :: (Floating a, Ord a) => a -> a -> Range a+exponentialFloat x y =+  exponentialFloatFrom x x y++-- | Construct a range which scales the bounds exponentially relative to the+--   size parameter.+--+--   This works the same as 'exponentialFrom', but for floating-point values.+--+--   >>> bounds 0 $ exponentialFloatFrom 0 (-10) 20+--   (0.0,0.0)+--+--   >>> bounds 50 $ exponentialFloatFrom 0 (-10) 20+--   (-2.357035250656098,3.6535836249197002)+--+--   >>> bounds 99 $ exponentialFloatFrom x (-10) 20+--   (-10.0,20.0)+--+exponentialFloatFrom :: (Floating a, Ord a) => a -> a -> a -> Range a+exponentialFloatFrom z x y =+  Range z $ \sz ->+    let+      sized_x =+        clamp x y $ scaleExponentialFloat sz z x++      sized_y =+        clamp x y $ scaleExponentialFloat sz z y+    in+      (sized_x, sized_y)++-- | Scale an integral exponentially with the size parameter.+--+scaleExponential :: Integral a => Size -> a -> a -> a+scaleExponential sz z0 n0 =+  let+    z =+      fromIntegral z0++    n =+      fromIntegral n0+  in+    round (scaleExponentialFloat sz z n :: Double)++-- | Scale a floating-point number exponentially with the size parameter.+--+scaleExponentialFloat :: Floating a => Size -> a -> a -> a+scaleExponentialFloat sz0 z n =+  let+    sz =+      clamp 0 99 sz0++    diff =+      (((abs (n - z) + 1) ** (realToFrac sz / 99)) - 1) * signum (n - z)+  in+    z + diff+++------------------------------------------------------------------------+-- Internal++-- $internal+--+-- These functions are exported in case you need them in a pinch, but are not+-- part of the public API and may change at any time, even as part of a minor+-- update.

@@ -28,9 +28,8 @@  import           Data.Semigroup ((<>)) -import           Hedgehog.Gen (runGen)-import qualified Hedgehog.Gen as Gen import           Hedgehog.Internal.Config+import           Hedgehog.Internal.Gen (runGen, runDiscardEffect) import           Hedgehog.Internal.Property (Group(..), GroupName(..)) import           Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..)) import           Hedgehog.Internal.Property (ShrinkLimit, withTests)@@ -104,7 +103,7 @@       Left (Failure loc err mdiff) -> do         let           failure =-            mkFailure size seed shrinks loc err mdiff w+            mkFailure size seed shrinks loc err mdiff (reverse w)          updateUI $ Shrinking failure @@ -157,7 +156,7 @@         case Seed.split seed of           (s0, s1) -> do             node@(Node x _) <--              runTree . Gen.runDiscardEffect $ runGen size s0 (runTest test)+              runTree . runDiscardEffect $ runGen size s0 (runTest test)             case x of               Nothing ->                 loop tests (discards + 1) (size + 1) s1

@@ -0,0 +1,474 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+module Hedgehog.Internal.State (+  -- * Variables+    Var(..)+  , Symbolic(..)+  , Concrete(..)++  -- * Environment+  , Environment(..)+  , EnvironmentError(..)+  , emptyEnvironment+  , insertConcrete+  , reifyDynamic+  , reifyEnvironment+  , reify++  -- * Commands+  , Command(..)+  , Callback(..)+  , commandGenOK++  -- * Actions+  , Action(..)+  , takeVariables+  , variablesOK+  , dropInvalid+  , action+  , actions+  , execute+  , executeSequential+  ) where++import           Control.Monad (when, foldM_)+import           Control.Monad.Catch (MonadCatch)+import           Control.Monad.Morph (hoist)+import           Control.Monad.State.Class (get, put, modify)+import           Control.Monad.Trans.Class (lift)+import           Control.Monad.Trans.State (StateT, execState, evalStateT)++import           Data.Dynamic (Dynamic, toDyn, fromDynamic, dynTypeRep)+import           Data.Foldable (traverse_)+import           Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..), showsPrec1)+import           Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import           Data.Set (Set)+import qualified Data.Set as Set+import           Data.Typeable (Typeable, TypeRep, Proxy(..), typeRep)++import           Hedgehog.Internal.Gen (Gen)+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.Range (Range)+++-- | Symbolic variable names.+--+newtype Var =+  Var Int+  deriving (Eq, Ord, Show, Num)++-- | Symbolic values.+--+data Symbolic a where+  Symbolic :: Typeable a => Var -> Symbolic a++deriving instance Eq (Symbolic a)+deriving instance Ord (Symbolic a)++instance Show (Symbolic a) where+  showsPrec p (Symbolic x) =+    showsPrec p x++instance Show1 Symbolic where+  liftShowsPrec _ _ p (Symbolic x) =+    showsPrec p x++instance Eq1 Symbolic where+  liftEq _ (Symbolic x) (Symbolic y) =+    x == y++instance Ord1 Symbolic where+  liftCompare _ (Symbolic x) (Symbolic y) =+    compare x y++-- | Concrete values.+--+newtype Concrete a where+  Concrete :: a -> Concrete a+  deriving (Eq, Ord, Functor, Foldable, Traversable)++instance Show a => Show (Concrete a) where+  showsPrec =+    showsPrec1++instance Show1 Concrete where+  liftShowsPrec sp _ p (Concrete x) =+    sp p x++instance Eq1 Concrete where+  liftEq eq (Concrete x) (Concrete y) =+    eq x y++instance Ord1 Concrete where+  liftCompare comp (Concrete x) (Concrete y) =+    comp x y++------------------------------------------------------------------------+-- Symbolic Environment++-- | A mapping of symbolic values to concrete values.+--+newtype Environment =+  Environment {+      unEnvironment :: Map Var Dynamic+    } deriving (Show)++-- | Environment errors.+--+data EnvironmentError =+    EnvironmentValueNotFound !Var+  | EnvironmentTypeError !TypeRep !TypeRep+    deriving (Eq, Ord, Show)++-- | Create an empty environment.+--+emptyEnvironment :: Environment+emptyEnvironment =+  Environment Map.empty++-- | Insert a symbolic / concrete pairing in to the environment.+--+insertConcrete :: Symbolic a -> Concrete a -> Environment -> Environment+insertConcrete (Symbolic k) (Concrete v) =+  Environment . Map.insert k (toDyn v) . unEnvironment++-- | Cast a 'Dynamic' in to a concrete value.+--+reifyDynamic :: forall a. Typeable a => Dynamic -> Either EnvironmentError (Concrete a)+reifyDynamic dyn =+  case fromDynamic dyn of+    Nothing ->+      Left $ EnvironmentTypeError (typeRep (Proxy :: Proxy a)) (dynTypeRep dyn)+    Just x ->+      Right $ Concrete x++-- | Turns an environment in to a function for looking up a concrete value from+--   a symbolic one.+--+reifyEnvironment :: Environment -> (forall a. Symbolic a -> Either EnvironmentError (Concrete a))+reifyEnvironment (Environment vars) (Symbolic n) =+  case Map.lookup n vars of+    Nothing ->+      Left $ EnvironmentValueNotFound n+    Just dyn ->+      reifyDynamic dyn++-- | Convert a symbolic structure to a concrete one, using the provided environment.+--+reify :: HTraversable t => Environment -> t Symbolic -> Either EnvironmentError (t Concrete)+reify vars =+  htraverse (reifyEnvironment vars)++------------------------------------------------------------------------+-- Callbacks++-- | Optional command configuration.+--+data Callback input output m state =+  -- | A pre-condition for a command that must be verified before the command+  --   can be executed. This is mainly used during shrinking to ensure that it+  --   is still OK to run a command despite the fact that some previously+  --   executed commands may have been removed from the sequence.+  --+    Require (state Symbolic -> input Symbolic -> Bool)++  -- | Updates the model state, given the input and output of the command. Note+  --   that this function is polymorphic in the type of values. This is because+  --   it must work over 'Symbolic' values when we are generating actions, and+  --   'Concrete' values when we are executing them.+  --+  | Update (forall v. Ord1 v => state v -> input v -> v output -> 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 ())++callbackRequire1 ::+     state Symbolic+  -> input Symbolic+  -> Callback input output m state+  -> Bool+callbackRequire1 s i = \case+  Require f ->+    f s i+  Update _ ->+    True+  Ensure _ ->+    True++callbackUpdate1 ::+     Ord1 v+  => state v+  -> input v+  -> v output+  -> Callback input output m state+  -> state v+callbackUpdate1 s i o = \case+  Require _ ->+    s+  Update f ->+    f s i o+  Ensure _ ->+    s++callbackEnsure1 ::+     Monad m+  => state Concrete+  -> input Concrete+  -> output+  -> Callback input output m state+  -> Test m ()+callbackEnsure1 s i o = \case+  Require _ ->+    success+  Update _ ->+    success+  Ensure f ->+    f s i o++callbackRequire ::+     [Callback input output m state]+  -> state Symbolic+  -> input Symbolic+  -> Bool+callbackRequire callbacks s i =+  all (callbackRequire1 s i) callbacks++callbackUpdate ::+     Ord1 v+  => [Callback input output m state]+  -> state v+  -> input v+  -> v output+  -> state v+callbackUpdate callbacks s0 i o =+  foldl (\s -> callbackUpdate1 s i o) s0 callbacks++callbackEnsure ::+     Monad m+  => [Callback input output m state]+  -> state Concrete+  -> input Concrete+  -> output+  -> Test m ()+callbackEnsure callbacks s i o =+  traverse_ (callbackEnsure1 s i o) callbacks++------------------------------------------------------------------------++-- | The specification for the expected behaviour of an 'Action'.+--+data Command n m (state :: (* -> *) -> *) =+  forall input output.+  (HTraversable input, Show (input Symbolic), Typeable output) =>+  Command {+    -- | A generator which provides random arguments for a command. If the+    --   command cannot be executed in the current state, it should return+    --   'Nothing'.+    --+      commandGen ::+        state Symbolic -> Maybe (Gen n (input Symbolic))++    -- | Executes a command using the arguments generated by 'commandGen'.+    --+    , commandExecute ::+        input Concrete -> Test 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]+    }++-- | Checks that input for a command can be executed in the given state.+--+commandGenOK :: Command n m state -> state Symbolic -> Bool+commandGenOK (Command inputGen _ _) state =+  Maybe.isJust (inputGen state)++-- | An instantiation of a 'Command' which can be executed, and its effect+--   evaluated.+--+data Action m (state :: (* -> *) -> *) =+  forall input output.+  (HTraversable input, Show (input Symbolic)) =>+  Action {+      actionInput ::+        input Symbolic++    , actionOutput ::+        Symbolic output++    , actionExecute ::+        input Concrete -> Test m output++    , actionRequire ::+        state Symbolic -> input Symbolic -> Bool++    , actionUpdate ::+        forall v. Ord1 v => state v -> input v -> v output -> state v++    , actionEnsure ::+        state Concrete -> input Concrete -> output -> Test m ()+    }++instance Show (Action m state) where+  showsPrec p (Action input output _ _ _ _) =+    showParen (p > 10) $+      showsPrec 11 output .+      showString " :<- " .+      showsPrec 11 input++-- | Collects all the symbolic values in a data structure and produces a set of+--   all the variables they refer to.+--+takeVariables :: HTraversable t => t Symbolic -> Set Var+takeVariables xs =+  let+    go x@(Symbolic var) = do+      modify (Set.insert var)+      pure x+  in+    flip execState Set.empty $ htraverse go xs++-- | Checks that the symbolic values in the data structure refer only to the+--   variables in the provided set.+--+variablesOK :: HTraversable t => t Symbolic -> Set Var -> Bool+variablesOK xs allowed =+  Set.null (takeVariables xs `Set.difference` allowed)++-- | Drops invalid actions from the sequence.+--+dropInvalid :: (forall v. state v) -> [Action m state] -> [Action m state]+dropInvalid initial =+  let+    loop step@(Action input output@(Symbolic var) _execute require update _ensure) = do+      ((state0, vars0), steps0) <- get++      when (require state0 input && variablesOK input vars0) $+        let+          state =+            update state0 input output++          vars =+            Set.insert var vars0++          steps =+            steps0 ++ [step]+        in+          put ((state, vars), steps)+  in+    snd . flip execState ((initial, Set.empty), []) . traverse_ loop++-- | Generates a single action from a set of possible commands.+--+action ::+     (Monad n, Monad m)+  => [Command n m state]+  -> Gen (StateT (state Symbolic, Var) n) (Action m state)+action commands =+  Gen.just $ do+    (state, var) <- get++    Command mgenInput exec callbacks <-+      Gen.element $ filter (\c -> commandGenOK c state) commands++    input <-+      case mgenInput state of+        Nothing ->+          error "genCommand: internal error, tried to use generator with invalid state."+        Just g ->+          hoist lift g++    if not $ callbackRequire callbacks state input then+      pure Nothing++    else do+      let+        output =+          Symbolic var++      put (callbackUpdate callbacks state input output, var + 1)++      pure . Just $+        Action input output exec+          (callbackRequire callbacks)+          (callbackUpdate callbacks)+          (callbackEnsure callbacks)++-- | Generates a sequence of actions from an initial model state and set of commands.+--+actions ::+     (Monad n, Monad 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++-- | Executes a single action in the given evironment.+--+execute ::+     (HasCallStack, Monad m)+  => (state Concrete, Environment)+  -> Action m state+  -> Test m (state Concrete, Environment)+execute (state0, env0) (Action sinput soutput exec _require update ensure) =+  withFrozenCallStack $ do+    input <- liftEither $ reify env0 sinput+    output <- exec input++    let+      coutput =+        Concrete output++      state =+        update state0 input coutput++      env =+        insertConcrete soutput coutput env0++    ensure state input output++    pure (state, env)++-- | Executes a list of actions sequentially, verifying that all+--   post-conditions are met and no exceptions are thrown.+--+--   To generate a sequence of actions to execute, see the+--   'Hedgehog.Gen.actions' combinator in the "Hedgehog.Gen" module.+--+executeSequential ::+     forall m state.+     (HasCallStack, MonadCatch m)+  => (forall v. state v)+  -> [Action m state]+  -> Test m ()+executeSequential initial commands =+  withFrozenCallStack $+    withCatch (foldM_ execute (initial, emptyEnvironment) commands)

@@ -4,7 +4,7 @@     Size(..)    -- * Range-  , Range(..)+  , Range   , origin   , bounds   , lowerBound@@ -29,433 +29,6 @@   , exponentialBounded   , exponentialFloat   , exponentialFloatFrom--  -- * Internal-  -- $internal-  , clamp-  , scaleLinear-  , scaleLinearFrac-  , scaleExponential-  , scaleExponentialFloat   ) where -import           Data.Bifunctor (bimap)--import           Prelude hiding (minimum, maximum)---- $setup--- >>> import Data.Int (Int8)--- >>> let x = 3---- | Tests are parameterized by the size of the randomly-generated data, the---   meaning of which depends on the particular generator used.----newtype Size =-  Size {-      unSize :: Int-    } deriving (Eq, Ord, Num, Real, Enum, Integral)--instance Show Size where-  showsPrec p (Size x) =-    showParen (p > 10) $-      showString "Size " .-      showsPrec 11 x--instance Read Size where-  readsPrec p =-    readParen (p > 10) $ \r0 -> do-      ("Size", r1) <- lex r0-      (s, r2) <- readsPrec 11 r1-      pure (Size s, r2)---- | A range describes the bounds of a number to generate, which may or may not---   be dependent on a 'Size'.----data Range a =-  Range !a (Size -> (a, a))--instance Functor Range where-  fmap f (Range z g) =-    Range (f z) $ \sz ->-      bimap f f (g sz)---- | Get the origin of a range. This might be the mid-point or the lower bound,---   depending on what the range represents.------   The 'bounds' of a range are scaled around this value when using the---   'linear' family of combinators.------   When using a 'Range' to generate numbers, the shrinking function will---   shrink towards the origin.----origin :: Range a -> a-origin (Range z _) =-  z---- | Get the extents of a range, for a given size.----bounds :: Size -> Range a -> (a, a)-bounds sz (Range _ f) =-  f sz---- | Get the lower bound of a range for the given size.----lowerBound :: Ord a => Size -> Range a -> a-lowerBound sz range =-  let-    (x, y) =-      bounds sz range-  in-    min x y---- | Get the upper bound of a range for the given size.----upperBound :: Ord a => Size -> Range a -> a-upperBound sz range =-  let-    (x, y) =-      bounds sz range-  in-    max x y---- | Construct a range which represents a constant single value.------   >>> bounds x $ singleton 5---   (5,5)------   >>> origin $ singleton 5---   5----singleton :: a -> Range a-singleton x =-  Range x $ \_ -> (x, x)---- | Construct a range which is unaffected by the size parameter.------   A range from @0@ to @10@, with the origin at @0@:------   >>> bounds x $ constant 0 10---   (0,10)------   >>> origin $ constant 0 10---   0----constant :: a -> a -> Range a-constant x y =-  constantFrom x x y---- | Construct a range which is unaffected by the size parameter with a origin---   point which may differ from the bounds.------   A range from @-10@ to @10@, with the origin at @0@:------   >>> bounds x $ constantFrom 0 (-10) 10---   (-10,10)------   >>> origin $ constantFrom 0 (-10) 10---   0------   A range from @1970@ to @2100@, with the origin at @2000@:------   >>> bounds x $ constantFrom 2000 1970 2100---   (1970,2100)------   >>> origin $ constantFrom 2000 1970 2100---   2000----constantFrom :: a -> a -> a -> Range a-constantFrom z x y =-  Range z $ \_ -> (x, y)---- | Construct a range which is unaffected by the size parameter using the full---   range of a data type.------   A range from @-128@ to @127@, with the origin at @0@:------   >>> bounds x (constantBounded :: Range Int8)---   (-128,127)------   >>> origin (constantBounded :: Range Int8)---   0----constantBounded :: (Bounded a, Num a) => Range a-constantBounded =-  constantFrom 0 minBound maxBound---- | Construct a range which scales the second bound relative to the size---   parameter.------   >>> bounds 0 $ linear 0 10---   (0,0)------   >>> bounds 50 $ linear 0 10---   (0,5)------   >>> bounds 99 $ linear 0 10---   (0,10)----linear :: Integral a => a -> a -> Range a-linear x y =-  linearFrom x x y---- | Construct a range which scales the bounds relative to the size parameter.------   >>> bounds 0 $ linearFrom 0 (-10) 10---   (0,0)------   >>> bounds 50 $ linearFrom 0 (-10) 20---   (-5,10)------   >>> bounds 99 $ linearFrom 0 (-10) 20---   (-10,20)----linearFrom :: Integral a => a -> a -> a -> Range a-linearFrom z x y =-  Range z $ \sz ->-    let-      x_sized =-        clamp x y $ scaleLinear sz z x--      y_sized =-        clamp x y $ scaleLinear sz z y-    in-      (x_sized, y_sized)---- | Construct a range which is scaled relative to the size parameter and uses---   the full range of a data type.------   >>> bounds 0 (linearBounded :: Range Int8)---   (0,0)------   >>> bounds 50 (linearBounded :: Range Int8)---   (-64,64)------   >>> bounds 99 (linearBounded :: Range Int8)---   (-128,127)----linearBounded :: (Bounded a, Integral a) => Range a-linearBounded =-  linearFrom 0 minBound maxBound---- | Construct a range which scales the second bound relative to the size---   parameter.------   This works the same as 'linear', but for fractional values.----linearFrac :: (Fractional a, Ord a) => a -> a -> Range a-linearFrac x y =-  linearFracFrom x x y---- | Construct a range which scales the bounds relative to the size parameter.------   This works the same as 'linearFrom', but for fractional values.----linearFracFrom :: (Fractional a, Ord a) => a -> a -> a -> Range a-linearFracFrom z x y =-  Range z $ \sz ->-    let-      x_sized =-        clamp x y $ scaleLinearFrac sz z x--      y_sized =-        clamp x y $ scaleLinearFrac sz z y-    in-      (x_sized, y_sized)---- | Truncate a value so it stays within some range.------   >>> clamp 5 10 15---   10------   >>> clamp 5 10 0---   5----clamp :: Ord a => a -> a -> a -> a-clamp x y n =-  if x > y then-    min x (max y n)-  else-    min y (max x n)---- | Scale an integral linearly with the size parameter.----scaleLinear :: Integral a => Size -> a -> a -> a-scaleLinear sz0 z0 n0 =-  let-    sz =-      max 0 (min 99 sz0)--    z =-      toInteger z0--    n =-      toInteger n0--    diff =-      ((n - z) * fromIntegral sz) `quot` 99-  in-    fromInteger $ z + diff---- | Scale a fractional number linearly with the size parameter.----scaleLinearFrac :: Fractional a => Size -> a -> a -> a-scaleLinearFrac sz0 z n =-  let-    sz =-      max 0 (min 99 sz0)--    diff =-      (n - z) * (fromIntegral sz / 99)-  in-    z + diff---- | Construct a range which scales the second bound exponentially relative to---   the size parameter.------   >>> bounds 0 $ exponential 1 512---   (1,1)------   >>> bounds 11 $ exponential 1 512---   (1,2)------   >>> bounds 22 $ exponential 1 512---   (1,4)------   >>> bounds 77 $ exponential 1 512---   (1,128)------   >>> bounds 88 $ exponential 1 512---   (1,256)------   >>> bounds 99 $ exponential 1 512---   (1,512)----exponential :: Integral a => a -> a -> Range a-exponential x y =-  exponentialFrom x x y---- | Construct a range which scales the bounds exponentially relative to the--- size parameter.------   >>> bounds 0 $ exponentialFrom 0 (-128) 512---   (0,0)------   >>> bounds 25 $ exponentialFrom 0 (-128) 512---   (-2,4)------   >>> bounds 50 $ exponentialFrom 0 (-128) 512---   (-11,22)------   >>> bounds 75 $ exponentialFrom 0 (-128) 512---   (-39,112)------   >>> bounds 99 $ exponentialFrom x (-128) 512---   (-128,512)----exponentialFrom :: Integral a => a -> a -> a -> Range a-exponentialFrom z x y =-  Range z $ \sz ->-    let-      sized_x =-        clamp x y $ scaleExponential sz z x--      sized_y =-        clamp x y $ scaleExponential sz z y-    in-      (sized_x, sized_y)---- | Construct a range which is scaled exponentially relative to the size---   parameter and uses the full range of a data type.------   >>> bounds 0 (exponentialBounded :: Range Int8)---   (0,0)------   >>> bounds 50 (exponentialBounded :: Range Int8)---   (-11,11)------   >>> bounds 99 (exponentialBounded :: Range Int8)---   (-128,127)----exponentialBounded :: (Bounded a, Integral a) => Range a-exponentialBounded =-  exponentialFrom 0 minBound maxBound---- | Construct a range which scales the second bound exponentially relative to---   the size parameter.------   This works the same as 'exponential', but for floating-point values.------   >>> bounds 0 $ exponentialFloat 0 10---   (0.0,0.0)------   >>> bounds 50 $ exponentialFloat 0 10---   (0.0,2.357035250656098)------   >>> bounds 99 $ exponentialFloat 0 10---   (0.0,10.0)----exponentialFloat :: (Floating a, Ord a) => a -> a -> Range a-exponentialFloat x y =-  exponentialFloatFrom x x y---- | Construct a range which scales the bounds exponentially relative to the---   size parameter.------   This works the same as 'exponentialFrom', but for floating-point values.------   >>> bounds 0 $ exponentialFloatFrom 0 (-10) 20---   (0.0,0.0)------   >>> bounds 50 $ exponentialFloatFrom 0 (-10) 20---   (-2.357035250656098,3.6535836249197002)------   >>> bounds 99 $ exponentialFloatFrom x (-10) 20---   (-10.0,20.0)----exponentialFloatFrom :: (Floating a, Ord a) => a -> a -> a -> Range a-exponentialFloatFrom z x y =-  Range z $ \sz ->-    let-      sized_x =-        clamp x y $ scaleExponentialFloat sz z x--      sized_y =-        clamp x y $ scaleExponentialFloat sz z y-    in-      (sized_x, sized_y)---- | Scale an integral exponentially with the size parameter.----scaleExponential :: Integral a => Size -> a -> a -> a-scaleExponential sz z0 n0 =-  let-    z =-      fromIntegral z0--    n =-      fromIntegral n0-  in-    round (scaleExponentialFloat sz z n :: Double)---- | Scale a floating-point number exponentially with the size parameter.----scaleExponentialFloat :: Floating a => Size -> a -> a -> a-scaleExponentialFloat sz0 z n =-  let-    sz =-      clamp 0 99 sz0--    diff =-      (((abs (n - z) + 1) ** (realToFrac sz / 99)) - 1) * signum (n - z)-  in-    z + diff------------------------------------------------------------------------------ Internal---- $internal------ These functions are exported in case you need them in a pinch, but are not--- part of the public API and may change at any time, even as part of a minor--- update.+import           Hedgehog.Internal.Range