{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, LambdaCase #-}
module Test.Tasty.ExpectedFailure (expectFail, expectFailBecause, ignoreTest, ignoreTestBecause, wrapTest) where

import Test.Tasty.Options
import Test.Tasty.Runners
import Test.Tasty.Providers
#if MIN_VERSION_tasty(1,3,1)
import Test.Tasty.Providers.ConsoleFormat ( ResultDetailsPrinter(..) )
#endif
import Test.Tasty ( Timeout(..), askOption, localOption )
import Data.Typeable
import Data.Tagged
import Data.Maybe
import Data.Monoid
import Control.Exception ( displayException, evaluate, try, SomeException )
import Control.Concurrent.Timeout ( timeout )


data WrappedTest t = WrappedTest Timeout (IO Result -> IO Result) t
    deriving Typeable

instance forall t. IsTest t => IsTest (WrappedTest t) where
    run :: OptionSet -> WrappedTest t -> (Progress -> IO ()) -> IO Result
run OptionSet
opts (WrappedTest Timeout
tmout IO Result -> IO Result
wrap t
t) Progress -> IO ()
prog =
      -- Re-implement timeouts and exception handling *inside* the
      -- wrapper.  The primary location for timeout and exception
      -- handling is in `executeTest` in the Tasty module's
      -- Test.Tasty.Run implementation, but that handling is above the
      -- level of this wrapper which therefore cannot absorb timeouts
      -- and exceptions as *expected* failures.
      let (IO a -> IO (Maybe a)
pre,Maybe Result -> Result
post) = case Timeout
tmout of
                         Timeout
NoTimeout -> ((a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just, Maybe Result -> Result
forall a. HasCallStack => Maybe a -> a
fromJust)
                         Timeout Integer
t String
s -> (Integer -> IO a -> IO (Maybe a)
forall α. Integer -> IO α -> IO (Maybe α)
timeout Integer
t, Result -> Maybe Result -> Result
forall a. a -> Maybe a -> a
fromMaybe (Integer -> String -> Result
timeoutResult Integer
t String
s))
          timeoutResult :: Integer -> String -> Result
timeoutResult Integer
t String
s =
            Result :: Outcome
-> String -> String -> Time -> ResultDetailsPrinter -> Result
Result { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure (FailureReason -> Outcome) -> FailureReason -> Outcome
forall a b. (a -> b) -> a -> b
$ Integer -> FailureReason
TestTimedOut Integer
t
                   , resultDescription :: String
resultDescription = String
"Timed out after " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s
                   , resultShortDescription :: String
resultShortDescription = String
"TIMEOUT"
                   , resultTime :: Time
resultTime = Integer -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
t
#if MIN_VERSION_tasty(1,3,1)
                   , resultDetailsPrinter :: ResultDetailsPrinter
resultDetailsPrinter = (Int -> ConsoleFormatPrinter -> IO ()) -> ResultDetailsPrinter
ResultDetailsPrinter ((Int -> ConsoleFormatPrinter -> IO ()) -> ResultDetailsPrinter)
-> (IO () -> Int -> ConsoleFormatPrinter -> IO ())
-> IO ()
-> ResultDetailsPrinter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConsoleFormatPrinter -> IO ())
-> Int -> ConsoleFormatPrinter -> IO ()
forall a b. a -> b -> a
const ((ConsoleFormatPrinter -> IO ())
 -> Int -> ConsoleFormatPrinter -> IO ())
-> (IO () -> ConsoleFormatPrinter -> IO ())
-> IO ()
-> Int
-> ConsoleFormatPrinter
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> ConsoleFormatPrinter -> IO ()
forall a b. a -> b -> a
const (IO () -> ResultDetailsPrinter) -> IO () -> ResultDetailsPrinter
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
                   }
          exceptionResult :: SomeException -> Result
exceptionResult SomeException
e =
            Result :: Outcome
-> String -> String -> Time -> ResultDetailsPrinter -> Result
Result { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure (FailureReason -> Outcome) -> FailureReason -> Outcome
forall a b. (a -> b) -> a -> b
$ SomeException -> FailureReason
TestThrewException SomeException
e
                   , resultDescription :: String
resultDescription = String
"Exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
                   , resultShortDescription :: String
resultShortDescription = String
"FAIL"
                   , resultTime :: Time
resultTime = Time
0
#if MIN_VERSION_tasty(1,3,1)
                   , resultDetailsPrinter :: ResultDetailsPrinter
resultDetailsPrinter = (Int -> ConsoleFormatPrinter -> IO ()) -> ResultDetailsPrinter
ResultDetailsPrinter ((Int -> ConsoleFormatPrinter -> IO ()) -> ResultDetailsPrinter)
-> (IO () -> Int -> ConsoleFormatPrinter -> IO ())
-> IO ()
-> ResultDetailsPrinter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConsoleFormatPrinter -> IO ())
-> Int -> ConsoleFormatPrinter -> IO ()
forall a b. a -> b -> a
const ((ConsoleFormatPrinter -> IO ())
 -> Int -> ConsoleFormatPrinter -> IO ())
-> (IO () -> ConsoleFormatPrinter -> IO ())
-> IO ()
-> Int
-> ConsoleFormatPrinter
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> ConsoleFormatPrinter -> IO ()
forall a b. a -> b -> a
const (IO () -> ResultDetailsPrinter) -> IO () -> ResultDetailsPrinter
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
                   }
          forceList :: [a] -> ()
forceList = (a -> () -> ()) -> () -> [a] -> ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> () -> ()
seq ()
      in IO Result -> IO Result
wrap (IO Result -> IO Result) -> IO Result -> IO Result
forall a b. (a -> b) -> a -> b
$ IO (Maybe Result) -> IO (Either SomeException (Maybe Result))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Result -> IO (Maybe Result)
forall a. IO a -> IO (Maybe a)
pre (OptionSet -> t -> (Progress -> IO ()) -> IO Result
forall t.
IsTest t =>
OptionSet -> t -> (Progress -> IO ()) -> IO Result
run OptionSet
opts t
t Progress -> IO ()
prog
                         -- Ensure exceptions trying to show the
                         -- failure result are caught as "expected"
                         -- (see Issue #24 and note below)
                         IO Result -> (Result -> IO Result) -> IO Result
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Result
r -> Result -> IO Result
forall a. a -> IO a
evaluate (String -> ()
forall a. [a] -> ()
forceList (Result -> String
resultDescription Result
r) () -> Result -> Result
`seq`
                                             String -> ()
forall a. [a] -> ()
forceList (Result -> String
resultShortDescription Result
r) () -> Result -> Result
`seq`
                                             Result -> Outcome
resultOutcome Result
r Outcome -> Result -> Result
`seq`
                                             Result
r)))
         IO (Either SomeException (Maybe Result))
-> (Either SomeException (Maybe Result) -> IO Result) -> IO Result
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
               Right Maybe Result
r -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Result -> Result
post Maybe Result
r)
               Left (SomeException
e :: SomeException) -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ SomeException -> Result
exceptionResult SomeException
e
    testOptions :: Tagged (WrappedTest t) [OptionDescription]
testOptions = Tagged t [OptionDescription]
-> Tagged (WrappedTest t) [OptionDescription]
forall k1 k2 (s :: k1) b (t :: k2). Tagged s b -> Tagged t b
retag (Tagged t [OptionDescription]
forall t. IsTest t => Tagged t [OptionDescription]
testOptions :: Tagged t [OptionDescription])

    -- Note regarding post-run evaluate above:
    --
    -- The normal behavior of tasty-expected-failure is to run the
    -- test, show the failure result, but then note that the failure
    -- is expected and not count that against a test failure.  If the
    -- test unexpectedly succeeds, a message to that effect is
    -- printed, but there is no resultDescription display of the test
    -- inputs.
    --
    -- As of Tasty 1.4, the core tasty code was enhanced to fix issue
    -- #280 in tasty: essentially the test result report is forced.
    -- However, when used with tests expected to fail that also throw
    -- exceptions when attempting to show the result, the forcing in
    -- Tasty 1.4 causes an exception to be thrown after the
    -- tasty-expected-failure protections but still within the realm
    -- where tasty would count it as a failure.  The fix here attempts
    -- to `show` the failing value here in tasty-expected-failure; if
    -- an exception occurs during that `show` then code here will
    -- report it (somewhat incorrectly) via the exceptionResult above,
    -- where tasty's subsequent forcing of the text of that
    -- exceptionResult no longer causes an exception *there*.  Since
    -- the value is only shown if there was already a failure, the
    -- reason is misleading but the outcome is consistent with the
    -- intent of tasty-expected-failure handling.


-- | 'wrapTest' allows you to modify the behaviour of the tests, e.g. by
-- modifying the result or not running the test at all. It is used to implement
-- 'expectFail' and 'ignoreTest'.
wrapTest :: (IO Result -> IO Result) -> TestTree -> TestTree
wrapTest :: (IO Result -> IO Result) -> TestTree -> TestTree
wrapTest IO Result -> IO Result
wrap = TestTree -> TestTree
go
  where
    go :: TestTree -> TestTree
go (SingleTest String
n t
t) =
      (Timeout -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption ((Timeout -> TestTree) -> TestTree)
-> (Timeout -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \(Timeout
old_timeout :: Timeout) ->
      Timeout -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption Timeout
NoTimeout (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$  -- disable Tasty's timeout; handled here instead
      String -> WrappedTest t -> TestTree
forall t. IsTest t => String -> t -> TestTree
SingleTest String
n (Timeout -> (IO Result -> IO Result) -> t -> WrappedTest t
forall t. Timeout -> (IO Result -> IO Result) -> t -> WrappedTest t
WrappedTest Timeout
old_timeout IO Result -> IO Result
wrap t
t)
    go (TestGroup String
name [TestTree]
tests) = String -> [TestTree] -> TestTree
TestGroup String
name ((TestTree -> TestTree) -> [TestTree] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
map TestTree -> TestTree
go [TestTree]
tests)
    go (PlusTestOptions OptionSet -> OptionSet
plus TestTree
tree) = (OptionSet -> OptionSet) -> TestTree -> TestTree
PlusTestOptions OptionSet -> OptionSet
plus (TestTree -> TestTree
go TestTree
tree)
    go (WithResource ResourceSpec a
spec IO a -> TestTree
gentree) = ResourceSpec a -> (IO a -> TestTree) -> TestTree
forall a. ResourceSpec a -> (IO a -> TestTree) -> TestTree
WithResource ResourceSpec a
spec (TestTree -> TestTree
go (TestTree -> TestTree) -> (IO a -> TestTree) -> IO a -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> TestTree
gentree)
    go (AskOptions OptionSet -> TestTree
f) = (OptionSet -> TestTree) -> TestTree
AskOptions (TestTree -> TestTree
go (TestTree -> TestTree)
-> (OptionSet -> TestTree) -> OptionSet -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptionSet -> TestTree
f)


-- | Marks all tests in the given test suite as expected failures: The tests will
-- still be run, but if they succeed, it is reported as a test suite failure,
-- and conversely a the failure of the test is ignored.
--
-- Any output of a failing test is still printed.
--
-- This is useful if, in a test driven development, tests are written and
-- commited to the master branch before their implementation: It allows the
-- tests to fail (as expected) without making the whole test suite fail.
--
-- Similarly, regressions and bugs can be documented in the test suite this
-- way, until a fix is commited, and if a fix is applied (intentionally or
-- accidentially), the test suite will remind you to remove the 'expectFail'
-- marker.
expectFail :: TestTree -> TestTree
expectFail :: TestTree -> TestTree
expectFail = Maybe String -> TestTree -> TestTree
expectFail' Maybe String
forall a. Maybe a
Nothing

-- | Like 'expectFail' but with additional comment
expectFailBecause :: String -> TestTree -> TestTree
expectFailBecause :: String -> TestTree -> TestTree
expectFailBecause String
reason = Maybe String -> TestTree -> TestTree
expectFail' (String -> Maybe String
forall a. a -> Maybe a
Just String
reason)

expectFail' :: Maybe String -> TestTree -> TestTree
expectFail' :: Maybe String -> TestTree -> TestTree
expectFail' Maybe String
reason = (IO Result -> IO Result) -> TestTree -> TestTree
wrapTest ((Result -> Result) -> IO Result -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result -> Result
change)
  where
    change :: Result -> Result
change Result
r
        | Result -> Bool
resultSuccessful Result
r
        = Result
r { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure FailureReason
TestFailed
            , resultDescription :: String
resultDescription = Result -> String
resultDescription Result
r String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (unexpected success" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
comment String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
            , resultShortDescription :: String
resultShortDescription = Result -> String
resultShortDescription Result
r String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (unexpected" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
comment String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
            }
        | Bool
otherwise
        = Result
r { resultOutcome :: Outcome
resultOutcome = Outcome
Success
            , resultDescription :: String
resultDescription = Result -> String
resultDescription Result
r String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (expected failure)"
            , resultShortDescription :: String
resultShortDescription = Result -> String
resultShortDescription Result
r String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (expected" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
comment String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
            }
    String
"" append :: String -> String -> String
`append` String
s = String
s
    String
t  `append` String
s | String -> Char
forall a. [a] -> a
last String
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' = String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
                  | Bool
otherwise      = String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
    comment :: String
comment = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String -> String -> String
forall a. Monoid a => a -> a -> a
mappend String
": ") Maybe String
reason

-- | Prevents the tests from running and reports them as succeeding.
--
-- This may be be desireable as an alternative to commenting out the tests. This
-- way, they are still typechecked (preventing bitrot), and the test report
-- lists them, which serves as a reminder that there are ignored tests.
--
-- Note that any setup/teardown actions executed by 'Test.Tasty.withResource'
-- are still executed. You can bypass this manually as in the following example:
--
-- @
-- askOption $ \\(MyFlag b) -> if b
--                            then withResource mytest
--                            else ignoreTest . mytest $ return junkvalue
-- @
ignoreTest :: TestTree -> TestTree
ignoreTest :: TestTree -> TestTree
ignoreTest = Maybe String -> TestTree -> TestTree
ignoreTest' Maybe String
forall a. Maybe a
Nothing

-- | Like 'ignoreTest' but with additional comment
ignoreTestBecause :: String -> TestTree -> TestTree
ignoreTestBecause :: String -> TestTree -> TestTree
ignoreTestBecause String
reason = Maybe String -> TestTree -> TestTree
ignoreTest' (String -> Maybe String
forall a. a -> Maybe a
Just String
reason)

ignoreTest' :: Maybe String -> TestTree -> TestTree
ignoreTest' :: Maybe String -> TestTree -> TestTree
ignoreTest' Maybe String
reason = (IO Result -> IO Result) -> TestTree -> TestTree
wrapTest ((IO Result -> IO Result) -> TestTree -> TestTree)
-> (IO Result -> IO Result) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ IO Result -> IO Result -> IO Result
forall a b. a -> b -> a
const (IO Result -> IO Result -> IO Result)
-> IO Result -> IO Result -> IO Result
forall a b. (a -> b) -> a -> b
$ Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$
    (String -> Result
testPassed (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
reason) {
      resultShortDescription :: String
resultShortDescription = String
"IGNORED"
    }