{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}

--
-- Copyright (c) 2005,2009-2012 Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--

{- |

This module integrates the 'Test.QuickCheck' library into HTF. It re-exports
all functionality of 'Test.QuickCheck' and defines some additional functions.

-}

module Test.Framework.QuickCheckWrapper (

  module Test.QuickCheck,

  -- * Arguments for evaluating properties
  defaultArgs, getCurrentArgs, setDefaultArgs,
  withQCArgs, WithQCArgs, setReplayFromString,
  QCAssertion,

  -- * Pending properties
  qcPending,

  -- * Auxiliary functions
#if !MIN_VERSION_QuickCheck(2,7,0)
  ioProperty,
#endif
  assertionAsProperty,

  -- * Internal functions
  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 (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 #-}

-- | The 'Args' used if not explicitly changed.
defaultArgs :: Args
defaultArgs :: Args
defaultArgs = Args
stdArgs { chatty :: Bool
chatty = Bool
False }

-- | Change the default 'Args' used to evaluate quick check properties.
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
qc_args = Args
args }
                  in (QCState
newState, QCState
newState)
       QCState
force QCState -> IO () -> IO ()
`seq` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Retrieve the 'Args' currently used per default when evaluating quick check properties.
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 (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
showList :: [QCPendingException] -> String -> String
$cshowList :: [QCPendingException] -> String -> String
show :: QCPendingException -> String
$cshow :: QCPendingException -> String
showsPrec :: Int -> QCPendingException -> String -> String
$cshowsPrec :: Int -> 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
readListPrec :: ReadPrec [QCPendingException]
$creadListPrec :: ReadPrec [QCPendingException]
readPrec :: ReadPrec QCPendingException
$creadPrec :: ReadPrec QCPendingException
readList :: ReadS [QCPendingException]
$creadList :: ReadS [QCPendingException]
readsPrec :: Int -> ReadS QCPendingException
$creadsPrec :: Int -> ReadS QCPendingException
Read,QCPendingException -> QCPendingException -> Bool
(QCPendingException -> QCPendingException -> Bool)
-> (QCPendingException -> QCPendingException -> Bool)
-> Eq QCPendingException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QCPendingException -> QCPendingException -> Bool
$c/= :: QCPendingException -> QCPendingException -> Bool
== :: QCPendingException -> QCPendingException -> Bool
$c== :: 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)

-- | Turns a 'Test.QuickCheck' property into an 'Assertion'. This function
-- is used internally in the code generated by @htfpp@, do not use it directly.
qcAssertion :: (QCAssertion t) => t -> Assertion
qcAssertion :: 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 (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 (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 (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 (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 (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 (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 (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 (t :: * -> *) a. Foldable t => t a -> Int
length [a]
s Int -> Int -> Int
forall a. Num a => a -> a -> 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

-- | Abstract type for representing quick check properties with custom 'Args'.
--   Used only internally.
data WithQCArgs a = WithQCArgs (Args -> Args) a

-- | Existential holding a 'Testable' value.
--   Used only internally.
data AnyTestable = forall a . Testable a => AnyTestable a

-- | Type class providing access to the custom 'Args' of a quick check property.
--   Used only internally.
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

-- | Run a 'Test.QuickCheck' property with modified quick check arguments 'Args'.
withQCArgs :: (Testable a) => (Args -> Args) -- ^ Modification function for the default 'Args'
           -> a                              -- ^ Property
           -> WithQCArgs a
withQCArgs :: (Args -> Args) -> a -> WithQCArgs a
withQCArgs = (Args -> Args) -> a -> WithQCArgs a
forall a. (Args -> Args) -> a -> WithQCArgs a
WithQCArgs

-- | Use @qcPending msg prop@ to mark the given quick check property as pending
-- without removing it from the test suite and without deleting or commenting out the property code.
qcPending :: Testable t => String -> t -> t
qcPending :: 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | Sets the 'replay' parameter of the 'Args' datatype by parsing the given string.
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
    -- Starting with QC 2.7 the type of the replay field changed from
    -- 'Maybe (StdGen, Int)' to 'Maybe (QCGen, Int)'
    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 :: Maybe (QCGen, Int)
replay = Maybe (QCGen, Int)
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