HUnit-Plus-2.0.0: test/Tests/Test/HUnitPlus/Execution.hs
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
module Tests.Test.HUnitPlus.Execution where
import Control.Exception(Exception, throwIO)
import Data.List
import Data.HashMap.Strict(HashMap)
import Data.Maybe
import Data.Typeable
import Distribution.TestSuite
import Test.HUnitPlus.Base
import Test.HUnitPlus.Execution
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
data ReportEvent =
EndEvent Counts
| StartSuiteEvent State
| EndSuiteEvent State
| StartCaseEvent State
| EndCaseEvent State
| SkipEvent State
| ProgressEvent Strict.Text State
| FailureEvent Strict.Text State
| ErrorEvent Strict.Text State
| SystemErrEvent Strict.Text State
| SystemOutEvent Strict.Text State
deriving (Eq, Show)
fullLoggingReporter :: Reporter [ReportEvent]
fullLoggingReporter = defaultReporter {
reporterStart = return [],
reporterEnd =
\_ ss events -> return $ (EndEvent ss :events),
reporterStartSuite =
\ss events -> return $ (StartSuiteEvent ss : events),
reporterEndSuite =
\_ ss events -> return $ (EndSuiteEvent ss : events),
reporterStartCase =
\ss events -> return $ (StartCaseEvent ss : events),
reporterEndCase =
\_ ss events -> return $ (EndCaseEvent ss : events),
reporterSkipCase =
\ss events -> return $ (SkipEvent ss : events),
reporterCaseProgress =
\msg ss events -> return $ (ProgressEvent msg ss : events),
reporterFailure =
\msg ss events -> return $ (FailureEvent msg ss : events),
reporterError =
\msg ss events -> return $ (ErrorEvent msg ss : events),
reporterSystemErr =
\msg ss events -> return $ (SystemErrEvent msg ss : events),
reporterSystemOut =
\msg ss events -> return $ (SystemOutEvent msg ss : events)
}
makeTagName False False = "no_tag"
makeTagName True False = "tag1"
makeTagName False True = "tag2"
makeTagName True True = "tag12"
makeTagSet (False, False) = HashSet.empty
makeTagSet (True, False) = HashSet.singleton "tag1"
makeTagSet (False, True) = HashSet.singleton "tag2"
makeTagSet (True, True) = HashSet.fromList ["tag1", "tag2"]
data TestException = TestException
deriving (Show, Typeable)
instance Exception TestException
data Behavior = Normal Result | Exception
makeResName (Normal Pass) = "pass"
makeResName (Normal (Fail _)) = "fail"
makeResName (Normal (Error _)) = "error"
makeResName Exception = "exception"
makeAssert (Normal Pass) = assertSuccess
makeAssert (Normal (Fail msg)) = assertFailure (Strict.pack msg)
makeAssert (Normal (Error msg)) = abortError (Strict.pack msg)
makeAssert Exception = throwIO TestException
updateCounts (Normal Pass) c @ Counts { cAsserts = asserts } =
c { cAsserts = asserts + 1, cCaseAsserts = 1 }
updateCounts (Normal (Fail _)) c @ Counts { cFailures = fails,
cAsserts = asserts } =
c { cFailures = fails + 1, cAsserts = asserts + 1, cCaseAsserts = 1 }
updateCounts (Normal (Error _)) c @ Counts { cErrors = errors } =
c { cErrors = errors + 1, cCaseAsserts = 0 }
updateCounts Exception c @ Counts { cErrors = errors } =
c { cErrors = errors + 1, cCaseAsserts = 0 }
makeName :: (Bool, Bool, Behavior) -> Strict.Text
makeName (tag1, tag2, res) =
Strict.concat [makeTagName tag1 tag2, "_", makeResName res]
makeTest :: String -> (Bool, Bool, Behavior) -> Test
makeTest prefix tdata @ (tag1, tag2, res) =
let
inittags = if tag1 then ["tag1"] else []
tags = if tag2 then "tag2" : inittags else inittags
testname = prefix ++ (Strict.unpack (makeName tdata))
in
testNameTags testname tags (makeAssert res)
{-
testInstance = TestInstance { name = testname, tags = tags,
setOption = (\_ _ -> Right testInstance),
options = [], run = runTest }
in
Test testInstance
-}
makeTestData :: String -> ([Test], [ReportEvent], State) ->
Either (Bool, Bool, Behavior) (Bool, Bool, Behavior) ->
([Test], [ReportEvent], State)
makeTestData prefix
(tests, events,
ss @ State { stName = oldname,
stCounts = counts @ Counts { cCases = cases,
cTried = tried } })
(Right tdata @ (tag1, tag2, res)) =
let
startedCounts = counts { cCases = cases + 1, cTried = tried + 1 }
finishedCounts = updateCounts res startedCounts
ssWithName = ss { stName = Strict.concat [Strict.pack prefix, makeName tdata] }
ssStarted = ssWithName { stCounts = startedCounts }
ssFinished = ssWithName { stCounts = finishedCounts }
-- Remember, the order is reversed for these, because we reverse
-- the events list in the end.
newevents =
case res of
Normal Pass ->
EndCaseEvent ssFinished : StartCaseEvent ssStarted : events
Normal (Fail msg) ->
EndCaseEvent ssFinished : FailureEvent (Strict.pack msg) ssStarted :
StartCaseEvent ssStarted : events
Normal (Error msg) ->
EndCaseEvent ssFinished : ErrorEvent (Strict.pack msg) ssStarted :
StartCaseEvent ssStarted : events
Exception ->
EndCaseEvent ssFinished :
ErrorEvent "Uncaught exception in test: TestException" ssStarted :
StartCaseEvent ssStarted : events
in
(makeTest prefix tdata : tests, newevents,
ssFinished { stName = oldname })
makeTestData prefix
(tests, events, ss @ State { stCounts =
c @ Counts { cSkipped = skipped,
cCases = cases },
stName = oldname })
(Left tdata) =
let
newcounts = c { cCases = cases + 1, cSkipped = skipped + 1 }
newstate = ss { stCounts = newcounts,
stName = Strict.concat [Strict.pack prefix, makeName tdata] }
in
(makeTest prefix tdata : tests, SkipEvent newstate : events,
newstate { stName = oldname })
resultVals :: [Behavior]
resultVals = [Normal Pass, Normal (Fail "Fail Message"),
Normal (Error "Error Message"), Exception]
tagVals :: [Bool]
tagVals = [True, False]
testData :: [(Bool, Bool, Behavior)]
testData = foldl (\accum tag1 ->
foldl (\accum tag2 ->
foldl (\accum res -> (tag1, tag2, res) : accum)
accum resultVals)
accum tagVals)
[] tagVals
tag1Filter tdata @ (True, _, _) = Right tdata
tag1Filter tdata = Left tdata
tag2Filter tdata @ (_, True, _) = Right tdata
tag2Filter tdata = Left tdata
tag12Filter tdata @ (True, _, _) = Right tdata
tag12Filter tdata @ (_, True, _) = Right tdata
tag12Filter tdata = Left tdata
data ModFilter = All | WithTags (Bool, Bool) | None deriving Show
getTests :: ModFilter -> [Either (Bool, Bool, Behavior) (Bool, Bool, Behavior)]
getTests All = map Right testData
getTests (WithTags (True, False)) = map tag1Filter testData
getTests (WithTags (False, True)) = map tag2Filter testData
getTests (WithTags (True, True)) = map tag12Filter testData
getTests None = map Left testData
-- Generate a list of all mod filters we can use for a sub-module, and
-- the selectors we need for them
getSuperSet :: (Selector -> Selector) -> ModFilter ->
[(ModFilter, Selector, Bool)]
-- If we're already running all tests, there's nothing else we can do
getSuperSet wrapinner All =
[(All, wrapinner (allSelector { selectorTags = Nothing }), False)]
-- If we're running tests with both tags, we can do that, or we can
-- run all tests in the submodule.
getSuperSet wrapinner (WithTags (True, True)) =
[(WithTags (True, True),
wrapinner (allSelector { selectorTags = Nothing }), False),
(All, wrapinner allSelector, True)]
-- If we're running tests with one of the tags, we can do that, or we
-- can run with both tags, or we can run all tests.
getSuperSet wrapinner (WithTags (False, True)) =
[(WithTags (False, True),
wrapinner (allSelector { selectorTags = Nothing }), False),
(WithTags (True, True),
wrapinner (allSelector { selectorTags =
Just $! HashSet.fromList ["tag1", "tag2" ] }),
True),
(All, wrapinner allSelector, True) ]
getSuperSet wrapinner (WithTags (True, False)) =
[(WithTags (True, False),
wrapinner (allSelector { selectorTags = Nothing }), False),
(WithTags (True, True),
wrapinner (allSelector { selectorTags =
Just $! HashSet.fromList ["tag1", "tag2" ] }),
True),
(All, wrapinner allSelector, True) ]
-- If we're not running any tests, we can do anything
getSuperSet wrapinner None =
[(None, wrapinner (allSelector { selectorTags = Nothing }), False),
(WithTags (True, False),
wrapinner (allSelector { selectorTags = Just $! HashSet.singleton "tag1" }),
True),
(WithTags (False, True),
wrapinner (allSelector { selectorTags = Just $! HashSet.singleton "tag2" }),
True),
(WithTags (True, True),
wrapinner (allSelector { selectorTags =
Just $! HashSet.fromList ["tag1", "tag2" ] }),
True),
(All, wrapinner allSelector, True) ]
-- Make the tests for a group, with a starting modfilter
makeLeafGroup :: String -> (Selector -> Selector) -> ModFilter ->
([Test], [ReportEvent], State, [Selector]) ->
[([Test], [ReportEvent], State, [Selector])]
makeLeafGroup gname wrapinner mfilter initialTests =
let
mapfun :: ([Test], [ReportEvent], State, [Selector]) ->
(ModFilter, Selector, Bool) ->
([Test], [ReportEvent], State, [Selector])
mapfun (tests, events, ss @ State { stPath = oldpath }, selectors)
(mfilter, selector, valid) =
let
ssWithPath = ss { stPath = Label (Strict.pack gname) : oldpath }
(grouptests, events', ss') =
foldl (makeTestData (gname ++ "_"))
([], events, ssWithPath)
(getTests mfilter)
tests' = Group { groupName = gname, groupTests = reverse grouptests,
concurrently = True } : tests
in
if valid
then (tests', events', ss' { stPath = oldpath }, selector : selectors)
else (tests', events', ss' { stPath = oldpath }, selectors)
in
map (mapfun initialTests) (getSuperSet wrapinner mfilter)
makeOuterGroup :: ModFilter -> ([Test], [ReportEvent], State, [Selector]) ->
[([Test], [ReportEvent], State, [Selector])]
makeOuterGroup mfilter initialTests =
let
wrapOuterPath inner =
Selector { selectorInners = HashMap.singleton "Outer" inner,
selectorTags = Nothing }
mapfun :: ([Test], [ReportEvent], State, [Selector]) ->
(ModFilter, Selector, Bool) ->
[([Test], [ReportEvent], State, [Selector])]
mapfun (tests, events, ss @ State { stPath = oldpath }, selectors)
(mfilter, selector, valid) =
let
ssWithPath = ss { stPath = Label "Outer" : oldpath }
mapfun :: ([Test], [ReportEvent], State, [Selector]) ->
([Test], [ReportEvent], State, [Selector])
mapfun (innergroup : tests, events, ss, selectors) =
let
(grouptests, events', ss') = foldl (makeTestData "Outer_")
([innergroup], events, ss)
(getTests mfilter)
tests' = Group { groupName = "Outer",
groupTests = reverse grouptests,
concurrently = True } : tests
in
if valid
then (tests', events', ss' { stPath = oldpath },
selector : selectors)
else (tests', events', ss' { stPath = oldpath }, selectors)
wrapInnerPath inner =
Selector {
selectorInners =
HashMap.singleton "Outer" Selector {
selectorInners =
HashMap.singleton "Inner" inner,
selectorTags = Nothing
},
selectorTags = Nothing
}
withInner :: [([Test], [ReportEvent], State, [Selector])]
withInner = makeLeafGroup "Inner" wrapInnerPath mfilter
(tests, events, ssWithPath, selectors)
in
map mapfun withInner
in
concatMap (mapfun initialTests) (getSuperSet wrapOuterPath mfilter)
modfilters = [ All, WithTags (True, False), WithTags (False, True),
WithTags (True, True), None ]
genFilter :: Strict.Text
-> [(TestSuite, [ReportEvent],
HashMap Strict.Text (HashMap OptionMap Selector), Counts)]
genFilter sname =
let
-- Take a root ModFilter and an initial (suite list, event list,
-- selectors). We generate a stock suite, derive a selector from
-- the root ModFilter, and produce a list of possible (suite list,
-- event list, selectors)'s, one for each possibility.
suiteTestInst :: ModFilter
-> [(TestSuite, [ReportEvent],
HashMap Strict.Text (HashMap OptionMap Selector),
Counts)]
suiteTestInst mfilter =
let
-- Initial state for a filter
initState = State { stCounts = zeroCounts, stName = sname,
stPath = [], stOptions = HashMap.empty,
stOptionDescs = [] }
-- The selectors for the root set
rootSelectors :: [Selector]
rootSelectors =
case mfilter of
All -> [allSelector]
WithTags tags ->
[allSelector { selectorTags = Just $! makeTagSet tags }]
None -> []
-- Result after executing the root tests.
(rootTests, rootEvents, rootState) =
foldl (makeTestData "") ([], [StartSuiteEvent initState], initState)
(getTests mfilter)
wrapOtherPath inner =
Selector { selectorInners = HashMap.singleton "Other" inner,
selectorTags = Nothing }
-- Results after executing tests in the Other module
withOther :: [([Test], [ReportEvent], State, [Selector])]
withOther = makeLeafGroup "Other" wrapOtherPath mfilter
(rootTests, rootEvents,
rootState, rootSelectors)
finalData = concatMap (makeOuterGroup mfilter) withOther
-- Wrap up a test list, end state, and selector list into a
-- test suite and a filter. Also add the EndSuite event to
-- the events list.
buildSuite :: ([Test], [ReportEvent], State, [Selector]) ->
(TestSuite, [ReportEvent],
HashMap Strict.Text (HashMap OptionMap Selector),
Counts)
buildSuite (tests, _, _, []) =
let
suite =
TestSuite { suiteName = sname, suiteTests = reverse tests,
suiteConcurrently = True, suiteOptions = [] }
in
(suite, [], HashMap.empty, zeroCounts)
buildSuite (tests, events, state @ State { stCounts = counts },
selectors) =
let
-- Build the test suite out of the name and test list, add
-- it to the list of suites.
suite =
TestSuite { suiteName = sname, suiteTests = reverse tests,
suiteConcurrently = True, suiteOptions = [] }
-- Add an end suite event
eventsWithEnd = EndSuiteEvent state : events
-- Add an entry for this suite to the selector map
selectormap :: HashMap Strict.Text (HashMap OptionMap Selector)
selectormap =
case selectors of
[one] ->
let
optmap = HashMap.singleton HashMap.empty one
in
HashMap.singleton sname optmap
_ ->
let
combined = foldl1 combineSelectors selectors
optmap = HashMap.singleton HashMap.empty combined
in
HashMap.singleton sname optmap
in
(suite, reverse eventsWithEnd, selectormap, counts)
in
map buildSuite finalData
in
-- Create test data for this suite with all possible modfilters,
-- and add it to the existing list of test instances.
concatMap suiteTestInst modfilters
suite1Data :: [(TestSuite, [ReportEvent],
HashMap Strict.Text (HashMap OptionMap Selector), Counts)]
suite1Data = genFilter "Suite1"
suite2Data :: [(TestSuite, [ReportEvent],
HashMap Strict.Text (HashMap OptionMap Selector), Counts)]
suite2Data = genFilter "Suite2"
combineSuites :: (TestSuite, [ReportEvent],
HashMap Strict.Text (HashMap OptionMap Selector), Counts) ->
(TestSuite, [ReportEvent],
HashMap Strict.Text (HashMap OptionMap Selector), Counts) ->
([TestSuite], [ReportEvent],
HashMap Strict.Text (HashMap OptionMap Selector))
combineSuites (suite1, events1, selectormap1, Counts { cAsserts = asserts1,
cCases = cases1,
cErrors = errors1,
cFailures = failures1,
cSkipped = skipped1,
cTried = tried1 })
(suite2, events2, selectormap2, counts2) =
let
bumpCounts (EndEvent c @ Counts { cAsserts = asserts2,
cCases = cases2,
cErrors = errors2,
cFailures = failures2,
cSkipped = skipped2,
cTried = tried2 }) =
EndEvent c { cAsserts = asserts1 + asserts2,
cErrors = errors1 + errors2,
cCases = cases1 + cases2,
cFailures = failures1 + failures2,
cSkipped = skipped1 + skipped2,
cTried = tried1 + tried2 }
bumpCounts (StartSuiteEvent s @ State { stCounts =
c @ Counts { cAsserts = asserts2,
cCases = cases2,
cErrors = errors2,
cFailures = failures2,
cSkipped = skipped2,
cTried = tried2 } }) =
StartSuiteEvent s { stCounts = c { cAsserts = asserts1 + asserts2,
cErrors = errors1 + errors2,
cCases = cases1 + cases2,
cFailures = failures1 + failures2,
cSkipped = skipped1 + skipped2,
cTried = tried1 + tried2 } }
bumpCounts (EndSuiteEvent s @ State { stCounts =
c @ Counts { cAsserts = asserts2,
cCases = cases2,
cErrors = errors2,
cFailures = failures2,
cSkipped = skipped2,
cTried = tried2 } }) =
EndSuiteEvent s { stCounts = c { cAsserts = asserts1 + asserts2,
cErrors = errors1 + errors2,
cCases = cases1 + cases2,
cFailures = failures1 + failures2,
cSkipped = skipped1 + skipped2,
cTried = tried1 + tried2 } }
bumpCounts (StartCaseEvent s @ State { stCounts =
c @ Counts { cAsserts = asserts2,
cCases = cases2,
cErrors = errors2,
cFailures = failures2,
cSkipped = skipped2,
cTried = tried2 } }) =
StartCaseEvent s { stCounts = c { cAsserts = asserts1 + asserts2,
cErrors = errors1 + errors2,
cCases = cases1 + cases2,
cFailures = failures1 + failures2,
cSkipped = skipped1 + skipped2,
cTried = tried1 + tried2 } }
bumpCounts (EndCaseEvent s @ State { stCounts =
c @ Counts { cAsserts = asserts2,
cCases = cases2,
cErrors = errors2,
cFailures = failures2,
cSkipped = skipped2,
cTried = tried2 } }) =
EndCaseEvent s { stCounts = c { cAsserts = asserts1 + asserts2,
cErrors = errors1 + errors2,
cCases = cases1 + cases2,
cFailures = failures1 + failures2,
cSkipped = skipped1 + skipped2,
cTried = tried1 + tried2 } }
bumpCounts (SkipEvent s @ State { stCounts =
c @ Counts { cAsserts = asserts2,
cCases = cases2,
cErrors = errors2,
cFailures = failures2,
cSkipped = skipped2,
cTried = tried2 } }) =
SkipEvent s { stCounts = c { cAsserts = asserts1 + asserts2,
cErrors = errors1 + errors2,
cCases = cases1 + cases2,
cFailures = failures1 + failures2,
cSkipped = skipped1 + skipped2,
cTried = tried1 + tried2 } }
bumpCounts (ProgressEvent msg s @ State { stCounts =
c @ Counts { cAsserts = asserts2,
cCases = cases2,
cErrors = errors2,
cFailures = failures2,
cSkipped = skipped2,
cTried = tried2 } }) =
ProgressEvent msg s { stCounts = c { cAsserts = asserts1 + asserts2,
cErrors = errors1 + errors2,
cCases = cases1 + cases2,
cFailures = failures1 + failures2,
cSkipped = skipped1 + skipped2,
cTried = tried1 + tried2 } }
bumpCounts (FailureEvent msg s @ State { stCounts =
c @ Counts { cAsserts = asserts2,
cCases = cases2,
cErrors = errors2,
cFailures = failures2,
cSkipped = skipped2,
cTried = tried2 } }) =
FailureEvent msg s { stCounts = c { cAsserts = asserts1 + asserts2,
cErrors = errors1 + errors2,
cCases = cases1 + cases2,
cFailures = failures1 + failures2,
cSkipped = skipped1 + skipped2,
cTried = tried1 + tried2 } }
bumpCounts (ErrorEvent msg s @ State { stCounts =
c @ Counts { cAsserts = asserts2,
cCases = cases2,
cErrors = errors2,
cFailures = failures2,
cSkipped = skipped2,
cTried = tried2 } }) =
ErrorEvent msg s { stCounts = c { cAsserts = asserts1 + asserts2,
cErrors = errors1 + errors2,
cCases = cases1 + cases2,
cFailures = failures1 + failures2,
cSkipped = skipped1 + skipped2,
cTried = tried1 + tried2 } }
bumpCounts (SystemErrEvent msg s @ State { stCounts =
c @ Counts { cAsserts = asserts2,
cCases = cases2,
cErrors = errors2,
cFailures = failures2,
cSkipped = skipped2,
cTried = tried2 } }) =
SystemErrEvent msg s { stCounts = c { cAsserts = asserts1 + asserts2,
cErrors = errors1 + errors2,
cCases = cases1 + cases2,
cFailures = failures1 + failures2,
cSkipped = skipped1 + skipped2,
cTried = tried1 + tried2 } }
bumpCounts (SystemOutEvent msg s @ State { stCounts =
c @ Counts { cAsserts = asserts2,
cCases = cases2,
cErrors = errors2,
cFailures = failures2,
cSkipped = skipped2,
cTried = tried2 } }) =
SystemOutEvent msg s { stCounts = c { cAsserts = asserts1 + asserts2,
cErrors = errors1 + errors2,
cCases = cases1 + cases2,
cFailures = failures1 + failures2,
cSkipped = skipped1 + skipped2,
cTried = tried1 + tried2 } }
suites = [suite1, suite2]
events = events1 ++ map bumpCounts events2 ++
[bumpCounts (EndEvent counts2 { cCaseAsserts = 0 })]
selectormap = HashMap.union selectormap1 selectormap2
in
(suites, events, selectormap)
suiteData :: [([TestSuite], [ReportEvent],
HashMap Strict.Text (HashMap OptionMap Selector))]
suiteData = foldl (\accum suite1 ->
foldl (\accum suite2 ->
(combineSuites suite1 suite2) : accum)
accum suite2Data)
[] suite1Data
makeExecutionTest :: ([TestSuite], [ReportEvent],
HashMap Strict.Text (HashMap OptionMap Selector)) ->
(Int, [Test]) -> (Int, [Test])
makeExecutionTest (suites, expected, selectors) (index, tests) =
let
format events = intercalate "\n" (map show events)
selectorStrs =
intercalate "\n" (map (\(suite, selector) -> "[" ++ Strict.unpack suite ++
"]" ++ show selector)
(HashMap.toList selectors))
compstate State { stName = name1, stPath = path1, stCounts = counts1,
stOptionDescs = descs1 }
State { stName = name2, stPath = path2, stCounts = counts2,
stOptionDescs = descs2 } =
name1 == name2 && path1 == path2 && counts1 == counts2 && descs1 == descs2
comp (EndEvent counts1) (EndEvent counts2) = counts1 == counts2
comp (StartSuiteEvent st1) (StartSuiteEvent st2) = compstate st1 st2
comp (EndSuiteEvent st1) (EndSuiteEvent st2) = compstate st1 st2
comp (StartCaseEvent st1) (StartCaseEvent st2) = compstate st1 st2
comp (EndCaseEvent st1) (EndCaseEvent st2) = compstate st1 st2
comp (SkipEvent st1) (SkipEvent st2) = compstate st1 st2
comp (ProgressEvent msg1 st1) (ProgressEvent msg2 st2) =
msg1 == msg2 && compstate st1 st2
comp (FailureEvent msg1 st1) (FailureEvent msg2 st2) =
msg1 == msg2 && compstate st1 st2
comp (ErrorEvent msg1 st1) (ErrorEvent msg2 st2) =
msg1 == msg2 && compstate st1 st2
comp (SystemErrEvent msg1 st1) (SystemErrEvent msg2 st2) =
msg1 == msg2 && compstate st1 st2
comp (SystemOutEvent msg1 st1) (SystemOutEvent msg2 st2) =
msg1 == msg2 && compstate st1 st2
comp _ _ = False
check (e : expecteds) (a : actuals)
| comp e a = check expecteds actuals
| otherwise =
return (Finished (Fail ("Selectors\n" ++ selectorStrs ++
"\nExpected\n************************\n" ++
show e ++
"\nbut got\n************************\n" ++
show a)))
check [] [] = return (Finished Pass)
check expected [] =
return (Finished (Fail ("Missing output:\n" ++ format expected)))
check [] actual =
return (Finished (Fail ("Extra output:\n" ++ format actual)))
runTest =
do
(_, actual) <- performTestSuites fullLoggingReporter selectors suites
check expected (reverse actual)
testInstance = TestInstance { name = "execution_test_" ++ show index,
tags = [], options = [], run = runTest,
setOption = (\_ _ -> Right testInstance) }
in
(index + 1, Test testInstance : tests)
tests :: Test
tests = testGroup "Execution" (snd (foldr makeExecutionTest (0, []) suiteData))