{-# 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
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_ :: Bool
_DEBUG_ = Bool
False
debug :: String -> IO ()
debug :: String -> IO ()
debug String
s = if Bool
_DEBUG_ then String -> IO ()
putStrLn (String
"[DEBUG] " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) else () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
data QCState = QCState { QCState -> Args
qc_args :: !Args }
qcState :: IORef QCState
qcState :: IORef QCState
qcState = IO (IORef QCState) -> IORef QCState
forall a. IO a -> a
unsafePerformIO (QCState -> IO (IORef QCState)
forall a. a -> IO (IORef a)
newIORef (Args -> QCState
QCState Args
defaultArgs))
{-# NOINLINE qcState #-}
defaultArgs :: Args
defaultArgs :: Args
defaultArgs = Args
stdArgs { chatty = False }
setDefaultArgs :: Args -> IO ()
setDefaultArgs :: Args -> IO ()
setDefaultArgs Args
args =
do QCState
force <- IORef QCState -> (QCState -> (QCState, QCState)) -> IO QCState
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef QCState
qcState ((QCState -> (QCState, QCState)) -> IO QCState)
-> (QCState -> (QCState, QCState)) -> IO QCState
forall a b. (a -> b) -> a -> b
$ \QCState
state ->
let newState :: QCState
newState = QCState
state { qc_args = args }
in (QCState
newState, QCState
newState)
QCState
force QCState -> IO () -> IO ()
forall a b. a -> b -> b
`seq` () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
getCurrentArgs :: IO Args
getCurrentArgs :: IO Args
getCurrentArgs =
do QCState
state <- IORef QCState -> IO QCState
forall a. IORef a -> IO a
readIORef IORef QCState
qcState
Args -> IO Args
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QCState -> Args
qc_args QCState
state)
data QCPendingException = QCPendingException String
deriving (Int -> QCPendingException -> String -> String
[QCPendingException] -> String -> String
QCPendingException -> String
(Int -> QCPendingException -> String -> String)
-> (QCPendingException -> String)
-> ([QCPendingException] -> String -> String)
-> Show QCPendingException
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> QCPendingException -> String -> String
showsPrec :: Int -> QCPendingException -> String -> String
$cshow :: QCPendingException -> String
show :: QCPendingException -> String
$cshowList :: [QCPendingException] -> String -> String
showList :: [QCPendingException] -> String -> String
Show,ReadPrec [QCPendingException]
ReadPrec QCPendingException
Int -> ReadS QCPendingException
ReadS [QCPendingException]
(Int -> ReadS QCPendingException)
-> ReadS [QCPendingException]
-> ReadPrec QCPendingException
-> ReadPrec [QCPendingException]
-> Read QCPendingException
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS QCPendingException
readsPrec :: Int -> ReadS QCPendingException
$creadList :: ReadS [QCPendingException]
readList :: ReadS [QCPendingException]
$creadPrec :: ReadPrec QCPendingException
readPrec :: ReadPrec QCPendingException
$creadListPrec :: ReadPrec [QCPendingException]
readListPrec :: ReadPrec [QCPendingException]
Read,QCPendingException -> QCPendingException -> Bool
(QCPendingException -> QCPendingException -> Bool)
-> (QCPendingException -> QCPendingException -> Bool)
-> Eq QCPendingException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QCPendingException -> QCPendingException -> Bool
== :: QCPendingException -> QCPendingException -> Bool
$c/= :: QCPendingException -> QCPendingException -> Bool
/= :: QCPendingException -> QCPendingException -> Bool
Eq,Typeable)
instance Exception QCPendingException
quickCheckTestError :: Maybe String -> Assertion
quickCheckTestError :: Maybe String -> IO ()
quickCheckTestError Maybe String
m = FullTestResult -> IO ()
forall (m :: * -> *) a.
MonadBaseControl IO m =>
FullTestResult -> m a
failHTF (FullTestResult -> IO ()) -> FullTestResult -> IO ()
forall a b. (a -> b) -> a -> b
$ TestResult -> Maybe String -> FullTestResult
mkFullTestResult TestResult
Error Maybe String
m
quickCheckTestFail :: Maybe String -> Assertion
quickCheckTestFail :: Maybe String -> IO ()
quickCheckTestFail Maybe String
m = FullTestResult -> IO ()
forall (m :: * -> *) a.
MonadBaseControl IO m =>
FullTestResult -> m a
failHTF (FullTestResult -> IO ()) -> FullTestResult -> IO ()
forall a b. (a -> b) -> a -> b
$ TestResult -> Maybe String -> FullTestResult
mkFullTestResult TestResult
Fail Maybe String
m
quickCheckTestPending :: String -> Assertion
quickCheckTestPending :: String -> IO ()
quickCheckTestPending String
m = FullTestResult -> IO ()
forall (m :: * -> *) a.
MonadBaseControl IO m =>
FullTestResult -> m a
failHTF (FullTestResult -> IO ()) -> FullTestResult -> IO ()
forall a b. (a -> b) -> a -> b
$ TestResult -> Maybe String -> FullTestResult
mkFullTestResult TestResult
Pending (String -> Maybe String
forall a. a -> Maybe a
Just String
m)
quickCheckTestPass :: String -> Assertion
quickCheckTestPass :: String -> IO ()
quickCheckTestPass String
m = FullTestResult -> IO ()
forall (m :: * -> *) a.
MonadBaseControl IO m =>
FullTestResult -> m a
failHTF (FullTestResult -> IO ()) -> FullTestResult -> IO ()
forall a b. (a -> b) -> a -> b
$ TestResult -> Maybe String -> FullTestResult
mkFullTestResult TestResult
Pass (String -> Maybe String
forall a. a -> Maybe a
Just String
m)
qcAssertion :: (QCAssertion t) => t -> Assertion
qcAssertion :: forall t. QCAssertion t => t -> IO ()
qcAssertion t
qc =
do Args
origArgs <- IO Args
getCurrentArgs
Either String Args
eitherArgs <-
(let a :: Args
a = (t -> Args -> Args
forall a. QCAssertion a => a -> Args -> Args
argsModifier t
qc) Args
origArgs
in do Int
_ <- Int -> IO Int
forall a. a -> IO a
evaluate (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Args -> String
forall a. Show a => a -> String
show Args
a))
Either String Args -> IO (Either String Args)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Args -> Either String Args
forall a b. b -> Either a b
Right Args
a))
IO (Either String Args)
-> (SomeException -> IO (Either String Args))
-> IO (Either String Args)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
(\SomeException
e -> Either String Args -> IO (Either String Args)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Args -> IO (Either String Args))
-> Either String Args -> IO (Either String Args)
forall a b. (a -> b) -> a -> b
$ String -> Either String Args
forall a b. a -> Either a b
Left (SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException)))
case Either String Args
eitherArgs of
Left String
err -> Maybe String -> IO ()
quickCheckTestError
(String -> Maybe String
forall a. a -> Maybe a
Just (String
"Cannot evaluate custom arguments: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err))
Right Args
args ->
do Either String Result
res <- do AnyTestable
anyTestable <- AnyTestable -> IO AnyTestable
forall a. a -> IO a
evaluate (t -> AnyTestable
forall a. QCAssertion a => a -> AnyTestable
testable t
qc)
Result
x <- case AnyTestable
anyTestable of
AnyTestable a
t' -> Args -> a -> IO Result
forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult Args
args a
t'
Either String Result -> IO (Either String Result)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> Either String Result
forall a b. b -> Either a b
Right Result
x)
IO (Either String Result)
-> [Handler (Either String Result)] -> IO (Either String Result)
forall a. IO a -> [Handler a] -> IO a
`catches`
[(QCPendingException -> IO (Either String Result))
-> Handler (Either String Result)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((QCPendingException -> IO (Either String Result))
-> Handler (Either String Result))
-> (QCPendingException -> IO (Either String Result))
-> Handler (Either String Result)
forall a b. (a -> b) -> a -> b
$ \(QCPendingException String
msg) -> Either String Result -> IO (Either String Result)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Result -> IO (Either String Result))
-> Either String Result -> IO (Either String Result)
forall a b. (a -> b) -> a -> b
$ String -> Either String Result
forall a b. a -> Either a b
Left String
msg]
String -> IO ()
debug (String
"QuickCheck result: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Either String Result -> String
forall a. Show a => a -> String
show Either String Result
res)
case Either String Result
res of
Left String
err ->
String -> IO ()
quickCheckTestPending String
err
Right (Success { output :: Result -> String
output=String
msg }) ->
String -> IO ()
quickCheckTestPass (String -> String
adjustOutput String
msg)
Right (Failure { usedSize :: Result -> Int
usedSize=Int
size, usedSeed :: Result -> QCGen
usedSeed=QCGen
gen, output :: Result -> String
output=String
msg, reason :: Result -> String
reason=String
reason }) ->
case () of
()
_| String
pendingPrefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isPrefixOf` String
reason ->
let pendingMsg :: String
pendingMsg = String -> String -> String -> String
forall {t :: * -> *} {t :: * -> *} {a} {a} {a}.
(Foldable t, Foldable t) =>
t a -> t a -> [a] -> [a]
getPayload String
pendingPrefix String
pendingSuffix String
reason
in String -> IO ()
quickCheckTestPending String
pendingMsg
| String
failurePrefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isPrefixOf` String
reason
, Just FullTestResult
result <- String -> Maybe FullTestResult
forall (m :: * -> *) a. (MonadFail m, Read a) => String -> m a
readM (String -> String -> String -> String
forall {t :: * -> *} {t :: * -> *} {a} {a} {a}.
(Foldable t, Foldable t) =>
t a -> t a -> [a] -> [a]
getPayload String
failurePrefix String
failureSuffix String
reason)
-> FullTestResult -> IO ()
forall (m :: * -> *) a.
MonadBaseControl IO m =>
FullTestResult -> m a
failHTF FullTestResult
result
| Bool
otherwise ->
let replay :: String
replay = String
"Replay argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
forall a. Show a => a -> String
show (Maybe (QCGen, Int) -> String
forall a. Show a => a -> String
show ((QCGen, Int) -> Maybe (QCGen, Int)
forall a. a -> Maybe a
Just (QCGen
gen, Int
size))))
out :: String
out = String -> String
adjustOutput String
msg
in Maybe String -> IO ()
quickCheckTestFail (String -> Maybe String
forall a. a -> Maybe a
Just (String
out String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
replay))
Right (GaveUp { output :: Result -> String
output=String
msg }) ->
Maybe String -> IO ()
quickCheckTestFail (String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
adjustOutput String
msg))
Right (NoExpectedFailure { output :: Result -> String
output=String
msg }) ->
Maybe String -> IO ()
quickCheckTestFail (String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
adjustOutput String
msg))
#if MIN_VERSION_QuickCheck(2,8,0) && !MIN_VERSION_QuickCheck(2,12,0)
Right (InsufficientCoverage { output=msg }) ->
quickCheckTestFail (Just (adjustOutput msg))
#endif
() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
pendingPrefix :: String
pendingPrefix = String
"Exception: 'QCPendingException \""
pendingSuffix :: String
pendingSuffix = String
"\"'"
failurePrefix :: String
failurePrefix = String
"Exception: 'HTFFailure "
failureSuffix :: String
failureSuffix = String
"'"
getPayload :: t a -> t a -> [a] -> [a]
getPayload t a
pref t a
suf [a]
reason =
let s :: [a]
s = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
pref) [a]
reason
in Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
suf) [a]
s
adjustOutput :: String -> String
adjustOutput String
s = String -> String
trimTrailing (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
case String
s of
Char
'+':Char
'+':Char
'+':Char
' ':Char
'O':Char
'K':Char
',':Char
' ':Char
'p':String
rest -> Char
'P'Char -> String -> String
forall a. a -> [a] -> [a]
:String
rest
Char
'*':Char
'*':Char
'*':Char
' ':Char
'F':Char
'a':Char
'i':Char
'l':Char
'e':Char
'd':Char
'!':Char
' ':String
rest -> String
rest
Char
'*':Char
'*':Char
'*':Char
' ':String
rest -> String
rest
String
_ -> String
s
trimTrailing :: String -> String
trimTrailing = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
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 :: a -> Args -> Args
argsModifier a
_ = Args -> Args
forall a. a -> a
id
testable :: a -> AnyTestable
testable = a -> AnyTestable
forall a. Testable a => a -> AnyTestable
AnyTestable
instance {-# OVERLAPPING #-} Testable a => QCAssertion (WithQCArgs a) where
argsModifier :: WithQCArgs a -> Args -> Args
argsModifier (WithQCArgs Args -> Args
f a
_) = Args -> Args
f
testable :: WithQCArgs a -> AnyTestable
testable (WithQCArgs Args -> Args
_ a
x) = a -> AnyTestable
forall a. Testable a => a -> AnyTestable
AnyTestable a
x
withQCArgs :: (Testable a) => (Args -> Args)
-> a
-> WithQCArgs a
withQCArgs :: forall a. Testable a => (Args -> Args) -> a -> WithQCArgs a
withQCArgs = (Args -> Args) -> a -> WithQCArgs a
forall a. (Args -> Args) -> a -> WithQCArgs a
WithQCArgs
qcPending :: Testable t => String -> t -> t
qcPending :: forall t. Testable t => String -> t -> t
qcPending String
msg t
_ = QCPendingException -> t
forall a e. Exception e => e -> a
throw (String -> QCPendingException
QCPendingException String
msg)
#if !MIN_VERSION_QuickCheck(2,7,0)
ioProperty :: Testable prop => IO prop -> Property
ioProperty = morallyDubiousIOProperty
#endif
assertionAsProperty :: IO () -> Property
assertionAsProperty :: IO () -> Property
assertionAsProperty IO ()
action =
IO Bool -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Bool -> Property) -> IO Bool -> Property
forall a b. (a -> b) -> a -> b
$ IO ()
action IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
setReplayFromString :: Args -> String -> Args
setReplayFromString :: Args -> String -> Args
setReplayFromString Args
args String
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 String -> Maybe (Maybe (QCGen, Int))
forall (m :: * -> *) a. (MonadFail m, Read a) => String -> m a
readM String
str of
Just Maybe (QCGen, Int)
x -> Args
args { replay = x }
Maybe (Maybe (QCGen, Int))
Nothing ->
String -> Args
forall a. HasCallStack => String -> a
error (String
"Could not parse replay parameter from string " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
str)
#endif