{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
module Test.Tasty.ExpectedFailure (expectFail, expectFailBecause, ignoreTest, ignoreTestBecause, wrapTest) where
import Test.Tasty.Options
import Test.Tasty.Runners
import Test.Tasty.Providers
import Data.Typeable
import Data.Tagged
import Data.Maybe
import Data.Monoid
data WrappedTest t = WrappedTest (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 opts :: OptionSet
opts (WrappedTest wrap :: IO Result -> IO Result
wrap t :: t
t) prog :: Progress -> IO ()
prog = IO Result -> IO Result
wrap (OptionSet -> t -> (Progress -> IO ()) -> IO Result
forall t.
IsTest t =>
OptionSet -> t -> (Progress -> IO ()) -> IO Result
run OptionSet
opts t
t Progress -> IO ()
prog)
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])
wrapTest :: (IO Result -> IO Result) -> TestTree -> TestTree
wrapTest :: (IO Result -> IO Result) -> TestTree -> TestTree
wrapTest wrap :: IO Result -> IO Result
wrap = TestTree -> TestTree
go
where
go :: TestTree -> TestTree
go (SingleTest n :: TestName
n t :: t
t) = TestName -> WrappedTest t -> TestTree
forall t. IsTest t => TestName -> t -> TestTree
SingleTest TestName
n ((IO Result -> IO Result) -> t -> WrappedTest t
forall t. (IO Result -> IO Result) -> t -> WrappedTest t
WrappedTest IO Result -> IO Result
wrap t
t)
go (TestGroup name :: TestName
name tests :: [TestTree]
tests) = TestName -> [TestTree] -> TestTree
TestGroup TestName
name ((TestTree -> TestTree) -> [TestTree] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
map TestTree -> TestTree
go [TestTree]
tests)
go (PlusTestOptions plus :: OptionSet -> OptionSet
plus tree :: TestTree
tree) = (OptionSet -> OptionSet) -> TestTree -> TestTree
PlusTestOptions OptionSet -> OptionSet
plus (TestTree -> TestTree
go TestTree
tree)
go (WithResource spec :: ResourceSpec a
spec gentree :: 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 f :: 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)
expectFail :: TestTree -> TestTree
expectFail :: TestTree -> TestTree
expectFail = Maybe TestName -> TestTree -> TestTree
expectFail' Maybe TestName
forall a. Maybe a
Nothing
expectFailBecause :: String -> TestTree -> TestTree
expectFailBecause :: TestName -> TestTree -> TestTree
expectFailBecause reason :: TestName
reason = Maybe TestName -> TestTree -> TestTree
expectFail' (TestName -> Maybe TestName
forall a. a -> Maybe a
Just TestName
reason)
expectFail' :: Maybe String -> TestTree -> TestTree
expectFail' :: Maybe TestName -> TestTree -> TestTree
expectFail' reason :: Maybe TestName
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 r :: Result
r
| Result -> Bool
resultSuccessful Result
r
= Result
r { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure FailureReason
TestFailed
, resultDescription :: TestName
resultDescription = Result -> TestName
resultDescription Result
r TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> "(unexpected success" TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
comment TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> ")"
, resultShortDescription :: TestName
resultShortDescription = "PASS (unexpected" TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
comment TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> ")"
}
| Bool
otherwise
= Result
r { resultOutcome :: Outcome
resultOutcome = Outcome
Success
, resultDescription :: TestName
resultDescription = Result -> TestName
resultDescription Result
r TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> "(expected failure)"
, resultShortDescription :: TestName
resultShortDescription = "FAIL (expected" TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
comment TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> ")"
}
"" append :: TestName -> TestName -> TestName
`append` s :: TestName
s = TestName
s
t :: TestName
t `append` s :: TestName
s | TestName -> Char
forall a. [a] -> a
last TestName
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' = TestName
t TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
s TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ "\n"
| Bool
otherwise = TestName
t TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ "\n" TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
s
comment :: TestName
comment = TestName -> (TestName -> TestName) -> Maybe TestName -> TestName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (TestName -> TestName -> TestName
forall a. Monoid a => a -> a -> a
mappend ": ") Maybe TestName
reason
ignoreTest :: TestTree -> TestTree
ignoreTest :: TestTree -> TestTree
ignoreTest = Maybe TestName -> TestTree -> TestTree
ignoreTest' Maybe TestName
forall a. Maybe a
Nothing
ignoreTestBecause :: String -> TestTree -> TestTree
ignoreTestBecause :: TestName -> TestTree -> TestTree
ignoreTestBecause reason :: TestName
reason = Maybe TestName -> TestTree -> TestTree
ignoreTest' (TestName -> Maybe TestName
forall a. a -> Maybe a
Just TestName
reason)
ignoreTest' :: Maybe String -> TestTree -> TestTree
ignoreTest' :: Maybe TestName -> TestTree -> TestTree
ignoreTest' reason :: Maybe TestName
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
$
(TestName -> Result
testPassed "") {
resultShortDescription :: TestName
resultShortDescription = "IGNORED" TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName -> (TestName -> TestName) -> Maybe TestName -> TestName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (TestName -> TestName -> TestName
forall a. Monoid a => a -> a -> a
mappend ": ") Maybe TestName
reason
}