{-# LANGUAGE CPP #-}
#ifndef NO_ST_MONAD
{-# LANGUAGE Rank2Types #-}
#endif
module Test.QuickCheck.Gen where
import System.Random
( Random
, random
, randomR
, split
)
import Control.Monad
( ap
, replicateM
, filterM
)
import Control.Monad.Fix
( MonadFix(..) )
import Control.Applicative
( Applicative(..) )
import Test.QuickCheck.Random
import Data.List
import Data.Ord
import Data.Maybe
newtype Gen a = MkGen{
Gen a -> QCGen -> Int -> a
unGen :: QCGen -> Int -> a
}
instance Functor Gen where
fmap :: (a -> b) -> Gen a -> Gen b
fmap f :: a -> b
f (MkGen h :: QCGen -> Int -> a
h) =
(QCGen -> Int -> b) -> Gen b
forall a. (QCGen -> Int -> a) -> Gen a
MkGen (\r :: QCGen
r n :: Int
n -> a -> b
f (QCGen -> Int -> a
h QCGen
r Int
n))
instance Applicative Gen where
pure :: a -> Gen a
pure = a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return
gf :: Gen (a -> b)
gf <*> :: Gen (a -> b) -> Gen a -> Gen b
<*> gx :: Gen a
gx = Gen (a -> b)
gf Gen (a -> b) -> ((a -> b) -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \f :: a -> b
f -> (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Gen a
gx
instance Monad Gen where
return :: a -> Gen a
return x :: a
x =
(QCGen -> Int -> a) -> Gen a
forall a. (QCGen -> Int -> a) -> Gen a
MkGen (\_ _ -> a
x)
MkGen m :: QCGen -> Int -> a
m >>= :: Gen a -> (a -> Gen b) -> Gen b
>>= k :: a -> Gen b
k =
(QCGen -> Int -> b) -> Gen b
forall a. (QCGen -> Int -> a) -> Gen a
MkGen (\r :: QCGen
r n :: Int
n ->
case QCGen -> (QCGen, QCGen)
forall g. RandomGen g => g -> (g, g)
split QCGen
r of
(r1 :: QCGen
r1, r2 :: QCGen
r2) ->
let MkGen m' :: QCGen -> Int -> b
m' = a -> Gen b
k (QCGen -> Int -> a
m QCGen
r1 Int
n)
in QCGen -> Int -> b
m' QCGen
r2 Int
n
)
instance MonadFix Gen where
mfix :: (a -> Gen a) -> Gen a
mfix f :: a -> Gen a
f =
(QCGen -> Int -> a) -> Gen a
forall a. (QCGen -> Int -> a) -> Gen a
MkGen ((QCGen -> Int -> a) -> Gen a) -> (QCGen -> Int -> a) -> Gen a
forall a b. (a -> b) -> a -> b
$ \r :: QCGen
r n :: Int
n ->
let a :: a
a = Gen a -> QCGen -> Int -> a
forall a. Gen a -> QCGen -> Int -> a
unGen (a -> Gen a
f a
a) QCGen
r Int
n
in a
a
variant :: Integral n => n -> Gen a -> Gen a
variant :: n -> Gen a -> Gen a
variant k :: n
k (MkGen g :: QCGen -> Int -> a
g) = (QCGen -> Int -> a) -> Gen a
forall a. (QCGen -> Int -> a) -> Gen a
MkGen (\r :: QCGen
r n :: Int
n -> QCGen -> Int -> a
g (Integer -> QCGen -> QCGen
forall a. Splittable a => Integer -> a -> a
integerVariant (n -> Integer
forall a. Integral a => a -> Integer
toInteger n
k) (QCGen -> QCGen) -> QCGen -> QCGen
forall a b. (a -> b) -> a -> b
$! QCGen
r) Int
n)
sized :: (Int -> Gen a) -> Gen a
sized :: (Int -> Gen a) -> Gen a
sized f :: Int -> Gen a
f = (QCGen -> Int -> a) -> Gen a
forall a. (QCGen -> Int -> a) -> Gen a
MkGen (\r :: QCGen
r n :: Int
n -> let MkGen m :: QCGen -> Int -> a
m = Int -> Gen a
f Int
n in QCGen -> Int -> a
m QCGen
r Int
n)
getSize :: Gen Int
getSize :: Gen Int
getSize = (Int -> Gen Int) -> Gen Int
forall a. (Int -> Gen a) -> Gen a
sized Int -> Gen Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure
resize :: Int -> Gen a -> Gen a
resize :: Int -> Gen a -> Gen a
resize n :: Int
n _ | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = [Char] -> Gen a
forall a. HasCallStack => [Char] -> a
error "Test.QuickCheck.resize: negative size"
resize n :: Int
n (MkGen g :: QCGen -> Int -> a
g) = (QCGen -> Int -> a) -> Gen a
forall a. (QCGen -> Int -> a) -> Gen a
MkGen (\r :: QCGen
r _ -> QCGen -> Int -> a
g QCGen
r Int
n)
scale :: (Int -> Int) -> Gen a -> Gen a
scale :: (Int -> Int) -> Gen a -> Gen a
scale f :: Int -> Int
f g :: Gen a
g = (Int -> Gen a) -> Gen a
forall a. (Int -> Gen a) -> Gen a
sized (\n :: Int
n -> Int -> Gen a -> Gen a
forall a. Int -> Gen a -> Gen a
resize (Int -> Int
f Int
n) Gen a
g)
choose :: Random a => (a,a) -> Gen a
choose :: (a, a) -> Gen a
choose rng :: (a, a)
rng = (QCGen -> Int -> a) -> Gen a
forall a. (QCGen -> Int -> a) -> Gen a
MkGen (\r :: QCGen
r _ -> let (x :: a
x,_) = (a, a) -> QCGen -> (a, QCGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (a, a)
rng QCGen
r in a
x)
chooseAny :: Random a => Gen a
chooseAny :: Gen a
chooseAny = (QCGen -> Int -> a) -> Gen a
forall a. (QCGen -> Int -> a) -> Gen a
MkGen (\r :: QCGen
r _ -> let (x :: a
x,_) = QCGen -> (a, QCGen)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random QCGen
r in a
x)
generate :: Gen a -> IO a
generate :: Gen a -> IO a
generate (MkGen g :: QCGen -> Int -> a
g) =
do QCGen
r <- IO QCGen
newQCGen
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QCGen -> Int -> a
g QCGen
r 30)
sample' :: Gen a -> IO [a]
sample' :: Gen a -> IO [a]
sample' g :: Gen a
g =
Gen [a] -> IO [a]
forall a. Gen a -> IO a
generate ([Gen a] -> Gen [a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Int -> Gen a -> Gen a
forall a. Int -> Gen a -> Gen a
resize Int
n Gen a
g | Int
n <- [0,2..20] ])
sample :: Show a => Gen a -> IO ()
sample :: Gen a -> IO ()
sample g :: Gen a
g =
do [a]
cases <- Gen a -> IO [a]
forall a. Gen a -> IO [a]
sample' Gen a
g
(a -> IO ()) -> [a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> IO ()
forall a. Show a => a -> IO ()
print [a]
cases
suchThat :: Gen a -> (a -> Bool) -> Gen a
gen :: Gen a
gen suchThat :: Gen a -> (a -> Bool) -> Gen a
`suchThat` p :: a -> Bool
p =
do Maybe a
mx <- Gen a
gen Gen a -> (a -> Bool) -> Gen (Maybe a)
forall a. Gen a -> (a -> Bool) -> Gen (Maybe a)
`suchThatMaybe` a -> Bool
p
case Maybe a
mx of
Just x :: a
x -> a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
Nothing -> (Int -> Gen a) -> Gen a
forall a. (Int -> Gen a) -> Gen a
sized (\n :: Int
n -> Int -> Gen a -> Gen a
forall a. Int -> Gen a -> Gen a
resize (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) (Gen a
gen Gen a -> (a -> Bool) -> Gen a
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` a -> Bool
p))
suchThatMap :: Gen a -> (a -> Maybe b) -> Gen b
gen :: Gen a
gen suchThatMap :: Gen a -> (a -> Maybe b) -> Gen b
`suchThatMap` f :: a -> Maybe b
f =
(Maybe b -> b) -> Gen (Maybe b) -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe b -> b
forall a. HasCallStack => Maybe a -> a
fromJust (Gen (Maybe b) -> Gen b) -> Gen (Maybe b) -> Gen b
forall a b. (a -> b) -> a -> b
$ (a -> Maybe b) -> Gen a -> Gen (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe b
f Gen a
gen Gen (Maybe b) -> (Maybe b -> Bool) -> Gen (Maybe b)
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` Maybe b -> Bool
forall a. Maybe a -> Bool
isJust
suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a)
gen :: Gen a
gen suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a)
`suchThatMaybe` p :: a -> Bool
p = (Int -> Gen (Maybe a)) -> Gen (Maybe a)
forall a. (Int -> Gen a) -> Gen a
sized (\n :: Int
n -> Int -> Int -> Gen (Maybe a)
try Int
n (2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n))
where
try :: Int -> Int -> Gen (Maybe a)
try m :: Int
m n :: Int
n
| Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n = Maybe a -> Gen (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
| Bool
otherwise = do
a
x <- Int -> Gen a -> Gen a
forall a. Int -> Gen a -> Gen a
resize Int
m Gen a
gen
if a -> Bool
p a
x then Maybe a -> Gen (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x) else Int -> Int -> Gen (Maybe a)
try (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Int
n
oneof :: [Gen a] -> Gen a
oneof :: [Gen a] -> Gen a
oneof [] = [Char] -> Gen a
forall a. HasCallStack => [Char] -> a
error "QuickCheck.oneof used with empty list"
oneof gs :: [Gen a]
gs = (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (0,[Gen a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Gen a]
gs Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Gen Int -> (Int -> Gen a) -> Gen a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Gen a]
gs [Gen a] -> Int -> Gen a
forall a. [a] -> Int -> a
!!)
frequency :: [(Int, Gen a)] -> Gen a
frequency :: [(Int, Gen a)] -> Gen a
frequency [] = [Char] -> Gen a
forall a. HasCallStack => [Char] -> a
error "QuickCheck.frequency used with empty list"
frequency xs :: [(Int, Gen a)]
xs
| (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (((Int, Gen a) -> Int) -> [(Int, Gen a)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Gen a) -> Int
forall a b. (a, b) -> a
fst [(Int, Gen a)]
xs) =
[Char] -> Gen a
forall a. HasCallStack => [Char] -> a
error "QuickCheck.frequency: negative weight"
| (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0) (((Int, Gen a) -> Int) -> [(Int, Gen a)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Gen a) -> Int
forall a b. (a, b) -> a
fst [(Int, Gen a)]
xs) =
[Char] -> Gen a
forall a. HasCallStack => [Char] -> a
error "QuickCheck.frequency: all weights were zero"
frequency xs0 :: [(Int, Gen a)]
xs0 = (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (1, Int
tot) Gen Int -> (Int -> Gen a) -> Gen a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int -> [(Int, Gen a)] -> Gen a
forall t p. (Ord t, Num t) => t -> [(t, p)] -> p
`pick` [(Int, Gen a)]
xs0)
where
tot :: Int
tot = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((Int, Gen a) -> Int) -> [(Int, Gen a)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Gen a) -> Int
forall a b. (a, b) -> a
fst [(Int, Gen a)]
xs0)
pick :: t -> [(t, p)] -> p
pick n :: t
n ((k :: t
k,x :: p
x):xs :: [(t, p)]
xs)
| t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
k = p
x
| Bool
otherwise = t -> [(t, p)] -> p
pick (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
k) [(t, p)]
xs
pick _ _ = [Char] -> p
forall a. HasCallStack => [Char] -> a
error "QuickCheck.pick used with empty list"
elements :: [a] -> Gen a
elements :: [a] -> Gen a
elements [] = [Char] -> Gen a
forall a. HasCallStack => [Char] -> a
error "QuickCheck.elements used with empty list"
elements xs :: [a]
xs = ([a]
xs [a] -> Int -> a
forall a. [a] -> Int -> a
!!) (Int -> a) -> Gen Int -> Gen a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (0, [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
sublistOf :: [a] -> Gen [a]
sublistOf :: [a] -> Gen [a]
sublistOf xs :: [a]
xs = (a -> Gen Bool) -> [a] -> Gen [a]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\_ -> (Bool, Bool) -> Gen Bool
forall a. Random a => (a, a) -> Gen a
choose (Bool
False, Bool
True)) [a]
xs
shuffle :: [a] -> Gen [a]
shuffle :: [a] -> Gen [a]
shuffle xs :: [a]
xs = do
[Int]
ns <- Int -> Gen Int -> Gen [Int]
forall a. Int -> Gen a -> Gen [a]
vectorOf ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
forall a. Bounded a => a
minBound :: Int, Int
forall a. Bounded a => a
maxBound))
[a] -> Gen [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (((Int, a) -> a) -> [(Int, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Int, a) -> a
forall a b. (a, b) -> b
snd (((Int, a) -> (Int, a) -> Ordering) -> [(Int, a)] -> [(Int, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, a) -> Int) -> (Int, a) -> (Int, a) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, a) -> Int
forall a b. (a, b) -> a
fst) ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
ns [a]
xs)))
growingElements :: [a] -> Gen a
growingElements :: [a] -> Gen a
growingElements [] = [Char] -> Gen a
forall a. HasCallStack => [Char] -> a
error "QuickCheck.growingElements used with empty list"
growingElements xs :: [a]
xs = (Int -> Gen a) -> Gen a
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen a) -> Gen a) -> (Int -> Gen a) -> Gen a
forall a b. (a -> b) -> a -> b
$ \n :: Int
n -> [a] -> Gen a
forall a. [a] -> Gen a
elements (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (1 Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int -> Int
size Int
n) [a]
xs)
where
k :: Int
k = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
mx :: Int
mx = 100
log' :: Int -> Int
log' = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> (Int -> Double) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
forall a. Floating a => a -> a
log (Double -> Double) -> (Int -> Double) -> Int -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
toDouble
size :: Int -> Int
size n :: Int
n = (Int -> Int
log' Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
k Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int -> Int
log' Int
mx
toDouble :: Int -> Double
toDouble = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Double
listOf :: Gen a -> Gen [a]
listOf :: Gen a -> Gen [a]
listOf gen :: Gen a
gen = (Int -> Gen [a]) -> Gen [a]
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen [a]) -> Gen [a]) -> (Int -> Gen [a]) -> Gen [a]
forall a b. (a -> b) -> a -> b
$ \n :: Int
n ->
do Int
k <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (0,Int
n)
Int -> Gen a -> Gen [a]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
k Gen a
gen
listOf1 :: Gen a -> Gen [a]
listOf1 :: Gen a -> Gen [a]
listOf1 gen :: Gen a
gen = (Int -> Gen [a]) -> Gen [a]
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen [a]) -> Gen [a]) -> (Int -> Gen [a]) -> Gen [a]
forall a b. (a -> b) -> a -> b
$ \n :: Int
n ->
do Int
k <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (1,1 Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int
n)
Int -> Gen a -> Gen [a]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
k Gen a
gen
vectorOf :: Int -> Gen a -> Gen [a]
vectorOf :: Int -> Gen a -> Gen [a]
vectorOf = Int -> Gen a -> Gen [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM
infiniteListOf :: Gen a -> Gen [a]
infiniteListOf :: Gen a -> Gen [a]
infiniteListOf gen :: Gen a
gen = [Gen a] -> Gen [a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Gen a -> [Gen a]
forall a. a -> [a]
repeat Gen a
gen)