module Ideas.Common.Utils.QuickCheck
( module Test.QuickCheck
, ArbGen, generator, generators
, arbGen, constGen, constGens, unaryGen, unaryGens
, unaryArbGen, binaryGen, binaryGens, toArbGen
, common, uncommon, rare, changeFrequency
) where
import Control.Arrow
import Control.Monad
import Data.Monoid
import Data.Ratio
import Test.QuickCheck
newtype ArbGen a = AG [(Rational, (Int, Gen ([a] -> a)))]
instance Monoid (ArbGen a) where
mempty = AG mempty
AG xs `mappend` AG ys = AG (xs `mappend` ys)
generator :: ArbGen a -> Gen a
generator (AG pairs) = sized rec
where
factor = foldr (lcm . denominator . fst) 1 pairs
rec n = frequency (map make (select pairs))
where
select
| n == 0 = filter ((==0) . fst . snd)
| otherwise = id
make (r, (a, gf)) =
let m = round (fromInteger factor*r)
xs = replicateM a $ rec $ n `div` 2
in (m, liftM2 ($) gf xs)
generators :: [ArbGen a] -> Gen a
generators = generator . mconcat
arbGen :: Arbitrary b => (b -> a) -> ArbGen a
arbGen f = newGen 0 (liftM (const . f) arbitrary)
constGen :: a -> ArbGen a
constGen = pureGen 0 . const
constGens :: [a] -> ArbGen a
constGens = mconcat . map constGen
unaryGen :: (a -> a) -> ArbGen a
unaryGen f = pureGen 1 (f . head)
unaryArbGen :: Arbitrary b => (b -> a -> a) -> ArbGen a
unaryArbGen f = newGen 1 $ liftM (\a -> f a . head) arbitrary
unaryGens :: [a -> a] -> ArbGen a
unaryGens = mconcat . map unaryGen
binaryGen :: (a -> a -> a) -> ArbGen a
binaryGen f = pureGen 2 (\xs -> f (head xs) (xs !! 1))
binaryGens :: [a -> a -> a] -> ArbGen a
binaryGens = mconcat . map binaryGen
pureGen :: Int -> ([a] -> a) -> ArbGen a
pureGen n = newGen n . return
toArbGen :: Gen a -> ArbGen a
toArbGen = newGen 0 . liftM const
newGen :: Int -> Gen ([a] -> a) -> ArbGen a
newGen n f = AG [(1, (n, f))]
common, uncommon, rare :: ArbGen a -> ArbGen a
common = changeFrequency 2
uncommon = changeFrequency (1/2)
rare = changeFrequency (1/5)
changeFrequency :: Rational -> ArbGen a -> ArbGen a
changeFrequency r (AG xs) = AG (map (first (*r)) xs)