module Test.HUnitPlus.Execution(
performTestCase,
performTest,
performTestSuite,
performTestSuites
) where
import Control.Monad (unless, foldM)
import Distribution.TestSuite
import Data.HashMap.Strict(HashMap)
import Data.Time
import Data.Version
import Network.HostName
import Prelude hiding (elem)
import System.Info
import System.TimeIt
import Test.HUnitPlus.Base
import Test.HUnitPlus.Filter
import Test.HUnitPlus.Reporting
import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as Strict
performTestCase :: Reporter us
-> State
-> us
-> TestInstance
-> 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
alldescs = testdescs ++ descs
ssWithName = ss { stName = Strict.pack testname,
stCounts = c { cTried = tried + 1, cCases = cases + 1 } }
applyOptions (us, ti) OptionDescr { optionName = optname } =
let
setresult :: Either String TestInstance
setresult =
case HashMap.lookup (Strict.pack optname) optmap of
Just optval -> setopt optname (Strict.unpack optval)
Nothing -> Right ti
in case setresult of
Left errmsg ->
do
newUs <- reportError (Strict.pack errmsg) ssWithName us
return (newUs, ti)
Right newTi -> return (us, newTi)
in do
(usOpts, TestInstance { run = runTest }) <-
foldM applyOptions (initialUs, initTi) alldescs
usStarted <- reportStartCase ssWithName usOpts
(time, ssFinal, usFinal) <- executeTest rep ssWithName usStarted runTest
usEnded <- reportEndCase time ssFinal usFinal
return (ssFinal { stName = oldname }, usEnded)
skipTestCase :: Reporter us
-> State
-> us
-> TestInstance
-> 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 = Strict.pack testname }
in do
us' <- reportSkipCase ss' us
return (ss' { stName = oldname }, us')
performTest :: Reporter us
-> Selector
-> State
-> us
-> Test
-> IO (State, us)
performTest rep initSelector initialState initialUs initialTest =
let
performTest' s @ Selector { selectorInners = inners,
selectorTags = currtags }
ss us Group { groupTests = testlist, groupName = gname } =
let
selector' =
case HashMap.lookup (Strict.pack gname) inners of
Nothing -> s { selectorInners = HashMap.empty,
selectorTags = currtags }
Just inner @ Selector { selectorTags = innertags } ->
inner { selectorTags = combineTags currtags innertags }
oldpath = stPath ss
ssWithPath = ss { stPath = Label (Strict.pack gname) : oldpath }
foldfun (ss', us') = performTest' selector' ss' us'
in do
(ssAfter, usAfter) <- foldM foldfun (ssWithPath, us) testlist
return (ssAfter { stPath = oldpath }, usAfter)
performTest' Selector { selectorInners = inners, selectorTags = currtags }
ss us (Test t @ TestInstance { name = testname,
tags = testtags }) =
let
finaltags =
case HashMap.lookup (Strict.pack testname) inners of
Nothing -> currtags
Just Selector { selectorTags = innertags } ->
combineTags currtags innertags
canExecute =
case finaltags of
Nothing -> False
Just set
| HashSet.null set -> True
| otherwise -> any (\tag -> HashSet.member tag set)
(map Strict.pack 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 initialState initialUs initialTest
unless (null (stPath ss')) $ error "performTest: Final path is nonnull"
return (ss', us')
performTestSuiteInstance :: Reporter us
-> OptionMap
-> Selector
-> State
-> us
-> TestSuite
-> IO (State, us)
performTestSuiteInstance rep @ Reporter { reporterStartSuite = reportStartSuite,
reporterEndSuite = reportEndSuite }
instopts selector
st @ State { stOptions = stopts } initialUs
TestSuite { suiteName = sname, suiteTests = testlist,
suiteOptions = suiteOpts } =
let
makestate timestamp =
let
timestr = formatTime defaultTimeLocale "%c" timestamp
withtime = HashMap.insert "timestamp" (Strict.pack timestr) stopts
withInstOpts = HashMap.union withtime instopts
unioned = HashMap.union withInstOpts (HashMap.fromList suiteOpts)
in
return st { stOptions = unioned, stName = sname }
foldfun (c, us) = performTest rep selector c us
in do
timestamp <- getCurrentTime
state <- makestate timestamp
startedUs <- reportStartSuite state initialUs
(time, (finishedState @ State { stCounts = counts }, finishedUs)) <-
timeItT (foldM foldfun (state, startedUs) testlist)
endedUs <- reportEndSuite time finishedState finishedUs
return (finishedState { stCounts = counts { cCaseAsserts = 0 } },
endedUs)
performTestSuiteInternal :: Reporter us
-> HashMap Strict.Text (HashMap OptionMap Selector)
-> State
-> us
-> TestSuite
-> IO (State, us)
performTestSuiteInternal rep filters initialSs initialUs
suite @ TestSuite { suiteName = sname } =
case HashMap.lookup sname filters of
Just optmap ->
let
foldfun (ss, us) (opts, selector) =
performTestSuiteInstance rep opts selector ss us suite
in
foldM foldfun (initialSs, initialUs) (HashMap.toList optmap)
_ -> return (initialSs, initialUs)
initState :: State
initState = State { stCounts = zeroCounts, stName = "",
stPath = [], stOptions = HashMap.empty,
stOptionDescs = [] }
performTestSuite :: Reporter us
-> HashMap Strict.Text (HashMap OptionMap Selector)
-> us
-> TestSuite
-> IO (Counts, us)
performTestSuite rep filters us suite =
do
(State { stCounts = out }, _) <-
performTestSuiteInternal rep filters initState us suite
return (out, us)
performTestSuites :: Reporter us
-> HashMap Strict.Text (HashMap OptionMap Selector)
-> [TestSuite]
-> IO (Counts, us)
performTestSuites rep @ Reporter { reporterStart = reportStart,
reporterEnd = reportEnd }
filters suites =
let
foldfun (accumState, accumUs) =
performTestSuiteInternal rep filters accumState accumUs
startstate =
do
hostname <- getHostName
return initState {
stOptions = HashMap.fromList
[("hostname", Strict.pack hostname),
("os", Strict.pack os),
("arch", Strict.pack arch),
("compiler-name",
Strict.pack compilerName),
("compiler-version",
Strict.pack (showVersion compilerVersion))]
}
in do
initialUs <- reportStart
st <- startstate
(time, (State { stCounts = finishedCounts }, finishedUs)) <-
timeItT (foldM foldfun (st, initialUs) suites)
endedUs <- reportEnd time finishedCounts finishedUs
return (finishedCounts, endedUs)