module Test.QuickCheck.Checkers
(
Test, TestBatch, unbatch, checkBatch, quickBatch, verboseBatch
, Unop, Binop, genR, inverseL, inverse
, FracT, NumT, OrdT, T
, EqProp(..), eq
, BinRel, reflexive, transitive, symmetric, antiSymmetric
, leftId, rightId, bothId, isAssoc, isCommut, commutes
, MonoidD, monoidD, endoMonoidD, homomorphism
, idempotent, idempotent2, idemElem
, Model(..)
, meq, meq1, meq2, meq3, meq4, meq5
, eqModels
, Model1(..)
, arbs, gens
, (.&.)
, arbitrarySatisfying
) where
import Data.Monoid
import Data.Function (on)
import Control.Applicative
import Control.Arrow ((***),first)
import Data.List (foldl')
import System.Random
import Test.QuickCheck
import Test.QuickCheck.Gen (Gen (..))
import Test.QuickCheck.Utils
type Test = (String,Property)
type TestBatch = (String,[Test])
unbatch :: TestBatch -> [Test]
unbatch (batchName,props) = map (first ((batchName ++ ": ")++)) props
checkBatch :: Args -> TestBatch -> IO ()
checkBatch args (name,tests) =
do putStrLn $ "\n" ++ name ++ ":"
mapM_ pr tests
where
pr (s,p) = do putStr (padTo (width + 4) (" "++s ++ ":"))
catch (quickCheckWith args p) print
width = foldl' max 0 (map (length.fst) tests)
padTo :: Int -> String -> String
padTo n = take n . (++ repeat ' ')
quickBatch :: TestBatch -> IO ()
quickBatch = checkBatch quick'
verboseBatch :: TestBatch -> IO ()
verboseBatch = checkBatch verbose'
quick', verbose' :: Args
quick' = stdArgs { maxSuccess = 500 }
verbose' = quick'
type Unop a = a -> a
type Binop a = a -> a -> a
type FracT = Float
type NumT = Int
type OrdT = Int
type T = Char
genR :: Random a => (a, a) -> Gen a
genR (lo,hi) = fmap (fst . randomR (lo,hi)) rand
inverseL :: (EqProp b, Arbitrary b, Show b) =>
(a -> b) -> (b -> a) -> Property
f `inverseL` g = f . g =-= id
inverse :: ( EqProp a, Arbitrary a, Show a
, EqProp b, Arbitrary b, Show b ) =>
(a -> b) -> (b -> a) -> Property
f `inverse` g = f `inverseL` g .&. g `inverseL` f
infix 4 =-=
class EqProp a where (=-=) :: a -> a -> Property
eq :: Eq a => a -> a -> Property
a `eq` a' = property (a == a')
instance EqProp Bool where (=-=) = eq
instance EqProp Char where (=-=) = eq
instance EqProp Int where (=-=) = eq
instance EqProp Float where (=-=) = eq
instance EqProp Double where (=-=) = eq
instance EqProp a => EqProp [a] where
[] =-= [] = property True
x:xs =-= y:ys = x =-= y .&. xs =-= ys
_ =-= _ = property False
instance EqProp a => EqProp (Maybe a) where
Nothing =-= Nothing = property True
Just x =-= Just y = x =-= y
_ =-= _ = property False
instance (EqProp a, EqProp b) => EqProp (a,b) where
(a,b) =-= (a',b') = a =-= a' .&. b =-= b'
instance (EqProp a, EqProp b, EqProp c) => EqProp (a,b,c) where
(a,b,c) =-=(a',b',c') = a =-= a' .&. b =-= b' .&. c =-= c'
instance (EqProp a, EqProp b, EqProp c, EqProp d) => EqProp (a,b,c,d) where
(a,b,c,d) =-=(a',b',c',d') = a =-= a' .&. b =-= b' .&. c =-= c' .&. d =-= d'
instance (EqProp a, EqProp b) => EqProp (Either a b) where
(Left x) =-= (Left x') = x =-= x'
(Right x) =-= (Right x') = x =-= x'
_ =-= _ = property False
instance (Show a, Arbitrary a, EqProp b) => EqProp (a -> b) where
f =-= f' = property (liftA2 (=-=) f f')
eqModels :: (Model a b, EqProp b) => a -> a -> Property
eqModels = (=-=) `on` model
type BinRel a = a -> a -> Bool
reflexive :: (Arbitrary a, Show a) =>
BinRel a -> Property
reflexive rel = property $ \ a -> a `rel` a
transitive :: (Arbitrary a, Show a) =>
BinRel a -> (a -> Gen a) -> Property
transitive rel gen =
property $ \ a ->
forAll (gen a) $ \ b ->
forAll (gen b) $ \ c ->
(a `rel` b) && (b `rel` c) ==> (a `rel` c)
symmetric :: (Arbitrary a, Show a) =>
BinRel a -> (a -> Gen a) -> Property
symmetric rel gen =
property $ \ a ->
forAll (gen a) $ \ b ->
(a `rel` b) ==> (b `rel` a)
antiSymmetric :: (Arbitrary a, Show a, Eq a) =>
BinRel a -> (a -> Gen a) -> Property
antiSymmetric rel gen =
property $ \ a ->
forAll (gen a) $ \ b ->
(a `rel` b) && (b `rel` a) ==> a == b
leftId :: (Show a, Arbitrary a, EqProp a) => (i -> a -> a) -> i -> Property
leftId op i = (i `op`) =-= id
rightId :: (Show a, Arbitrary a, EqProp a) => (a -> i -> a) -> i -> Property
rightId op i = (`op` i) =-= id
bothId :: (Show a, Arbitrary a, EqProp a) => (a -> a -> a) -> a -> Property
bothId = (liftA2.liftA2) (.&.) leftId rightId
isAssoc :: (EqProp a, Show a, Arbitrary a) => (a -> a -> a) -> Property
isAssoc = isAssociativeBy (=-=) arbitrary
commutes :: EqProp z => (a -> a -> z) -> a -> a -> Property
commutes (#) a b = a # b =-= b # a
isCommut :: (EqProp a, Show a, Arbitrary a) => (a -> a -> a) -> Property
isCommut = isCommutableBy (=-=) arbitrary
data MonoidD a = MonoidD a (a -> a -> a)
monoidD :: Monoid a => MonoidD a
monoidD = MonoidD mempty mappend
endoMonoidD :: MonoidD (a -> a)
endoMonoidD = MonoidD id (.)
homomorphism :: (EqProp b, Show a, Arbitrary a) =>
MonoidD a -> MonoidD b -> (a -> b) -> [(String,Property)]
homomorphism (MonoidD ida opa) (MonoidD idb opb) q =
[ ("identity" , q ida =-= idb)
, ("binop", property $ \ u v -> q (u `opa` v) =-= q u `opb` q v)
]
idempotent :: (Show a, Arbitrary a, EqProp a) =>
(a -> a) -> Property
idempotent f = idemElem (.) f
idempotent2 :: (Show a, Arbitrary a, EqProp a) =>
(a -> a -> a) -> Property
idempotent2 = property . idemElem
idemElem :: EqProp a => (a -> a -> a) -> a -> Property
idemElem op x = x `op` x =-= x
class Model a b | a -> b where
model :: a -> b
meq :: (Model a b, EqProp b) => a -> b -> Property
meq1 :: (Model a b, Model a1 b1, EqProp b) =>
(a1 -> a) -> (b1 -> b) -> a1 -> Property
meq2 :: (Model a b, Model a1 b1, Model a2 b2, EqProp b) =>
(a1 -> a2 -> a) -> (b1 -> b2 -> b) -> a1 -> a2 -> Property
meq3 :: (Model a b, Model a1 b1, Model a2 b2, Model a3 b3, EqProp b) =>
(a1 -> a2 -> a3 -> a)
-> (b1 -> b2 -> b3 -> b)
-> a1 -> a2 -> a3 -> Property
meq4 :: ( Model a b, Model a1 b1, Model a2 b2
, Model a3 b3, Model a4 b4, EqProp b) =>
(a1 -> a2 -> a3 -> a4 -> a)
-> (b1 -> b2 -> b3 -> b4 -> b)
-> a1 -> a2 -> a3 -> a4 -> Property
meq5 :: ( Model a b, Model a1 b1, Model a2 b2, Model a3 b3
, Model a4 b4, Model a5 b5, EqProp b) =>
(a1 -> a2 -> a3 -> a4 -> a5 -> a)
-> (b1 -> b2 -> b3 -> b4 -> b5 -> b)
-> a1 -> a2 -> a3 -> a4 -> a5 -> Property
meq a b =
model a =-= b
meq1 f g = \a ->
model (f a) =-= g (model a)
meq2 f g = \a b ->
model (f a b) =-= g (model a) (model b)
meq3 f g = \a b c ->
model (f a b c) =-= g (model a) (model b) (model c)
meq4 f g = \a b c d ->
model (f a b c d) =-= g (model a) (model b) (model c) (model d)
meq5 f g = \a b c d e ->
model (f a b c d e) =-= g (model a) (model b) (model c) (model d) (model e)
instance Model Bool Bool where model = id
instance Model Char Char where model = id
instance Model Int Int where model = id
instance Model Float Float where model = id
instance Model Double Double where model = id
instance Model String String where model = id
instance (Model a b, Model a' b') => Model (a,a') (b,b') where
model = model *** model
class Model1 f g | f -> g where
model1 :: forall a. f a -> g a
arbitrarySatisfying :: Arbitrary a => (a -> Bool) -> Gen a
arbitrarySatisfying = (arbitrary `suchThat`)
arbs :: Arbitrary a => Int -> IO [a]
arbs n = fmap (\ rnd -> generate n rnd (vector n)) newStdGen
gens :: Int -> Gen a -> IO [a]
gens n gen =
fmap (\ rnd -> generate 1000 rnd (sequence (replicate n gen))) newStdGen
instance Testable a => Testable [a] where
property [] = property True
property props = property $ \n -> props !! (n `mod` len)
where len = length props
instance (Testable a, Testable b) => Testable (a,b) where
property = uncurry (.&.)
rand :: Gen StdGen
rand = MkGen (\r _ -> r)
generate :: Int -> StdGen -> Gen a -> a
generate n rnd (MkGen m) = m rnd' size
where
(size, rnd') = randomR (0, n) rnd