diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/hedgehog.cabal b/hedgehog.cabal --- a/hedgehog.cabal +++ b/hedgehog.cabal @@ -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 diff --git a/src/Hedgehog.hs b/src/Hedgehog.hs --- a/src/Hedgehog.hs +++ b/src/Hedgehog.hs @@ -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(..)) diff --git a/src/Hedgehog/Gen.hs b/src/Hedgehog/Gen.hs --- a/src/Hedgehog/Gen.hs +++ b/src/Hedgehog/Gen.hs @@ -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 "" 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) diff --git a/src/Hedgehog/Internal/Distributive.hs b/src/Hedgehog/Internal/Distributive.hs --- a/src/Hedgehog/Internal/Distributive.hs +++ b/src/Hedgehog/Internal/Distributive.hs @@ -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 diff --git a/src/Hedgehog/Internal/Exception.hs b/src/Hedgehog/Internal/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/Exception.hs @@ -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 diff --git a/src/Hedgehog/Internal/Gen.hs b/src/Hedgehog/Internal/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/Gen.hs @@ -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 "" 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. diff --git a/src/Hedgehog/Internal/HTraversable.hs b/src/Hedgehog/Internal/HTraversable.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/HTraversable.hs @@ -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) diff --git a/src/Hedgehog/Internal/Opaque.hs b/src/Hedgehog/Internal/Opaque.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/Opaque.hs @@ -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" diff --git a/src/Hedgehog/Internal/Property.hs b/src/Hedgehog/Internal/Property.hs --- a/src/Hedgehog/Internal/Property.hs +++ b/src/Hedgehog/Internal/Property.hs @@ -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. -- diff --git a/src/Hedgehog/Internal/Range.hs b/src/Hedgehog/Internal/Range.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/Range.hs @@ -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. diff --git a/src/Hedgehog/Internal/Runner.hs b/src/Hedgehog/Internal/Runner.hs --- a/src/Hedgehog/Internal/Runner.hs +++ b/src/Hedgehog/Internal/Runner.hs @@ -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 diff --git a/src/Hedgehog/Internal/State.hs b/src/Hedgehog/Internal/State.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/State.hs @@ -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) diff --git a/src/Hedgehog/Range.hs b/src/Hedgehog/Range.hs --- a/src/Hedgehog/Range.hs +++ b/src/Hedgehog/Range.hs @@ -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