module Test.Framework.QuickCheckWrapper (
testableAsAssertion,
module Test.QuickCheck,
TestableWithQCArgs, WithQCArgs, withQCArgs, asTestableWithQCArgs,
qcPending
) where
import qualified Data.Map as Map
import Control.Concurrent.MVar
import Prelude hiding ( catch )
import Control.Exception ( SomeException, Exception, Handler(..),
throw, catch, catches, evaluate )
import System.IO
import System.IO.Unsafe
import System.Random
import Data.List( group, sort, intersperse, isPrefixOf )
import Data.Char
import Data.Typeable (Typeable)
import Test.QuickCheck
import Test.QuickCheck.Property hiding (reason)
import Test.Framework.TestManager
import Test.Framework.TestManagerInternal
data QCState = QCState { qc_args :: Args }
qcState :: MVar QCState
qcState = unsafePerformIO (newMVar (QCState defaultArgs))
defaultArgs :: Args
defaultArgs = stdArgs { chatty = False }
setDefaultArgs :: Args -> IO ()
setDefaultArgs args =
do withMVar qcState $ \state -> return (state { qc_args = args })
return ()
getCurrentArgs :: IO Args
getCurrentArgs =
withMVar qcState $ \state -> return (qc_args state)
data QCPendingException = QCPendingException String
deriving (Show,Read,Eq,Typeable)
instance Exception QCPendingException
testableAsAssertion :: (Testable t, WithQCArgs t) => t -> Assertion
testableAsAssertion t =
withMVar qcState $ \state ->
do eitherArgs <-
(let a = (argsModifier t) (qc_args state)
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 t' <- evaluate t
x <- quickCheckWithResult args t'
return (Right x)
`catches`
[Handler $ \(QCPendingException msg) -> return $ Left (True, msg)
,Handler $ \(e::SomeException) -> return $ Left (False, show (e::SomeException))]
case res of
Left (isPending, err) ->
if isPending
then quickCheckTestPending err
else quickCheckTestError (Just err)
Right (Success { output=msg }) ->
quickCheckTestPass (adjustOutput msg)
Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=reason }) ->
if pendingPrefix `isPrefixOf` reason
then let pendingMsg = let s = drop (length pendingPrefix) reason
in take (length s length pendingSuffix) s
in quickCheckTestPending pendingMsg
else do let replay = "Replay argument: " ++ (show (show (Just (gen, size))))
quickCheckTestFail (Just (adjustOutput msg ++ "\n" ++ replay))
Right (GaveUp { output=msg }) ->
quickCheckTestFail (Just (adjustOutput msg))
Right (NoExpectedFailure { output=msg }) ->
quickCheckTestFail (Just (adjustOutput msg))
return ()
where
pendingPrefix = "Exception: 'QCPendingException \""
pendingSuffix = "\"'"
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 TestableWithQCArgs = forall a . Testable a =>
TestableWithQCArgs (Args -> Args) a
instance Testable TestableWithQCArgs where
property (TestableWithQCArgs _ t) = property t
class WithQCArgs a where
argsModifier :: a -> (Args -> Args)
original :: a -> Maybe TestableWithQCArgs
instance WithQCArgs a where
argsModifier _ = id
original _ = Nothing
instance WithQCArgs TestableWithQCArgs where
argsModifier (TestableWithQCArgs f _) = f
original a = Just a
withQCArgs :: (WithQCArgs a, Testable a) => (Args -> Args) -> a
-> TestableWithQCArgs
withQCArgs = TestableWithQCArgs
asTestableWithQCArgs :: (WithQCArgs a, Testable a) => a -> TestableWithQCArgs
asTestableWithQCArgs a =
case original a of
Just a' -> a'
Nothing -> TestableWithQCArgs id a
qcPending :: Testable t => String -> t -> t
qcPending msg _ = throw (QCPendingException msg)