module Test.Framework.QuickCheckWrapper (
testableAsAssertion,
module Test.QuickCheck,
TestableWithQCArgs, WithQCArgs, withQCArgs, asTestableWithQCArgs
) where
import qualified Data.Map as Map
import Control.Concurrent.MVar
import Prelude hiding ( catch )
import Control.Exception ( throw, catch, SomeException, evaluate )
import System.IO
import System.IO.Unsafe
import System.Random
import Data.List( group, sort, intersperse )
import Data.Char
import Test.QuickCheck
import Test.QuickCheck.Property
import Test.Framework.TestManager
data QCState = QCState { qc_args :: Args }
qcState :: MVar QCState
qcState = unsafePerformIO (newMVar (QCState defaultArgs))
defaultArgs :: Args
defaultArgs = stdArgs
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)
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 x <- quickCheckWithResult args t
return (Right x)
`catch`
(\e -> return $ Left (show (e::SomeException)))
case res of
Left err -> quickCheckTestError (Just err)
Right (Success _) -> return ()
Right (Failure gen size _ _) ->
do putStrLn ("Replay argument: " ++
(show (show (Just (gen, size)))))
quickCheckTestFail Nothing
_ -> quickCheckTestFail Nothing
return ()
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