{-# 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
import Test.Tasty ( Timeout(..) )
import Data.Typeable
import Data.Tagged
import Data.Maybe
import Data.Monoid
import Control.Exception ( displayException, try, SomeException )
import Control.Concurrent.Timeout ( timeout )
data WrappedTest t = WrappedTest (IO Result -> IO Result) t
deriving Typeable
instance forall t. IsTest t => IsTest (WrappedTest t) where
run opts (WrappedTest wrap t) prog =
let (pre,post) = case lookupOption opts of
NoTimeout -> (fmap Just, fromJust)
Timeout t s -> (timeout (faster t), fromMaybe (timeoutResult t s))
faster t = t - 2000
timeoutResult t s =
Result { resultOutcome = Failure $ TestTimedOut t
, resultDescription = "Timed out after " <> s
, resultShortDescription = "TIMEOUT"
, resultTime = fromIntegral t
}
exceptionResult e =
Result { resultOutcome = Failure $ TestThrewException e
, resultDescription = "Exception: " ++ displayException e
, resultShortDescription = "FAIL"
, resultTime = 0
}
in wrap $ try (pre $ run opts t prog) >>= \case
Right r -> return (post r)
Left (e :: SomeException) -> return $ exceptionResult e
testOptions = retag (testOptions :: Tagged t [OptionDescription])
wrapTest :: (IO Result -> IO Result) -> TestTree -> TestTree
wrapTest wrap = go
where
go (SingleTest n t) = SingleTest n (WrappedTest wrap t)
go (TestGroup name tests) = TestGroup name (map go tests)
go (PlusTestOptions plus tree) = PlusTestOptions plus (go tree)
go (WithResource spec gentree) = WithResource spec (go . gentree)
go (AskOptions f) = AskOptions (go . f)
expectFail :: TestTree -> TestTree
expectFail = expectFail' Nothing
expectFailBecause :: String -> TestTree -> TestTree
expectFailBecause reason = expectFail' (Just reason)
expectFail' :: Maybe String -> TestTree -> TestTree
expectFail' reason = wrapTest (fmap change)
where
change r
| resultSuccessful r
= r { resultOutcome = Failure TestFailed
, resultDescription = resultDescription r <> " (unexpected success" <> comment <> ")"
, resultShortDescription = resultShortDescription r <> " (unexpected" <> comment <> ")"
}
| otherwise
= r { resultOutcome = Success
, resultDescription = resultDescription r <> " (expected failure)"
, resultShortDescription = resultShortDescription r <> " (expected" <> comment <> ")"
}
"" `append` s = s
t `append` s | last t == '\n' = t ++ s ++ "\n"
| otherwise = t ++ "\n" ++ s
comment = maybe "" (mappend ": ") reason
ignoreTest :: TestTree -> TestTree
ignoreTest = ignoreTest' Nothing
ignoreTestBecause :: String -> TestTree -> TestTree
ignoreTestBecause reason = ignoreTest' (Just reason)
ignoreTest' :: Maybe String -> TestTree -> TestTree
ignoreTest' reason = wrapTest $ const $ return $
(testPassed "") {
resultShortDescription = "IGNORED" <> maybe "" (mappend ": ") reason
}