HUnit.hs

{-# 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 name = Test name . 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 = go ""
  where
    go desc (Test.HUnit.Base.TestCase a)    = [testCase desc a]
    go desc (Test.HUnit.Base.TestLabel s t) = go (desc ++ ":" ++ s) t
    go desc (Test.HUnit.Base.TestList ts)
        -- If the list occurs at the top level (with no description above it),
        -- just return that list straightforwardly
      | null desc = concatMap (go desc) 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
      | otherwise = [testGroup desc (concatMap (go "") ts)]


instance TestResultlike TestCaseRunning TestCaseResult where
    testSucceeded = testCaseSucceeded

data TestCaseRunning = TestCaseRunning

instance Show TestCaseRunning where
    show TestCaseRunning = "Running"

data TestCaseResult = TestCasePassed
                    | TestCaseFailed String
                    | TestCaseError String

instance Show TestCaseResult where
    show result = case result of
        TestCasePassed         -> "OK"
        TestCaseFailed message -> message
        TestCaseError message  -> "ERROR: " ++ message

testCaseSucceeded :: TestCaseResult -> Bool
testCaseSucceeded TestCasePassed = True
testCaseSucceeded _              = False


newtype TestCase = TestCase Assertion
    deriving Typeable

instance Testlike TestCaseRunning TestCaseResult TestCase where
    runTest topts (TestCase assertion) = runTestCase topts assertion
    testTypeName _ = "Test Cases"

runTestCase :: CompleteTestOptions -> Assertion -> IO (TestCaseRunning :~> TestCaseResult, IO ())
runTestCase topts assertion = runImprovingIO $ do
    yieldImprovement TestCaseRunning
    mb_result <- maybeTimeoutImprovingIO (unK $ topt_timeout topts) $ liftIO (myPerformTestCase assertion)
    return (mb_result `orElse` TestCaseError "Timed out")

myPerformTestCase :: Assertion -> IO TestCaseResult
myPerformTestCase assertion = do
    result <- performTestCase assertion
    return $ case result of
        Nothing               -> TestCasePassed
        Just (True, message)  -> TestCaseFailed message
        Just (False, message) -> TestCaseError message