module Quickpull.Laws where
import Control.Applicative
import Data.Monoid
import Quickpull.Types
import Test.QuickCheck
monad
:: (Eq b, Show b, Monad m)
=> Gen (m Int)
-> Gen (Int -> m Int)
-> Gen (m Int -> b)
-> TestTree
monad genK genF genU = group "monad laws"
[ test "left identity" monadLeftIdentity
, test "right identity" monadRightIdentity
, test "associativity" monadAssociativity
]
where
monadLeftIdentity = do
i <- arbitrary
f <- genF
u <- genU
return $ (u (return i >>= f)) === u (f i)
monadRightIdentity = do
m <- genK
u <- genU
return $ (u (m >>= return)) === u m
monadAssociativity = do
m <- genK
f <- genF
g <- genF
u <- genU
return $ (u ((m >>= f) >>= g)) === (u (m >>= (\x -> f x >>= g)))
functor
:: (Eq b, Show b, Functor f)
=> Gen (f Int)
-> Gen (f Int -> b)
-> TestTree
functor genK genU = group "functor laws"
[ test "identity" tIdentity
, test "composition" tComposition
]
where
tIdentity = do
k <- genK
u <- genU
return $ (u (fmap id k)) === (u (id k))
tComposition = do
k <- genK
u <- genU
f <- arbitrary
let _types = f :: Int -> Int
g <- arbitrary
return $ (u (fmap (f . g) k)) === (u ((fmap f . fmap g) k))
applicative
:: (Eq b, Show b, Applicative f)
=> Gen (f Int)
-> Gen (f (Int -> Int))
-> Gen (f Int -> b)
-> TestTree
applicative gK gF gU = group "applicative laws"
[ test "identity" tIdentity
, test "composition" tComposition
, test "homomorphism" tHomomorphism
, test "interchange" tInterchange
]
where
tIdentity = do
u <- gU
v <- gK
return $ (u (pure id <*> v)) === (u v)
tComposition = do
u <- gF
v <- gF
w <- gK
r <- gU
return $ (r (pure (.) <*> u <*> v <*> w)) ===
(r (u <*> (v <*> w)))
tHomomorphism = do
f <- arbitrary
let _types = f :: Int -> Int
x <- arbitrary
u <- gU
return $ (u (pure f <*> pure x)) ===
(u (pure (f x)))
tInterchange = do
r <- gU
u <- gF
y <- arbitrary
return $ (r (u <*> pure y)) ===
(r (pure ($ y) <*> u))
monoid
:: (Eq b, Show b, Monoid a)
=> Gen a
-> Gen (a -> b)
-> TestTree
monoid gV gU = group "monoid laws"
[ test "left identity" tLeft
, test "right identity" tRight
, test "associativity" tAssociative
, test "mconcat = foldr" tFoldr
]
where
tLeft = do
x <- gV
u <- gU
return $ (u (mappend mempty x)) === (u x)
tRight = do
x <- gV
u <- gU
return $ (u (mappend x mempty)) === (u x)
tAssociative = do
x <- gV
y <- gV
z <- gV
u <- gU
return $ (u (mappend x (mappend y z))) ===
(u (mappend (mappend x y) z))
tFoldr = do
ls <- listOf gV
u <- gU
return $ (u (mconcat ls)) ===
(u (foldr mappend mempty ls))
associative
:: (Eq b, Show b)
=> Gen (a -> a -> a)
-> Gen (a -> b)
-> Gen a
-> Gen Property
associative gF gU gV = do
f <- gF
u <- gU
a <- gV
b <- gV
c <- gV
return $ (u (a `f` (b `f` c))) ===
(u ((a `f` b) `f` c))
commutative
:: (Eq b, Show b)
=> Gen (a -> a -> a)
-> Gen (a -> b)
-> Gen a
-> Gen Property
commutative gF gU gV = do
f <- gF
u <- gU
a <- gV
b <- gV
return $ (u (a `f` b)) === (u (b `f` a))
leftIdentity
:: (Eq b, Show b)
=> Gen (a -> a -> a)
-> Gen (a -> b)
-> Gen a
-> Gen a
-> Gen Property
leftIdentity gF gU gZ gR = do
f <- gF
u <- gU
z <- gZ
r <- gR
return $ u (z `f` r) === u r
rightIdentity
:: (Eq b, Show b)
=> Gen (a -> a -> a)
-> Gen (a -> b)
-> Gen a
-> Gen a
-> Gen Property
rightIdentity gF gU gZ gL = do
f <- gF
u <- gU
z <- gZ
l <- gL
return $ u (l `f` z) === u l