module Hedgehog.Gen (
Gen(..)
, shrink
, prune
, small
, scale
, resize
, sized
, integral
, integral_
, int
, int8
, int16
, int32
, int64
, word
, word8
, word16
, word32
, word64
, realFloat
, realFrac_
, float
, double
, enum
, enumBounded
, bool
, bool_
, binit
, octit
, digit
, hexit
, lower
, upper
, alpha
, alphaNum
, ascii
, latin1
, unicode
, unicodeAll
, string
, text
, utf8
, bytes
, constant
, element
, choice
, frequency
, recursive
, discard
, filter
, just
, maybe
, list
, seq
, nonEmpty
, set
, map
, subterm
, subtermM
, subterm2
, subtermM2
, subterm3
, subtermM3
, subsequence
, shuffle
, sample
, print
, printTree
, printWith
, printTreeWith
, runGen
, mapGen
, generate
, liftTree
, runDiscardEffect
, golden
, atLeast
, isSurrogate
, Vec(..)
, Nat(..)
, subtermMVec
, freeze
, renderNodes
) where
import Control.Applicative (Alternative(..))
import Control.Monad (MonadPlus(..), mfilter, filterM, replicateM, ap)
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.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)
newtype Gen m a =
Gen {
unGen :: Size -> Seed -> Tree (MaybeT m) a
}
runGen :: Size -> Seed -> Gen m a -> Tree (MaybeT m) a
runGen size seed (Gen m) =
m size seed
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 :: Monad m => (Size -> Seed -> a) -> Gen m a
generate f =
Gen $ \size seed ->
pure (f size seed)
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 . pure $ Node x xs)
liftTree :: Tree (MaybeT m) a -> Gen m a
liftTree x =
Gen (\_ _ -> x)
runDiscardEffect :: Monad m => Tree (MaybeT m) a -> Tree m (Maybe a)
runDiscardEffect s =
Tree $ do
mx <- runMaybeT $ runTree s
case mx of
Nothing ->
pure $ Node Nothing []
Just (Node x xs) ->
pure $ Node (Just x) (fmap runDiscardEffect xs)
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
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
shrink :: Monad m => (a -> [a]) -> Gen m a -> Gen m a
shrink =
mapGen . Tree.expand
prune :: Monad m => Gen m a -> Gen m a
prune =
mapGen Tree.prune
sized :: (Size -> Gen m a) -> Gen m a
sized f =
Gen $ \size seed ->
runGen size seed (f size)
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
scale :: (Size -> Size) -> Gen m a -> Gen m a
scale f gen =
sized $ \n ->
resize (f n) gen
small :: Gen m a -> Gen m a
small =
scale golden
golden :: Size -> Size
golden x =
round (fromIntegral x * 0.61803398875 :: Double)
integral :: (Monad m, Integral a) => Range a -> Gen m a
integral range =
shrink (Shrink.towards $ Range.origin range) (integral_ range)
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
int :: Monad m => Range Int -> Gen m Int
int =
integral
int8 :: Monad m => Range Int8 -> Gen m Int8
int8 =
integral
int16 :: Monad m => Range Int16 -> Gen m Int16
int16 =
integral
int32 :: Monad m => Range Int32 -> Gen m Int32
int32 =
integral
int64 :: Monad m => Range Int64 -> Gen m Int64
int64 =
integral
word :: Monad m => Range Word -> Gen m Word
word =
integral
word8 :: Monad m => Range Word8 -> Gen m Word8
word8 =
integral
word16 :: Monad m => Range Word16 -> Gen m Word16
word16 =
integral
word32 :: Monad m => Range Word32 -> Gen m Word32
word32 =
integral
word64 :: Monad m => Range Word64 -> Gen m Word64
word64 =
integral
realFloat :: (Monad m, RealFloat a) => Range a -> Gen m a
realFloat range =
shrink (Shrink.towardsFloat $ Range.origin range) (realFrac_ range)
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
float :: Monad m => Range Float -> Gen m Float
float =
realFloat
double :: Monad m => Range Double -> Gen m Double
double =
realFloat
enum :: (Monad m, Enum a) => a -> a -> Gen m a
enum lo hi =
fmap toEnum . integral $
Range.constant (fromEnum lo) (fromEnum hi)
enumBounded :: (Monad m, Enum a, Bounded a) => Gen m a
enumBounded =
enum minBound maxBound
bool :: Monad m => Gen m Bool
bool =
enumBounded
bool_ :: Monad m => Gen m Bool
bool_ =
generate $ \_ seed ->
(/= 0) . fst $ Seed.nextInteger 0 1 seed
binit :: Monad m => Gen m Char
binit =
enum '0' '1'
octit :: Monad m => Gen m Char
octit =
enum '0' '7'
digit :: Monad m => Gen m Char
digit =
enum '0' '9'
hexit :: Monad m => Gen m Char
hexit =
element "0123456789aAbBcCdDeEfF"
lower :: Monad m => Gen m Char
lower =
enum 'a' 'z'
upper :: Monad m => Gen m Char
upper =
enum 'A' 'Z'
alpha :: Monad m => Gen m Char
alpha =
element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
alphaNum :: Monad m => Gen m Char
alphaNum =
element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
ascii :: Monad m => Gen m Char
ascii =
enum '\0' '\127'
latin1 :: Monad m => Gen m Char
latin1 =
enum '\0' '\255'
unicode :: Monad m => Gen m Char
unicode =
filter (not . isSurrogate) unicodeAll
unicodeAll :: Monad m => Gen m Char
unicodeAll =
enumBounded
isSurrogate :: Char -> Bool
isSurrogate x =
x >= '\55296' && x <= '\57344'
string :: Monad m => Range Int -> Gen m Char -> Gen m String
string =
list
text :: Monad m => Range Int -> Gen m Char -> Gen m Text
text range =
fmap Text.pack . string range
utf8 :: Monad m => Range Int -> Gen m Char -> Gen m ByteString
utf8 range =
fmap Text.encodeUtf8 . text range
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
]
constant :: Monad m => a -> Gen m a
constant =
pure
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
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
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
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
discard :: Monad m => Gen m a
discard =
mzero
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
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"
maybe :: Monad m => Gen m a -> Gen m (Maybe a)
maybe gen =
sized $ \n ->
frequency [
(2, pure Nothing)
, (1 + fromIntegral n, Just <$> gen)
]
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)
seq :: Monad m => Range Int -> Gen m a -> Gen m (Seq a)
seq range gen =
Seq.fromList <$> list range gen
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
set :: (Monad m, Ord a) => Range Int -> Gen m a -> Gen m (Set a)
set range gen =
fmap Map.keysSet . map range $ fmap (, ()) gen
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
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
atLeast :: Int -> [a] -> Bool
atLeast n =
if n == 0 then
const True
else
not . null . drop (n 1)
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
subtermMVec :: Monad m => Vec n (Gen m a) -> (Vec n a -> Gen m a) -> Gen m a
subtermMVec gs f =
fromSubterms f =<< genSubterms gs
subtermM :: Monad m => Gen m a -> (a -> Gen m a) -> Gen m a
subtermM gx f =
subtermMVec (gx :. Nil) $ \(x :. Nil) ->
f x
subterm :: Monad m => Gen m a -> (a -> a) -> Gen m a
subterm gx f =
subtermM gx $ \x ->
pure (f x)
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
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)
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
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)
subsequence :: Monad m => [a] -> Gen m [a]
subsequence xs =
shrink Shrink.list $ filterM (const bool_) xs
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"
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
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
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
print :: (MonadIO m, Show a) => Gen m a -> m ()
print gen = do
seed <- liftIO Seed.random
printWith 30 seed gen
printTree :: (MonadIO m, Show a) => Gen m a -> m ()
printTree gen = do
seed <- liftIO Seed.random
printTreeWith 30 seed gen
renderNodes :: (Monad m, Show a) => Size -> Seed -> Gen m a -> Tree m String
renderNodes size seed =
fmap (Maybe.maybe "<discard>" show) . runDiscardEffect . runGen size seed