{-# 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))