{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-- | Allows HUnit test cases to be used with the test-framework package.
--
-- For an example of how to use test-framework, please see <http://github.com/batterseapower/test-framework/raw/master/example/Test/Framework/Example.lhs>
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

-- | Create a 'Test' for a HUnit 'Assertion'
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

-- | Adapt an existing HUnit test into a list of test-framework tests.
-- This is useful when migrating your existing HUnit test suite to test-framework.
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)
        -- If the list occurs at the top level (with no description above it),
        -- just return that list straightforwardly
      | 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
        -- If the list occurs with a description, turn that into a honest-to-god
        -- test group. This is heuristic, but likely to give good results
      | 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