{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
module QuickCheck.GenT
( GenT
, runGenT
, MonadGen(..)
, arbitrary'
, oneof
, frequency
, elements
, growingElements
, getSize
, scale
, suchThat
, suchThatMap
, suchThatMaybe
, applyArbitrary2
, applyArbitrary3
, applyArbitrary4
, listOf
, listOf1
, vectorOf
, vector
, infiniteListOf
, infiniteList
, shuffle
, sublistOf
, orderedList
, Arbitrary(..)
, QC.Gen
, oneofMay
, elementsMay
, growingElementsMay
) where
import QuickCheck.GenT.Prelude
import Test.QuickCheck (Arbitrary(..))
import qualified Test.QuickCheck.Arbitrary as QC
import qualified Test.QuickCheck.Gen as QC
import qualified Test.QuickCheck.Random as QC
import qualified System.Random as Random
newtype GenT m a = GenT { unGenT :: QC.QCGen -> Int -> m a }
instance (Functor m) => Functor (GenT m) where
fmap f m = GenT $ \r n -> fmap f $ unGenT m r n
instance (Monad m) => Monad (GenT m) where
return a = GenT (\_ _ -> return a)
m >>= k = GenT $ \r n -> do
let (r1, r2) = Random.split r
a <- unGenT m r1 n
unGenT (k a) r2 n
#if MIN_VERSION_base(4,13,0)
instance (MonadFail m) => MonadFail (GenT m) where
#endif
fail msg = GenT (\_ _ -> fail msg)
instance (Functor m, Monad m) => Applicative (GenT m) where
pure = return
(<*>) = ap
instance MonadTrans GenT where
lift m = GenT (\_ _ -> m)
instance (MonadIO m) => MonadIO (GenT m) where
liftIO = lift . liftIO
runGenT :: GenT m a -> QC.Gen (m a)
runGenT (GenT run) = QC.MkGen run
class (Applicative g, Monad g) => MonadGen g where
liftGen :: QC.Gen a -> g a
variant :: Integral n => n -> g a -> g a
sized :: (Int -> g a) -> g a
resize :: Int -> g a -> g a
choose :: Random.Random a => (a, a) -> g a
instance (Applicative m, Monad m) => MonadGen (GenT m) where
liftGen gen = GenT $ \r n -> return $ QC.unGen gen r n
choose rng = GenT $ \r _ -> return $ fst $ Random.randomR rng r
variant k (GenT g) = GenT $ \r n -> g (var k r) n
sized f = GenT $ \r n -> let GenT g = f n in g r n
resize n (GenT g) = GenT $ \r _ -> g r n
instance MonadGen QC.Gen where
liftGen = id
variant k (QC.MkGen g) = QC.MkGen $ \r n -> g (var k r) n
sized f = QC.MkGen $ \r n -> let QC.MkGen g = f n in g r n
resize n (QC.MkGen g) = QC.MkGen $ \r _ -> g r n
choose range = QC.MkGen $ \r _ -> fst $ Random.randomR range r
var :: Integral n => n -> QC.QCGen -> QC.QCGen
var k =
(if k == k' then id else var k') . (if even k then fst else snd) . Random.split
where k' = k `div` 2
arbitrary' :: (Arbitrary a, MonadGen m) => m a
arbitrary' = liftGen arbitrary
getSize :: MonadGen m => m Int
getSize = liftGen getSize
scale :: MonadGen m => (Int -> Int) -> m a -> m a
scale f g = sized (\n -> resize (f n) g)
applyArbitrary2 :: MonadGen m => (Arbitrary a, Arbitrary b) => (a -> b -> r) -> m r
applyArbitrary2 = liftGen . QC.applyArbitrary2
applyArbitrary3 :: MonadGen m => (Arbitrary a, Arbitrary b, Arbitrary c) => (a -> b -> c -> r) -> m r
applyArbitrary3 = liftGen . QC.applyArbitrary3
applyArbitrary4 :: MonadGen m => (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) => (a -> b -> c -> d -> r) -> m r
applyArbitrary4 = liftGen . QC.applyArbitrary4
infiniteListOf :: MonadGen m => m a -> m [a]
infiniteListOf = sequence . repeat
infiniteList :: (Arbitrary a, MonadGen m) => m [a]
infiniteList = infiniteListOf arbitrary'
shuffle :: MonadGen m => [a] -> m [a]
shuffle = liftGen . QC.shuffle
sublistOf :: MonadGen m => [a] -> m [a]
sublistOf = liftGen . QC.sublistOf
orderedList :: (Ord a, Arbitrary a, MonadGen m) => m [a]
orderedList = liftGen QC.orderedList
suchThat :: MonadGen m => m a -> (a -> Bool) -> m a
gen `suchThat` p =
do mx <- gen `suchThatMaybe` p
case mx of
Just x -> return x
Nothing -> sized (\n -> resize (n+1) (gen `suchThat` p))
suchThatMap :: MonadGen m => m a -> (a -> Maybe b) -> m b
gen `suchThatMap` f =
fmap fromJust $ fmap f gen `suchThat` isJust
suchThatMaybe :: MonadGen m => m a -> (a -> Bool) -> m (Maybe a)
gen `suchThatMaybe` p = sized (try 0 . max 1)
where
try _ 0 = return Nothing
try k n = do x <- resize (2*k+n) gen
if p x then return (Just x) else try (k+1) (n-1)
listOf :: MonadGen m => m a -> m [a]
listOf gen = sized $ \n ->
do k <- choose (0,n)
vectorOf k gen
listOf1 :: MonadGen m => m a -> m [a]
listOf1 gen = sized $ \n ->
do k <- choose (1,1 `max` n)
vectorOf k gen
vectorOf :: MonadGen m => Int -> m a -> m [a]
vectorOf k gen = sequence [ gen | _ <- [1..k] ]
vector :: (Arbitrary a, MonadGen m) => Int -> m [a]
vector n = vectorOf n arbitrary'
oneof :: MonadGen m => [m a] -> m a
oneof =
fmap (fromMaybe (error "QuickCheck.GenT.oneof used with empty list")) .
oneofMay
frequency :: MonadGen m => [(Int, m a)] -> m a
frequency [] = error "QuickCheck.GenT.frequency used with empty list"
frequency xs0 = choose (1, tot) >>= (`pick` xs0)
where
tot = sum (map fst xs0)
pick n ((k,x):xs)
| n <= k = x
| otherwise = pick (n-k) xs
pick _ _ = error "QuickCheck.GenT.pick used with empty list"
elements :: MonadGen m => [a] -> m a
elements =
fmap (fromMaybe (error "QuickCheck.GenT.elements used with empty list")) .
elementsMay
growingElements :: MonadGen m => [a] -> m a
growingElements =
fmap (fromMaybe (error "QuickCheck.GenT.growingElements used with empty list")) .
growingElementsMay
oneofMay :: MonadGen m => [m a] -> m (Maybe a)
oneofMay = \case
[] -> return Nothing
l -> fmap Just $ choose (0, length l - 1) >>= (l !!)
elementsMay :: MonadGen m => [a] -> m (Maybe a)
elementsMay = \case
[] -> return Nothing
l -> Just . (l !!) <$> choose (0, length l - 1)
growingElementsMay :: MonadGen m => [a] -> m (Maybe a)
growingElementsMay = \case
[] -> return Nothing
xs -> fmap Just $ sized $ \n -> elements (take (1 `max` size n) xs)
where
k = length xs
mx = 100
log' = round . log . fromIntegral
size n = (log' n + 1) * k `div` log' mx