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)
data Callback
= PostTest (State -> Result -> IO ())
| PostFinalFailure (State -> Result -> IO ())
data Result
= MkResult
{ ok :: Maybe Bool
, expect :: Bool
, reason :: String
, stamp :: [(String,Int)]
, callbacks :: [Callback]
}
result :: Result
result =
MkResult
{ ok = undefined
, expect = True
, reason = ""
, stamp = []
, callbacks = []
}
failed :: Result
failed = result{ ok = Just False }
exception :: Show a => a -> Result
exception err = failed{ reason = "Exception: '" ++ showErr err ++ "'" }
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 (wrap m))
where
wrap m = either exception id `fmap` tryEvaluateIO m
liftRoseIOResult :: Rose (IO Result) -> Property
liftRoseIOResult t = return (MkProp t)
mapResult :: Testable prop => (Result -> Result) -> prop -> Property
mapResult f = mapIOResult (>>= wrap f)
where
wrap f res =
do mres <- tryEvaluate res
return $ f $ case mres of
Left err -> exception err
Right res -> res
mapIOResult :: Testable prop => (IO Result -> IO Result) -> prop -> Property
mapIOResult f = mapRoseIOResult (fmap (f . wrap))
where
wrap iores =
do miores <- tryEvaluate iores
case miores of
Left err -> return (exception err)
Right iores -> iores
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 ]
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 = mapIOResult $ \ior ->
do eeb <- tryEvaluate b
res <- ior
return $
case eeb of
Left err -> res{ ok = Just False
, reason = "Exception: '" ++ showErr err ++ "'"
}
Right True -> res{ stamp = (s,n) : stamp res }
Right 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
pidV <- newEmptyMVar
partResV <- newIORef failed
let waitAndFail =
do put "Waiting ..."
threadDelay n
put "Done waiting!"
partRes <- readIORef partResV
putMVar resV $
partRes
{ ok = Just False
, reason = "Time out"
}
evalProp =
do put "Evaluating Result ..."
res <- ior
writeIORef partResV res
put "Evaluating OK ..."
mok <- tryEvaluate (ok res == Just False)
case mok of
Left err -> do put "Exception!"
putMVar resV $
res
{ ok = Just False
, reason = "Exception: '" ++ showErr err ++ "'"
}
Right _ -> do put "Done!"
putMVar resV res
pid1 <- forkIO $ do pid2 <- takeMVar pidV
evalProp
killThread pid2
pid2 <- forkIO $ do waitAndFail
killThread pid1
putMVar pidV pid2
put "Blocking ..."
res <- takeMVar resV
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