{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
module Test.Framework.QuickCheckWrapper (
module Test.QuickCheck,
defaultArgs, getCurrentArgs, setDefaultArgs,
withQCArgs, WithQCArgs, setReplayFromString,
QCAssertion,
qcPending,
#if !MIN_VERSION_QuickCheck(2,7,0)
ioProperty,
#endif
assertionAsProperty,
qcAssertion
) where
#if !MIN_VERSION_base(4,6,0)
import Prelude hiding ( catch )
#endif
import Control.Exception ( SomeException, Exception, Handler(..),
throw, catch, catches, evaluate )
import Data.Typeable (Typeable)
import Data.Char
import qualified Data.List as List
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef
#if MIN_VERSION_QuickCheck(2,7,0)
import System.Random
#endif
import Test.QuickCheck
#if !MIN_VERSION_QuickCheck(2,7,0)
import Test.QuickCheck.Property (morallyDubiousIOProperty)
#endif
import Test.Framework.TestInterface
import Test.Framework.Utils
_DEBUG_ :: Bool
_DEBUG_ = False
debug :: String -> IO ()
debug s = if _DEBUG_ then putStrLn ("[DEBUG] " ++ s) else return ()
data QCState = QCState { qc_args :: !Args }
qcState :: IORef QCState
qcState = unsafePerformIO (newIORef (QCState defaultArgs))
{-# NOINLINE qcState #-}
defaultArgs :: Args
defaultArgs = stdArgs { chatty = False }
setDefaultArgs :: Args -> IO ()
setDefaultArgs args =
do force <- atomicModifyIORef qcState $ \state ->
let newState = state { qc_args = args }
in (newState, newState)
force `seq` return ()
getCurrentArgs :: IO Args
getCurrentArgs =
do state <- readIORef qcState
return (qc_args state)
data QCPendingException = QCPendingException String
deriving (Show,Read,Eq,Typeable)
instance Exception QCPendingException
quickCheckTestError :: Maybe String -> Assertion
quickCheckTestError m = failHTF $ mkFullTestResult Error m
quickCheckTestFail :: Maybe String -> Assertion
quickCheckTestFail m = failHTF $ mkFullTestResult Fail m
quickCheckTestPending :: String -> Assertion
quickCheckTestPending m = failHTF $ mkFullTestResult Pending (Just m)
quickCheckTestPass :: String -> Assertion
quickCheckTestPass m = failHTF $ mkFullTestResult Pass (Just m)
qcAssertion :: (QCAssertion t) => t -> Assertion
qcAssertion qc =
do origArgs <- getCurrentArgs
eitherArgs <-
(let a = (argsModifier qc) origArgs
in do _ <- evaluate (length (show a))
return (Right a))
`catch`
(\e -> return $ Left (show (e :: SomeException)))
case eitherArgs of
Left err -> quickCheckTestError
(Just ("Cannot evaluate custom arguments: "
++ err))
Right args ->
do res <- do anyTestable <- evaluate (testable qc)
x <- case anyTestable of
AnyTestable t' -> quickCheckWithResult args t'
return (Right x)
`catches`
[Handler $ \(QCPendingException msg) -> return $ Left msg]
debug ("QuickCheck result: " ++ show res)
case res of
Left err ->
quickCheckTestPending err
Right (Success { output=msg }) ->
quickCheckTestPass (adjustOutput msg)
Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=reason }) ->
case () of
_| pendingPrefix `List.isPrefixOf` reason ->
let pendingMsg = getPayload pendingPrefix pendingSuffix reason
in quickCheckTestPending pendingMsg
| failurePrefix `List.isPrefixOf` reason
, Just result <- readM (getPayload failurePrefix failureSuffix reason)
-> failHTF result
| otherwise ->
let replay = "Replay argument: " ++ (show (show (Just (gen, size))))
out = adjustOutput msg
in quickCheckTestFail (Just (out ++ "\n" ++ replay))
Right (GaveUp { output=msg }) ->
quickCheckTestFail (Just (adjustOutput msg))
Right (NoExpectedFailure { output=msg }) ->
quickCheckTestFail (Just (adjustOutput msg))
#if MIN_VERSION_QuickCheck(2,8,0)
Right (InsufficientCoverage { output=msg }) ->
quickCheckTestFail (Just (adjustOutput msg))
#endif
return ()
where
pendingPrefix = "Exception: 'QCPendingException \""
pendingSuffix = "\"'"
failurePrefix = "Exception: 'HTFFailure "
failureSuffix = "'"
getPayload pref suf reason =
let s = drop (length pref) reason
in take (length s - length suf) s
adjustOutput s = trimTrailing $
case s of
'+':'+':'+':' ':'O':'K':',':' ':'p':rest -> 'P':rest
'*':'*':'*':' ':'F':'a':'i':'l':'e':'d':'!':' ':rest -> rest
'*':'*':'*':' ':rest -> rest
_ -> s
trimTrailing = reverse . dropWhile isSpace . reverse
data WithQCArgs a = WithQCArgs (Args -> Args) a
data AnyTestable = forall a . Testable a => AnyTestable a
class QCAssertion a where
argsModifier :: a -> (Args -> Args)
testable :: a -> AnyTestable
instance {-# OVERLAPPABLE #-} Testable a => QCAssertion a where
argsModifier _ = id
testable = AnyTestable
instance {-# OVERLAPPING #-} Testable a => QCAssertion (WithQCArgs a) where
argsModifier (WithQCArgs f _) = f
testable (WithQCArgs _ x) = AnyTestable x
withQCArgs :: (Testable a) => (Args -> Args)
-> a
-> WithQCArgs a
withQCArgs = WithQCArgs
qcPending :: Testable t => String -> t -> t
qcPending msg _ = throw (QCPendingException msg)
#if !MIN_VERSION_QuickCheck(2,7,0)
ioProperty :: Testable prop => IO prop -> Property
ioProperty = morallyDubiousIOProperty
#endif
assertionAsProperty :: IO () -> Property
assertionAsProperty action =
ioProperty $ action >> return True
setReplayFromString :: Args -> String -> Args
setReplayFromString args str =
#if !MIN_VERSION_QuickCheck(2,7,0)
case readM str of
Just x -> args { replay = x }
Nothing -> error ("Could not parse replay parameter from string " ++ show str)
#else
case readM str of
Just x -> args { replay = x }
Nothing ->
case readM str of
Just (_ :: Maybe (StdGen, Int)) ->
error ("Your replay parameter has been produced with QuickCheck <= 2.6. It cannot be used with QuickCheck >= 2.7")
Nothing -> error ("Could not parse replay parameter from string " ++ show str)
#endif