    {-# 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 a b. (a -> b) -> IO a -> IO b
    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 { 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 a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    #endif
                       }
              exceptionResult :: SomeException -> Result
    exceptionResult SomeException
    e =
                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 a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    #endif
                       }
              forceList :: [a] -> ()
    forceList = (a -> () -> ()) -> () -> [a] -> ()
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr a -> () -> ()
    forall a b. a -> b -> b
    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 a b. IO a -> (a -> IO b) -> IO b
    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
    forall a b. a -> b -> b
    `seq`
                                                 String -> ()
    forall {a}. [a] -> ()
    forceList (Result -> String
    resultShortDescription Result
    r) () -> Result -> Result
    forall a b. a -> b -> b
    `seq`
                                                 Result -> Outcome
    resultOutcome Result
    r Outcome -> Result -> Result
    forall a b. a -> b -> b
    `seq`
                                                 Result
    r)))
             IO (Either SomeException (Maybe Result))
    -> (Either SomeException (Maybe Result) -> IO Result) -> IO Result
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
                   Right Maybe Result
    r -> Result -> IO Result
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe Result -> Result
    post Maybe Result
    r)
                   Left (SomeException
    e :: SomeException) -> Result -> IO Result
    forall a. a -> IO a
    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 a b. (a -> b) -> IO a -> IO b
    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 = Failure TestFailed
                , resultDescription = resultDescription r <> " (unexpected success" <> comment <> ")"
                , resultShortDescription = resultShortDescription r <> " (unexpected" <> comment <> ")"
                }
            | Bool
    otherwise
            = Result
    r { resultOutcome = Success
                , resultDescription = resultDescription r <> " (expected failure)"
                , resultShortDescription = resultShortDescription r <> " (expected" <> comment <> ")"
                }
        String
    "" append :: String -> String -> String
    `append` String
    s = String
    s
        String
    t  `append` String
    s | String -> Char
    forall a. HasCallStack => [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 a. a -> IO a
    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 = "IGNORED"
        }