{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
module QuickCheck.GenT where
import QuickCheck.GenT.Prelude
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
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))
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] ]
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