#ifndef NO_SAFE_HASKELL
#endif
module Test.QuickCheck.Property where
import Test.QuickCheck.Gen
import Test.QuickCheck.Gen.Unsafe
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Text( showErr, isOneLine, putLine )
import Test.QuickCheck.Exception
import Test.QuickCheck.State hiding (labels)
#ifndef NO_TIMEOUT
import System.Timeout(timeout)
#endif
import Data.Maybe
import Control.Applicative
import Control.Monad
import qualified Data.Map as Map
import Data.Map(Map)
import qualified Data.Set as Set
import Data.Set(Set)
infixr 0 ==>
infixr 1 .&.
infixr 1 .&&.
infixr 1 .||.
newtype Property = MkProperty { unProperty :: Gen Prop }
class Testable prop where
property :: prop -> Property
exhaustive :: prop -> Bool
exhaustive _ = False
data Discard = Discard
instance Testable Discard where
property _ = property rejected
exhaustive _ = True
instance Testable Bool where
property = property . liftBool
exhaustive _ = True
instance Testable Result where
property = MkProperty . return . MkProp . protectResults . return
exhaustive _ = True
instance Testable Prop where
property (MkProp r) = MkProperty . return . MkProp . ioRose . return $ r
exhaustive _ = True
instance Testable prop => Testable (Gen prop) where
property mp = MkProperty $ do p <- mp; unProperty (property p)
instance Testable Property where
property = property . unProperty
morallyDubiousIOProperty :: Testable prop => IO prop -> Property
morallyDubiousIOProperty = ioProperty
ioProperty :: Testable prop => IO prop -> Property
ioProperty = MkProperty . fmap (MkProp . ioRose . fmap unProp) . promote . fmap (unProperty . property)
instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop) where
property f = forAllShrink arbitrary shrink f
protect :: (AnException -> a) -> IO a -> IO a
protect f x = either f id `fmap` tryEvaluateIO x
newtype Prop = MkProp{ unProp :: Rose Result }
data Rose a = MkRose a [Rose a] | IORose (IO (Rose a))
ioRose :: IO (Rose Result) -> Rose Result
ioRose = IORose . protectRose
joinRose :: Rose (Rose a) -> Rose a
joinRose (IORose rs) = IORose (fmap joinRose rs)
joinRose (MkRose (IORose rm) rs) = IORose $ do r <- rm; return (joinRose (MkRose r rs))
joinRose (MkRose (MkRose x ts) tts) =
MkRose x (map joinRose tts ++ ts)
instance Functor Rose where
fmap f (IORose rs) = IORose (fmap (fmap f) rs)
fmap f (MkRose x rs) = MkRose (f x) [ fmap f r | r <- rs ]
instance Applicative Rose where
pure = return
(<*>) = liftM2 ($)
instance Monad Rose where
return x = MkRose x []
m >>= k = joinRose (fmap k m)
reduceRose :: Rose Result -> IO (Rose Result)
reduceRose r@(MkRose _ _) = return r
reduceRose (IORose m) = m >>= reduceRose
onRose :: (a -> [Rose a] -> Rose a) -> Rose a -> Rose a
onRose f (MkRose x rs) = f x rs
onRose f (IORose m) = IORose (fmap (onRose f) m)
protectRose :: IO (Rose Result) -> IO (Rose Result)
protectRose = protect (return . exception "Exception")
protectResults :: Rose Result -> Rose Result
protectResults = onRose $ \x rs ->
IORose $ do
y <- protectResult (return x)
return (MkRose y (map protectResults rs))
data Callback
= PostTest CallbackKind (State -> Result -> IO ())
| PostFinalFailure CallbackKind (State -> Result -> IO ())
data CallbackKind = Counterexample
| NotCounterexample
data Result
= MkResult
{ ok :: Maybe Bool
, expect :: Bool
, reason :: String
, theException :: Maybe AnException
, abort :: Bool
, labels :: Map String Int
, stamp :: Set String
, callbacks :: [Callback]
}
exception :: String -> AnException -> Result
exception msg err
| isDiscard err = rejected
| otherwise = failed{ reason = formatException msg err,
theException = Just err }
formatException :: String -> AnException -> String
formatException msg err = msg ++ ":" ++ format (show err)
where format xs | isOneLine xs = " '" ++ xs ++ "'"
| otherwise = "\n" ++ unlines [ " " ++ l | l <- lines xs ]
protectResult :: IO Result -> IO Result
protectResult = protect (exception "Exception")
succeeded, failed, rejected :: Result
(succeeded, failed, rejected) =
(result{ ok = Just True },
result{ ok = Just False },
result{ ok = Nothing })
where
result =
MkResult
{ ok = undefined
, expect = True
, reason = ""
, theException = Nothing
, abort = False
, labels = Map.empty
, stamp = Set.empty
, callbacks = []
}
liftBool :: Bool -> Result
liftBool True = succeeded
liftBool False = failed { reason = "Falsifiable" }
mapResult :: Testable prop => (Result -> Result) -> prop -> Property
mapResult f = mapRoseResult (protectResults . fmap f)
mapTotalResult :: Testable prop => (Result -> Result) -> prop -> Property
mapTotalResult f = mapRoseResult (fmap f)
mapRoseResult :: Testable prop => (Rose Result -> Rose Result) -> prop -> Property
mapRoseResult f = mapProp (\(MkProp t) -> MkProp (f t))
mapProp :: Testable prop => (Prop -> Prop) -> prop -> Property
mapProp f = MkProperty . fmap f . unProperty . property
mapSize :: Testable prop => (Int -> Int) -> prop -> Property
mapSize f p = MkProperty (sized ((`resize` unProperty (property p)) . f))
shrinking :: Testable prop =>
(a -> [a])
-> a
-> (a -> prop) -> Property
shrinking shrinker x0 pf = MkProperty (fmap (MkProp . joinRose . fmap unProp) (promote (props x0)))
where
props x =
MkRose (unProperty (property (pf x))) [ props x' | x' <- shrinker x ]
noShrinking :: Testable prop => prop -> Property
noShrinking = mapRoseResult (onRose (\res _ -> MkRose res []))
callback :: Testable prop => Callback -> prop -> Property
callback cb = mapTotalResult (\res -> res{ callbacks = cb : callbacks res })
counterexample :: Testable prop => String -> prop -> Property
counterexample s =
callback $ PostFinalFailure Counterexample $ \st _res -> do
res <- tryEvaluateIO (putLine (terminal st) s)
case res of
Left err ->
putLine (terminal st) (formatException "Exception thrown while printing test case" err)
Right () ->
return ()
printTestCase :: Testable prop => String -> prop -> Property
printTestCase = counterexample
whenFail :: Testable prop => IO () -> prop -> Property
whenFail m =
callback $ PostFinalFailure NotCounterexample $ \_st _res ->
m
whenFail' :: Testable prop => IO () -> prop -> Property
whenFail' m =
callback $ PostTest NotCounterexample $ \_st res ->
if ok res == Just False
then m
else return ()
verbose :: Testable prop => prop -> Property
verbose = mapResult (\res -> res { callbacks = newCallbacks (callbacks res) ++ callbacks res })
where newCallbacks cbs =
PostTest Counterexample (\st res -> putLine (terminal st) (status res ++ ":")):
[ PostTest Counterexample f | PostFinalFailure Counterexample f <- cbs ]
status MkResult{ok = Just True} = "Passed"
status MkResult{ok = Just False} = "Failed"
status MkResult{ok = Nothing} = "Skipped (precondition false)"
expectFailure :: Testable prop => prop -> Property
expectFailure = mapTotalResult (\res -> res{ expect = False })
once :: Testable prop => prop -> Property
once = mapTotalResult (\res -> res{ abort = True })
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 x n s =
x `seq` n `seq` s `listSeq`
mapTotalResult $
\res -> res {
labels = Map.insertWith max s n (labels res),
stamp = if x then Set.insert s (stamp res) else stamp res }
where [] `listSeq` z = z
(x:xs) `listSeq` z = x `seq` xs `listSeq` z
(==>) :: Testable prop => Bool -> prop -> Property
False ==> _ = property Discard
True ==> p = property p
within :: Testable prop => Int -> prop -> Property
within n = mapRoseResult f
where
f rose = ioRose $ do
let m `orError` x = fmap (fromMaybe (error x)) m
MkRose res roses <- timeout n (reduceRose rose) `orError`
"within: timeout exception not caught in Rose Result"
res' <- timeout n (protectResult (return res)) `orError`
"within: timeout exception not caught in Result"
return (MkRose res' (map f roses))
#ifdef NO_TIMEOUT
timeout _ = fmap Just
#endif
forAll :: (Show a, Testable prop)
=> Gen a -> (a -> prop) -> Property
forAll gen pf =
MkProperty $
gen >>= \x ->
unProperty (counterexample (show x) (pf x))
forAllShrink :: (Show a, Testable prop)
=> Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink gen shrinker pf =
MkProperty $
gen >>= \x ->
unProperty $
shrinking shrinker x $ \x' ->
counterexample (show x') (pf x')
(.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property
p1 .&. p2 =
MkProperty $
arbitrary >>= \b ->
unProperty $
counterexample (if b then "LHS" else "RHS") $
if b then property p1 else property p2
(.&&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property
p1 .&&. p2 = conjoin [property p1, property p2]
conjoin :: Testable prop => [prop] -> Property
conjoin ps =
MkProperty $
do roses <- mapM (fmap unProp . unProperty . property) ps
return (MkProp (conj id roses))
where
conj k [] =
MkRose (k succeeded) []
conj k (p : ps) = IORose $ do
rose@(MkRose result _) <- reduceRose p
case ok result of
_ | not (expect result) ->
return (return failed { reason = "expectFailure may not occur inside a conjunction" })
Just True -> return (conj (addLabels result . addCallbacks result . k) ps)
Just False -> return rose
Nothing -> do
rose2@(MkRose result2 _) <- reduceRose (conj (addCallbacks result . k) ps)
return $
case ok result2 of
Just True -> MkRose (result2 { ok = Nothing }) []
Just False -> rose2
Nothing -> rose2
addCallbacks result r =
r { callbacks = callbacks result ++ callbacks r }
addLabels result r =
r { labels = Map.unionWith max (labels result) (labels r),
stamp = Set.union (stamp result) (stamp r) }
(.||.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property
p1 .||. p2 = disjoin [property p1, property p2]
disjoin :: Testable prop => [prop] -> Property
disjoin ps =
MkProperty $
do roses <- mapM (fmap unProp . unProperty . property) ps
return (MkProp (foldr disj (MkRose failed []) roses))
where
disj :: Rose Result -> Rose Result -> Rose Result
disj p q =
do result1 <- p
case ok result1 of
_ | not (expect result1) -> return expectFailureError
Just True -> return result1
Just False -> do
result2 <- q
return $
case ok result2 of
_ | not (expect result2) -> expectFailureError
Just True -> result2
Just False ->
MkResult {
ok = Just False,
expect = True,
reason = sep (reason result1) (reason result2),
theException = theException result1 `mplus` theException result2,
abort = False,
labels = Map.empty,
stamp = Set.empty,
callbacks =
callbacks result1 ++
[PostFinalFailure Counterexample $ \st _res -> putLine (terminal st) ""] ++
callbacks result2 }
Nothing -> result2
Nothing -> do
result2 <- q
return (case ok result2 of
_ | not (expect result2) -> expectFailureError
Just True -> result2
_ -> result1)
expectFailureError = failed { reason = "expectFailure may not occur inside a disjunction" }
sep [] s = s
sep s [] = s
sep s s' = s ++ ", " ++ s'
infix 4 ===
(===) :: (Eq a, Show a) => a -> a -> Property
x === y =
counterexample (show x ++ " /= " ++ show y) (x == y)