{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Test.Framework.Providers.HUnit (
testCase,
hUnitTestToTests,
) where
import Test.Framework.Providers.API
import qualified Test.HUnit.Base
import Test.HUnit.Lang
import Data.Typeable
testCase :: TestName -> Assertion -> Test
testCase :: TestName -> Assertion -> Test
testCase name :: TestName
name = TestName -> TestCase -> Test
forall i r t. (Testlike i r t, Typeable t) => TestName -> t -> Test
Test TestName
name (TestCase -> Test) -> (Assertion -> TestCase) -> Assertion -> Test
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Assertion -> TestCase
TestCase
hUnitTestToTests :: Test.HUnit.Base.Test -> [Test]
hUnitTestToTests :: Test -> [Test]
hUnitTestToTests = TestName -> Test -> [Test]
go ""
where
go :: TestName -> Test -> [Test]
go desc :: TestName
desc (Test.HUnit.Base.TestCase a :: Assertion
a) = [TestName -> Assertion -> Test
testCase TestName
desc Assertion
a]
go desc :: TestName
desc (Test.HUnit.Base.TestLabel s :: TestName
s t :: Test
t) = TestName -> Test -> [Test]
go (TestName
desc TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ ":" TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
s) Test
t
go desc :: TestName
desc (Test.HUnit.Base.TestList ts :: [Test]
ts)
| TestName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TestName
desc = (Test -> [Test]) -> [Test] -> [Test]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TestName -> Test -> [Test]
go TestName
desc) [Test]
ts
| Bool
otherwise = [TestName -> [Test] -> Test
testGroup TestName
desc ((Test -> [Test]) -> [Test] -> [Test]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TestName -> Test -> [Test]
go "") [Test]
ts)]
instance TestResultlike TestCaseRunning TestCaseResult where
testSucceeded :: TestCaseResult -> Bool
testSucceeded = TestCaseResult -> Bool
testCaseSucceeded
data TestCaseRunning = TestCaseRunning
instance Show TestCaseRunning where
show :: TestCaseRunning -> TestName
show TestCaseRunning = "Running"
data TestCaseResult = TestCasePassed
| TestCaseFailed String
| TestCaseError String
instance Show TestCaseResult where
show :: TestCaseResult -> TestName
show result :: TestCaseResult
result = case TestCaseResult
result of
TestCasePassed -> "OK"
TestCaseFailed message :: TestName
message -> TestName
message
TestCaseError message :: TestName
message -> "ERROR: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
message
testCaseSucceeded :: TestCaseResult -> Bool
testCaseSucceeded :: TestCaseResult -> Bool
testCaseSucceeded TestCasePassed = Bool
True
testCaseSucceeded _ = Bool
False
newtype TestCase = TestCase Assertion
deriving Typeable
instance Testlike TestCaseRunning TestCaseResult TestCase where
runTest :: CompleteTestOptions
-> TestCase -> IO (TestCaseRunning :~> TestCaseResult, Assertion)
runTest topts :: CompleteTestOptions
topts (TestCase assertion :: Assertion
assertion) = CompleteTestOptions
-> Assertion -> IO (TestCaseRunning :~> TestCaseResult, Assertion)
runTestCase CompleteTestOptions
topts Assertion
assertion
testTypeName :: TestCase -> TestName
testTypeName _ = "Test Cases"
runTestCase :: CompleteTestOptions -> Assertion -> IO (TestCaseRunning :~> TestCaseResult, IO ())
runTestCase :: CompleteTestOptions
-> Assertion -> IO (TestCaseRunning :~> TestCaseResult, Assertion)
runTestCase topts :: CompleteTestOptions
topts assertion :: Assertion
assertion = ImprovingIO TestCaseRunning TestCaseResult TestCaseResult
-> IO (TestCaseRunning :~> TestCaseResult, Assertion)
forall i f. ImprovingIO i f f -> IO (i :~> f, Assertion)
runImprovingIO (ImprovingIO TestCaseRunning TestCaseResult TestCaseResult
-> IO (TestCaseRunning :~> TestCaseResult, Assertion))
-> ImprovingIO TestCaseRunning TestCaseResult TestCaseResult
-> IO (TestCaseRunning :~> TestCaseResult, Assertion)
forall a b. (a -> b) -> a -> b
$ do
TestCaseRunning -> ImprovingIO TestCaseRunning TestCaseResult ()
forall i f. i -> ImprovingIO i f ()
yieldImprovement TestCaseRunning
TestCaseRunning
Maybe TestCaseResult
mb_result <- Maybe Int
-> ImprovingIO TestCaseRunning TestCaseResult TestCaseResult
-> ImprovingIO
TestCaseRunning TestCaseResult (Maybe TestCaseResult)
forall i f a.
Maybe Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
maybeTimeoutImprovingIO (K (Maybe Int) -> Maybe Int
forall a. K a -> a
unK (K (Maybe Int) -> Maybe Int) -> K (Maybe Int) -> Maybe Int
forall a b. (a -> b) -> a -> b
$ CompleteTestOptions -> K (Maybe Int)
forall (f :: * -> *). TestOptions' f -> f (Maybe Int)
topt_timeout CompleteTestOptions
topts) (ImprovingIO TestCaseRunning TestCaseResult TestCaseResult
-> ImprovingIO
TestCaseRunning TestCaseResult (Maybe TestCaseResult))
-> ImprovingIO TestCaseRunning TestCaseResult TestCaseResult
-> ImprovingIO
TestCaseRunning TestCaseResult (Maybe TestCaseResult)
forall a b. (a -> b) -> a -> b
$ IO TestCaseResult
-> ImprovingIO TestCaseRunning TestCaseResult TestCaseResult
forall a i f. IO a -> ImprovingIO i f a
liftIO (Assertion -> IO TestCaseResult
myPerformTestCase Assertion
assertion)
TestCaseResult
-> ImprovingIO TestCaseRunning TestCaseResult TestCaseResult
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TestCaseResult
mb_result Maybe TestCaseResult -> TestCaseResult -> TestCaseResult
forall a. Maybe a -> a -> a
`orElse` TestName -> TestCaseResult
TestCaseError "Timed out")
myPerformTestCase :: Assertion -> IO TestCaseResult
myPerformTestCase :: Assertion -> IO TestCaseResult
myPerformTestCase assertion :: Assertion
assertion = do
Result
result <- Assertion -> IO Result
performTestCase Assertion
assertion
TestCaseResult -> IO TestCaseResult
forall (m :: * -> *) a. Monad m => a -> m a
return (TestCaseResult -> IO TestCaseResult)
-> TestCaseResult -> IO TestCaseResult
forall a b. (a -> b) -> a -> b
$ case Result
result of
#if MIN_VERSION_HUnit(1,3,0)
Success -> TestCaseResult
TestCasePassed
Failure _loc :: Maybe SrcLoc
_loc message :: TestName
message -> TestName -> TestCaseResult
TestCaseFailed TestName
message
Error _loc :: Maybe SrcLoc
_loc message :: TestName
message -> TestName -> TestCaseResult
TestCaseError TestName
message
#else
Nothing -> TestCasePassed
Just (True, message) -> TestCaseFailed message
Just (False, message) -> TestCaseError message
#endif