HUnit-Plus-0.3.0: src/Test/HUnitPlus/Execution.hs
{-# OPTIONS_GHC -Wall -Werror #-}
-- | Functions for executing test cases, test paths, and test suites.
-- These functions are provided for the sake of convenience and
-- testing; however, the preferred way of using HUnit-Plus is to use
-- the "Test.HUnitPlus.Main#createMain" to create a test program
-- directly from a list of test suites.
module Test.HUnitPlus.Execution(
performTestCase,
performTest,
performTestSuite,
performTestSuites
) where
import Control.Monad (unless, foldM)
import Distribution.TestSuite
import Data.Map(Map)
import Prelude hiding (elem)
import System.TimeIt
import Test.HUnitPlus.Base
import Test.HUnitPlus.Filter
import Test.HUnitPlus.Reporting
import qualified Data.Set as Set
import qualified Data.Map as Map
-- | Execute an individual test case.
performTestCase :: Reporter us
-- ^ Report generator for the test run.
-> State
-- ^ HUnit-Plus internal state.
-> us
-- ^ State for the report generator.
-> TestInstance
-- ^ The test to be executed.
-> IO (State, us)
performTestCase rep @ Reporter { reporterStartCase = reportStartCase,
reporterError = reportError,
reporterEndCase = reportEndCase }
ss @ State { stCounts = c @ Counts { cTried = tried,
cCases = cases },
stName = oldname, stOptions = optmap,
stOptionDescs = descs } initialUs
initTi @ TestInstance { name = testname,
options = testdescs,
setOption = setopt } =
let
-- First, apply all the options
alldescs = testdescs ++ descs
-- Add the name to the state we use to run the tests
-- Update the state before running
ssWithName = ss { stName = testname, stCounts = c { cTried = tried + 1,
cCases = cases + 1 } }
-- Fold function for applying options
applyOptions (us, ti) OptionDescr { optionName = optname,
optionDefault = def } =
let
setresult :: Either String TestInstance
setresult =
case Map.lookup optname optmap of
Just optval -> setopt optname optval
Nothing -> case def of
Just optval -> setopt optname optval
Nothing -> Right ti
in case setresult of
Left errmsg ->
do
newUs <- reportError errmsg ssWithName us
return $! (newUs, ti)
Right newTi -> return $! (us, newTi)
in do
-- Get all the rest of the information from the resulting test instance
(usOpts, TestInstance { run = runTest }) <-
foldM applyOptions (initialUs, initTi) alldescs
-- Call the reporter's start case function
usStarted <- reportStartCase ssWithName usOpts
-- Actually run the test
(time, ssFinal, usFinal) <- executeTest rep ssWithName usStarted runTest
-- Call the reporters end case function
usEnded <- reportEndCase time ssFinal usFinal
-- Restore the old name before returning
return $ (ssFinal { stName = oldname }, usEnded)
-- | Log a skipped test case.
skipTestCase :: Reporter us
-- ^ Report generator for the test run.
-> State
-- ^ HUnit-Plus internal state.
-> us
-- ^ State for the report generator.
-> TestInstance
-- ^ The test to be executed.
-> IO (State, us)
skipTestCase Reporter { reporterSkipCase = reportSkipCase }
ss @ State { stCounts = c @ Counts { cSkipped = skipped,
cCases = cases },
stName = oldname } us
TestInstance { name = testname } =
let
ss' = ss { stCounts = c { cSkipped = skipped + 1, cCases = cases + 1 },
stName = testname }
in do
us' <- reportSkipCase ss' us
return $! (ss' { stName = oldname }, us')
-- | Execute a given test (which may be a group), with the specified
-- selector and report generators. Only tests which match the
-- selector will be executed. The rest will be logged as skipped.
performTest :: Reporter us
-- ^ Report generator for the test run.
-> Selector
-- ^ The selector to apply to all tests in the suite.
-> State
-- ^ HUnit-Plus internal state.
-> us
-- ^ State for the report generator.
-> Test
-- ^ The test to be executed.
-> IO (State, us)
performTest rep initSelector initState initialUs initialTest =
let
-- The recursive worker function that actually runs all the tests
--
-- We need to actually run through all the tests, so we can record
-- the ones we skip. So we keep a Maybe Selector, where Nothing
-- represents tests that aren't actually going to be executed.
--
-- We also have to keep a set of tags by which we're filtering.
-- The empty tag set means we don't actually filter at all.
performTest' Selector { selectorInners = inners, selectorTags = currtags }
ss us Group { groupTests = testlist, groupName = gname } =
let
-- Build the new selector
selector' =
-- Try looking up the group in the inners
case Map.lookup gname inners of
-- If we don't find anything, we can only keep executing
-- if our tag state allows it.
Nothing -> Selector { selectorInners = Map.empty,
selectorTags = currtags }
-- Otherwise, combine the inner's tag state with ours and
-- carry on.
Just inner @ Selector { selectorTags = innertags } ->
inner { selectorTags = combineTags currtags innertags }
-- Update the path for running the group's tests
oldpath = stPath ss
ssWithPath = ss { stPath = Label gname : oldpath }
foldfun (ss', us') t = performTest' selector' ss' us' t
in do
-- Run the tests with the updated path
(ssAfter, usAfter) <- foldM foldfun (ssWithPath, us) testlist
-- Return the state, reset to the old path
return $! (ssAfter { stPath = oldpath }, usAfter)
performTest' Selector { selectorInners = inners, selectorTags = currtags }
ss us (Test t @ TestInstance { name = testname,
tags = testtags }) =
let
-- Get the final tag state
finaltags =
-- Try looking up the group in the inners
case Map.lookup testname inners of
-- If we don't find anything, we can only keep executing
-- if our tag state allows it.
Nothing -> currtags
-- Otherwise, combine the inner's tag state with ours and
-- carry on.
Just Selector { selectorTags = innertags } ->
combineTags currtags innertags
-- Decide if we can execute the test
canExecute =
case finaltags of
Nothing -> False
Just set
| set == Set.empty -> True
| otherwise -> any (\tag -> Set.member tag set) testtags
in
if canExecute
then performTestCase rep ss us t
else skipTestCase rep ss us t
performTest' selector ss @ State { stOptionDescs = descs }
us (ExtraOptions newopts inner) =
performTest' selector ss { stOptionDescs = descs ++ newopts } us inner
in do
(ss', us') <- performTest' initSelector initState initialUs initialTest
unless (null (stPath ss')) $ error "performTest: Final path is nonnull"
return $! (ss', us')
-- | Decide whether to execute a test suite based on a map from suite
-- names to selectors. If the map contains a selector for the test
-- suite, execute all tests matching the selector, and log the rest as
-- skipped. If the map does not contain a selector, do not execute
-- the suite, and do /not/ log its tests as skipped.
performTestSuite :: Reporter us
-- ^ Report generator to use for running the test suite.
-> Map String Selector
-- ^ The map containing selectors for each suite.
-> us
-- ^ State for the report generator.
-> TestSuite
-- ^ Test suite to be run.
-> IO (Counts, us)
performTestSuite rep @ Reporter { reporterStartSuite = reportStartSuite,
reporterEndSuite = reportEndSuite }
filters initialUs
TestSuite { suiteName = sname, suiteTests = testlist,
suiteOptions = suiteOpts } =
case Map.lookup sname filters of
Just selector ->
let
initState = State { stCounts = zeroCounts, stName = sname,
stPath = [], stOptions = Map.fromList suiteOpts,
stOptionDescs = [] }
foldfun (c, us) testcase = performTest rep selector c us testcase
in do
startedUs <- reportStartSuite initState initialUs
(time, (finishedState, finishedUs)) <-
timeItT (foldM foldfun (initState, startedUs) testlist)
endedUs <- reportEndSuite time finishedState finishedUs
return $! (stCounts finishedState, endedUs)
_ ->
return $! (Counts { cCases = 0, cTried = 0, cErrors = 0, cFailures = 0,
cAsserts = 0, cSkipped = 0 }, initialUs)
-- | Top-level function for a test run. Given a set of suites and a
-- map from suite names to selectors, execute all suites that have
-- selectors. For any test suite, only the tests specified by its
-- selector will be executed; the rest will be logged as skipped.
-- Suites that do not have a selector will be omitted entirely, and
-- their tests will /not/ be logged as skipped.
performTestSuites :: Reporter us
-- ^ Report generator to use for running the test suite.
-> Map String Selector
-- ^ The processed filter to use.
-> [TestSuite]
-- ^ Test suite to be run.
-> IO (Counts, us)
performTestSuites rep @ Reporter { reporterStart = reportStart,
reporterEnd = reportEnd }
filters suites =
let
initialCounts = Counts { cCases = 0, cTried = 0, cErrors = 0,
cFailures = 0, cAsserts = 0, cSkipped = 0 }
combineCounts Counts { cCases = cases1, cTried = tried1,
cErrors = errors1, cFailures = failures1,
cAsserts = asserts1, cSkipped = skipped1 }
Counts { cCases = cases2, cTried = tried2,
cErrors = errors2, cFailures = failures2,
cAsserts = asserts2, cSkipped = skipped2 } =
Counts { cCases = cases1 + cases2, cTried = tried1 + tried2,
cErrors = errors1 + errors2, cFailures = failures1 + failures2,
cAsserts = asserts1 + asserts2, cSkipped = skipped1 + skipped2 }
foldfun (accumCounts, accumUs) suite =
do
(suiteCounts, suiteUs) <- performTestSuite rep filters accumUs suite
return $! (combineCounts accumCounts suiteCounts, suiteUs)
in do
initialUs <- reportStart
(time, (finishedCounts, finishedUs)) <-
timeItT (foldM foldfun (initialCounts, initialUs) suites)
endedUs <- reportEnd time finishedCounts finishedUs
return $! (finishedCounts, endedUs)