module Test.QuickCheck.Property where
import Test.QuickCheck.Gen
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Text( showErr )
import Test.QuickCheck.Exception
import Test.QuickCheck.State
import Control.Concurrent
( forkIO
, threadDelay
, killThread
, newEmptyMVar
, takeMVar
, putMVar
)
import Data.IORef
import System.IO
( hFlush
, stdout
)
infixr 0 ==>
infixr 1 .&.
type Property = Gen Prop
class Testable prop where
property :: prop -> Property
instance Testable () where
property _ = property rejected
instance Testable Bool where
property = property . liftBool
instance Testable Result where
property = return . MkProp . return . return
instance Testable Prop where
property = return
instance Testable prop => Testable (Gen prop) where
property mp = do p <- mp; property p
instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where
property f = forAllShrink arbitrary shrink f
newtype Prop = MkProp{ unProp :: Rose (IO Result) }
data Rose a = MkRose a [Rose a]
join :: Rose (Rose a) -> Rose a
join (MkRose ~(MkRose x ts) tts) =
MkRose x (map join tts ++ ts)
instance Functor Rose where
fmap f ~(MkRose x rs) = MkRose (f x) [ fmap f r | r <- rs ]
instance Monad Rose where
return x = MkRose x []
m >>= k = join (fmap k m)
protectRose :: Rose (IO Result) -> IO (Rose (IO Result))
protectRose rose = either (return . return . exception result) id `fmap` tryEvaluate (unpack rose)
where unpack (MkRose mres ts) = MkRose (protectResult mres) ts
data Callback
= PostTest (State -> Result -> IO ())
| PostFinalFailure (State -> Result -> IO ())
data Result
= MkResult
{ ok :: Maybe Bool
, expect :: Bool
, reason :: String
, interrupted :: Bool
, stamp :: [(String,Int)]
, callbacks :: [Callback]
}
result :: Result
result =
MkResult
{ ok = undefined
, expect = True
, reason = ""
, interrupted = False
, stamp = []
, callbacks = []
}
failed :: Result -> Result
failed res = res{ ok = Just False }
exception res err = failed res{ reason = "Exception: '" ++ showErr err ++ "'",
interrupted = isInterrupt err }
protectResult :: IO Result -> IO Result
protectResult m = either (exception result) id `fmap` tryEvaluateIO (fmap force m)
where force res = ok res == Just False `seq` res
succeeded :: Result
succeeded = result{ ok = Just True }
rejected :: Result
rejected = result{ ok = Nothing }
liftBool :: Bool -> Property
liftBool b = liftResult $
result
{ ok = Just b
, reason = if b then "" else "Falsifiable"
}
liftResult :: Result -> Property
liftResult r = liftIOResult (return r)
liftIOResult :: IO Result -> Property
liftIOResult m = liftRoseIOResult (return m)
liftRoseIOResult :: Rose (IO Result) -> Property
liftRoseIOResult t = return (MkProp t)
mapResult :: Testable prop => (Result -> Result) -> prop -> Property
mapResult f = mapIOResult (fmap f)
mapIOResult :: Testable prop => (IO Result -> IO Result) -> prop -> Property
mapIOResult f = mapRoseIOResult (fmap (f . protectResult))
mapRoseIOResult :: Testable prop => (Rose (IO Result) -> Rose (IO Result)) -> prop -> Property
mapRoseIOResult f = mapProp (\(MkProp t) -> MkProp (f t))
mapProp :: Testable prop => (Prop -> Prop) -> prop -> Property
mapProp f = fmap f . property
mapSize :: Testable prop => (Int -> Int) -> prop -> Property
mapSize f p = sized ((`resize` property p) . f)
shrinking :: Testable prop =>
(a -> [a])
-> a
-> (a -> prop) -> Property
shrinking shrink x pf = fmap (MkProp . join . fmap unProp) (promote (props x))
where
props x =
MkRose (property (pf x)) [ props x' | x' <- shrink x ]
noShrinking :: Testable prop => prop -> Property
noShrinking = mapRoseIOResult f
where f (MkRose mres ts) = MkRose mres []
callback :: Testable prop => Callback -> prop -> Property
callback cb = mapResult (\res -> res{ callbacks = cb : callbacks res })
whenFail :: Testable prop => IO () -> prop -> Property
whenFail m =
callback $ PostFinalFailure $ \st res ->
m
whenFail' :: Testable prop => IO () -> prop -> Property
whenFail' m =
callback $ PostTest $ \st res ->
if ok res == Just False
then m
else return ()
expectFailure :: Testable prop => prop -> Property
expectFailure = mapResult (\res -> res{ expect = False })
label :: Testable prop => String -> prop -> Property
label s = classify True s
collect :: (Show a, Testable prop) => a -> prop -> Property
collect x = label (show x)
classify :: Testable prop =>
Bool
-> String
-> prop -> Property
classify b s = cover b 0 s
cover :: Testable prop =>
Bool
-> Int
-> String
-> prop -> Property
cover b n s = mapResult $ \res ->
case b of
True -> res{ stamp = (s,n) : stamp res }
False -> res
(==>) :: Testable prop => Bool -> prop -> Property
False ==> _ = property ()
True ==> p = property p
within :: Testable prop => Int -> prop -> Property
within n = mapIOResult race
where
race ior =
do put "Race starts ..."
resV <- newEmptyMVar
let waitAndFail =
do put "Waiting ..."
threadDelay n
put "Done waiting!"
putMVar resV (failed result{reason = "Time out"})
evalProp =
do put "Evaluating Result ..."
res <- protectResult ior
put "Evaluating OK ..."
putMVar resV res
pid1 <- forkIO evalProp
pid2 <- forkIO waitAndFail
put "Blocking ..."
res <- takeMVar resV
put "Killing threads ..."
killThread pid1
killThread pid2
put ("Got Result: " ++ show (ok res))
return res
put s | True = do return ()
| otherwise = do putStrLn s
hFlush stdout
forAll :: (Show a, Testable prop)
=> Gen a -> (a -> prop) -> Property
forAll gen pf =
gen >>= \x ->
whenFail (putStrLn (show x)) $
property (pf x)
forAllShrink :: (Show a, Testable prop)
=> Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink gen shrink pf =
gen >>= \x ->
shrinking shrink x $ \x' ->
whenFail (putStrLn (show x')) $
property (pf x')
(.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property
p1 .&. p2 =
arbitrary >>= \b ->
whenFail (putStrLn (if b then "LHS" else "RHS")) $
if b then property p1 else property p2