diff --git a/Test/Framework/Runners/Console.hs b/Test/Framework/Runners/Console.hs --- a/Test/Framework/Runners/Console.hs +++ b/Test/Framework/Runners/Console.hs @@ -3,34 +3,23 @@ ) where import Test.Framework.Core -import Test.Framework.Improving import Test.Framework.Options -import Test.Framework.Runners.Console.Colors -import Test.Framework.Runners.Console.ProgressBar -import Test.Framework.Runners.Console.Statistics -import Test.Framework.Runners.Console.Utilities +import Test.Framework.Runners.Console.Run import Test.Framework.Runners.Core import Test.Framework.Runners.Options import Test.Framework.Runners.Processors -import Test.Framework.Runners.TimedConsumption +import Test.Framework.Runners.Statistics +import qualified Test.Framework.Runners.XML as XML import Test.Framework.Seed import Test.Framework.Utilities -import System.Console.ANSI import System.Console.GetOpt import System.Environment import System.Exit -import System.IO -import Text.PrettyPrint.ANSI.Leijen - -import Data.List -import Data.Maybe import Data.Monoid -import Control.Monad - instance Functor OptDescr where fmap f (Option a b arg_descr c) = Option a b (fmap f arg_descr) c @@ -69,7 +58,10 @@ "specifies that tests should be run without a timeout, by default", Option ['t'] ["select-tests"] (ReqArg (\t -> mempty { ropt_test_patterns = Just [read t] }) "TEST-PATTERN") - "only tests that match at least one glob pattern given by an instance of this argument will be run" + "only tests that match at least one glob pattern given by an instance of this argument will be run", + Option [] ["jxml"] + (OptArg (\t -> mempty { ropt_xml_output = Just (Just t) }) "FILE") + "Set the output format to junit-xml, and (optionally) writes to FILE instead of STDOUT" ] interpretArgs :: [String] -> IO (Either String (RunnerOptions, [String])) @@ -100,19 +92,20 @@ exitWith (ExitFailure 1) defaultMainWithOpts :: [Test] -> RunnerOptions -> IO () -defaultMainWithOpts tests ropts = hideCursorDuring $ do +defaultMainWithOpts tests ropts = do let ropts' = completeRunnerOptions ropts -- Get a lazy list of the test results, as executed in parallel - run_tests <- runTests ropts' tests + running_tests <- runTests ropts' tests -- Show those test results to the user as we get them - let test_statistics = initialTestStatistics (totalRunTestsList run_tests) - test_statistics' <- showRunTests 0 test_statistics run_tests + fin_tests <- showRunTestsTop running_tests + let test_statistics' = gatherStatistics fin_tests - -- Show the final statistics - putStrLn "" - putDoc $ showFinalTestStatistics test_statistics' + -- Output XML report (if requested) + case ropt_xml_output ropts' of + K (Just mb_file) -> XML.produceReport test_statistics' fin_tests >>= maybe putStrLn writeFile mb_file + _ -> return () -- Set the error code depending on whether the tests succeded or not exitWith $ if ts_no_failures test_statistics' @@ -124,91 +117,6 @@ completeRunnerOptions ro = RunnerOptions { ropt_threads = K $ ropt_threads ro `orElse` processorCount, ropt_test_options = K $ ropt_test_options ro `orElse` mempty, - ropt_test_patterns = K $ ropt_test_patterns ro `orElse` mempty + ropt_test_patterns = K $ ropt_test_patterns ro `orElse` mempty, + ropt_xml_output = K $ ropt_xml_output ro `orElse` Nothing } - - -totalRunTests :: RunTest -> TestCount -totalRunTests (RunTest _ test_type _) = adjustTestCount test_type 1 mempty -totalRunTests (RunTestGroup _ tests) = totalRunTestsList tests - -totalRunTestsList :: [RunTest] -> TestCount -totalRunTestsList = mconcat . map totalRunTests - - --- This code all /really/ sucks. There must be a better way to seperate out the console-updating --- and the improvement-traversing concerns - but how? -showRunTest :: Int -> TestStatistics -> RunTest -> IO TestStatistics -showRunTest indent_level test_statistics (RunTest name test_type improving_result) = do - let progress_bar = testStatisticsProgressBar test_statistics - property_suceeded <- showImprovingTestResult (return ()) indent_level name progress_bar improving_result - return $ updateTestStatistics (\count -> adjustTestCount test_type count mempty) property_suceeded test_statistics -showRunTest indent_level test_statistics (RunTestGroup name tests) = do - putDoc $ (indent indent_level (text name <> char ':')) <> linebreak - showRunTests (indent_level + 2) test_statistics tests - -showRunTests :: Int -> TestStatistics -> [RunTest] -> IO TestStatistics -showRunTests indent_level = foldM (showRunTest indent_level) - - -testStatisticsProgressBar :: TestStatistics -> Doc -testStatisticsProgressBar test_statistics = progressBar (colorPassOrFail no_failures) width (Progress run_tests total_tests) - where - run_tests = testCountTotal (ts_run_tests test_statistics) - total_tests = testCountTotal (ts_total_tests test_statistics) - no_failures = ts_no_failures test_statistics - -- We assume a terminal width of 80, but we can't make the progress bar 80 characters wide. Why? Because if we - -- do so, when we write the progress bar out Windows will move the cursor onto the next line! By using a slightly - -- smaller width we prevent this from happening. Bit of a hack, but it does the job. - width = 79 - -updateTestStatistics :: (Int -> TestCount) -> Bool -> TestStatistics -> TestStatistics -updateTestStatistics count_constructor test_suceeded test_statistics = test_statistics { - ts_run_tests = ts_run_tests test_statistics `mappend` (count_constructor 1), - ts_failed_tests = ts_failed_tests test_statistics `mappend` (count_constructor (if test_suceeded then 0 else 1)), - ts_passed_tests = ts_passed_tests test_statistics `mappend` (count_constructor (if test_suceeded then 1 else 0)) - } - - -consumeImprovingThing :: (a :~> b) -> [(a :~> b)] -consumeImprovingThing improving@(Finished _) = [improving] -consumeImprovingThing improving@(Improving _ rest) = improving : consumeImprovingThing rest - - -showImprovingTestResult :: TestResultlike i r => IO () -> Int -> String -> Doc -> (i :~> r) -> IO Bool -showImprovingTestResult erase indent_level test_name progress_bar improving = do - -- Update the screen every every 200ms - improving_list <- consumeListInInterval 200000 (consumeImprovingThing improving) - case listToMaybeLast improving_list of - Nothing -> do -- 200ms was somehow not long enough for a single result to arrive: try again! - showImprovingTestResult erase indent_level test_name progress_bar improving - Just improving' -> do -- Display that new improving value to the user - showImprovingTestResult' erase indent_level test_name progress_bar improving' - -showImprovingTestResult' :: TestResultlike i r => IO () -> Int -> String -> Doc -> (i :~> r) -> IO Bool -showImprovingTestResult' erase indent_level test_name _ (Finished result) = do - erase - -- Output the final test status and a trailing newline - putTestHeader indent_level test_name result_doc - -- There may still be a progress bar on the line below the final test result, so - -- remove it as a precautionary measure in case this is the last test in a group - -- and hence it will not be erased in the normal course of test display. - clearLine - -- Output any extra information that may be required, e.g. to show failure reason - putDoc extra_doc - return success - where - success = testSucceeded result - (result_doc, extra_doc) | success = (brackets $ colorPass (text (show result)), empty) - | otherwise = (brackets (colorFail (text "Failed")), text (show result) <> linebreak) -showImprovingTestResult' erase indent_level test_name progress_bar (Improving intermediate rest) = do - erase - putTestHeader indent_level test_name (brackets (text intermediate_str)) - putDoc progress_bar - hFlush stdout - showImprovingTestResult (cursorUpLine 1 >> clearLine) indent_level test_name progress_bar rest - where - intermediate_str = show intermediate - -putTestHeader :: Int -> String -> Doc -> IO () -putTestHeader indent_level test_name result = putDoc $ (indent indent_level (text test_name <> char ':' <+> result)) <> linebreak diff --git a/Test/Framework/Runners/Console/Run.hs b/Test/Framework/Runners/Console/Run.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/Runners/Console/Run.hs @@ -0,0 +1,107 @@ +module Test.Framework.Runners.Console.Run ( + showRunTestsTop + ) where + +import Test.Framework.Core +import Test.Framework.Improving +import Test.Framework.Runners.Console.Colors +import Test.Framework.Runners.Console.ProgressBar +import Test.Framework.Runners.Console.Statistics +import Test.Framework.Runners.Console.Utilities +import Test.Framework.Runners.Core +import Test.Framework.Runners.Statistics +import Test.Framework.Runners.TimedConsumption +import Test.Framework.Utilities + +import System.Console.ANSI +import System.IO + +import Text.PrettyPrint.ANSI.Leijen + +import Data.Monoid + +import Control.Arrow (second) + + +showRunTestsTop :: [RunningTest] -> IO [FinishedTest] +showRunTestsTop running_tests = hideCursorDuring $ do + -- Show those test results to the user as we get them. Gather statistics on the fly for a progress bar + let test_statistics = initialTestStatistics (totalRunTestsList running_tests) + (test_statistics', finished_tests) <- showRunTests 0 test_statistics running_tests + + -- Show the final statistics + putStrLn "" + putDoc $ showFinalTestStatistics test_statistics' + + return finished_tests + + +-- This code all /really/ sucks. There must be a better way to seperate out the console-updating +-- and the improvement-traversing concerns - but how? +showRunTest :: Int -> TestStatistics -> RunningTest -> IO (TestStatistics, FinishedTest) +showRunTest indent_level test_statistics (RunTest name test_type (SomeImproving improving_result)) = do + let progress_bar = testStatisticsProgressBar test_statistics + (property_text, property_suceeded) <- showImprovingTestResult (return ()) indent_level name progress_bar improving_result + return (updateTestStatistics (\count -> adjustTestCount test_type count mempty) property_suceeded test_statistics, RunTest name test_type (property_text, property_suceeded)) +showRunTest indent_level test_statistics (RunTestGroup name tests) = do + putDoc $ (indent indent_level (text name <> char ':')) <> linebreak + fmap (second $ RunTestGroup name) $ showRunTests (indent_level + 2) test_statistics tests + +showRunTests :: Int -> TestStatistics -> [RunningTest] -> IO (TestStatistics, [FinishedTest]) +showRunTests indent_level = mapAccumLM (showRunTest indent_level) + + +testStatisticsProgressBar :: TestStatistics -> Doc +testStatisticsProgressBar test_statistics = progressBar (colorPassOrFail no_failures) terminal_width (Progress run_tests total_tests) + where + run_tests = testCountTotal (ts_run_tests test_statistics) + total_tests = testCountTotal (ts_total_tests test_statistics) + no_failures = ts_no_failures test_statistics + -- We assume a terminal width of 80, but we can't make the progress bar 80 characters wide. Why? Because if we + -- do so, when we write the progress bar out Windows will move the cursor onto the next line! By using a slightly + -- smaller width we prevent this from happening. Bit of a hack, but it does the job. + terminal_width = 79 + + +consumeImprovingThing :: (a :~> b) -> [(a :~> b)] +consumeImprovingThing improving@(Finished _) = [improving] +consumeImprovingThing improving@(Improving _ rest) = improving : consumeImprovingThing rest + + +showImprovingTestResult :: TestResultlike i r => IO () -> Int -> String -> Doc -> (i :~> r) -> IO (String, Bool) +showImprovingTestResult erase indent_level test_name progress_bar improving = do + -- Update the screen every every 200ms + improving_list <- consumeListInInterval 200000 (consumeImprovingThing improving) + case listToMaybeLast improving_list of + Nothing -> do -- 200ms was somehow not long enough for a single result to arrive: try again! + showImprovingTestResult erase indent_level test_name progress_bar improving + Just improving' -> do -- Display that new improving value to the user + showImprovingTestResult' erase indent_level test_name progress_bar improving' + +showImprovingTestResult' :: TestResultlike i r => IO () -> Int -> String -> Doc -> (i :~> r) -> IO (String, Bool) +showImprovingTestResult' erase indent_level test_name _ (Finished result) = do + erase + -- Output the final test status and a trailing newline + putTestHeader indent_level test_name result_doc + -- There may still be a progress bar on the line below the final test result, so + -- remove it as a precautionary measure in case this is the last test in a group + -- and hence it will not be erased in the normal course of test display. + clearLine + -- Output any extra information that may be required, e.g. to show failure reason + putDoc extra_doc + return (show result, success) + where + success = testSucceeded result + (result_doc, extra_doc) | success = (brackets $ colorPass (text (show result)), empty) + | otherwise = (brackets (colorFail (text "Failed")), text (show result) <> linebreak) +showImprovingTestResult' erase indent_level test_name progress_bar (Improving intermediate rest) = do + erase + putTestHeader indent_level test_name (brackets (text intermediate_str)) + putDoc progress_bar + hFlush stdout + showImprovingTestResult (cursorUpLine 1 >> clearLine) indent_level test_name progress_bar rest + where + intermediate_str = show intermediate + +putTestHeader :: Int -> String -> Doc -> IO () +putTestHeader indent_level test_name result = putDoc $ (indent indent_level (text test_name <> char ':' <+> result)) <> linebreak diff --git a/Test/Framework/Runners/Console/Statistics.hs b/Test/Framework/Runners/Console/Statistics.hs --- a/Test/Framework/Runners/Console/Statistics.hs +++ b/Test/Framework/Runners/Console/Statistics.hs @@ -1,70 +1,15 @@ module Test.Framework.Runners.Console.Statistics ( - TestCount, adjustTestCount, testCountTotal, - TestStatistics(..), ts_pending_tests, ts_no_failures, initialTestStatistics, showFinalTestStatistics + showFinalTestStatistics ) where -import Test.Framework.Core (TestTypeName) +import Test.Framework.Runners.Statistics import Test.Framework.Runners.Console.Colors import Test.Framework.Runners.Console.Table import Text.PrettyPrint.ANSI.Leijen import Data.List -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Monoid - --- | Records a count of the various kinds of test that have been run -newtype TestCount = TestCount { unTestCount :: Map TestTypeName Int } - -testCountTestTypes :: TestCount -> [TestTypeName] -testCountTestTypes = Map.keys . unTestCount - -testCountForType :: String -> TestCount -> Int -testCountForType test_type = Map.findWithDefault 0 test_type . unTestCount - -adjustTestCount :: String -> Int -> TestCount -> TestCount -adjustTestCount test_type amount = TestCount . Map.insertWith (+) test_type amount . unTestCount - - --- | The number of tests of all kinds recorded in the given 'TestCount' -testCountTotal :: TestCount -> Int -testCountTotal = sum . Map.elems . unTestCount - -instance Monoid TestCount where - mempty = TestCount $ Map.empty - mappend (TestCount tcm1) (TestCount tcm2) = TestCount $ Map.unionWith (+) tcm1 tcm2 - -minusTestCount :: TestCount -> TestCount -> TestCount -minusTestCount (TestCount tcm1) (TestCount tcm2) = TestCount $ Map.unionWith (-) tcm1 tcm2 - - --- | Records information about the run of a number of tests, such --- as how many tests have been run, how many are pending and how --- many have passed or failed. -data TestStatistics = TestStatistics { - ts_total_tests :: TestCount, - ts_run_tests :: TestCount, - ts_passed_tests :: TestCount, - ts_failed_tests :: TestCount - } - -ts_pending_tests :: TestStatistics -> TestCount -ts_pending_tests ts = ts_total_tests ts `minusTestCount` ts_run_tests ts - -ts_no_failures :: TestStatistics -> Bool -ts_no_failures ts = testCountTotal (ts_failed_tests ts) <= 0 - --- | Create some test statistics that simply records the total number of --- tests to be run, ready to be updated by the actual test runs. -initialTestStatistics :: TestCount -> TestStatistics -initialTestStatistics total_tests = TestStatistics { - ts_total_tests = total_tests, - ts_run_tests = mempty, - ts_passed_tests = mempty, - ts_failed_tests = mempty - } -- | Displays statistics as a string something like this: -- diff --git a/Test/Framework/Runners/Core.hs b/Test/Framework/Runners/Core.hs --- a/Test/Framework/Runners/Core.hs +++ b/Test/Framework/Runners/Core.hs @@ -1,5 +1,5 @@ module Test.Framework.Runners.Core ( - RunTest(..), runTests + RunTest(..), RunningTest, SomeImproving(..), FinishedTest, runTests, ) where import Test.Framework.Core @@ -11,26 +11,29 @@ import Test.Framework.Seed import Test.Framework.Utilities -import Control.Monad - -import Data.List import Data.Maybe import Data.Monoid --- | A test that has been executed -data RunTest = forall i r. TestResultlike i r => RunTest TestName TestTypeName (i :~> r) - | RunTestGroup TestName [RunTest] +-- | A test that has been executed or is in the process of execution +data RunTest a = RunTest TestName TestTypeName a + | RunTestGroup TestName [RunTest a] + deriving (Show) +data SomeImproving = forall i r. TestResultlike i r => SomeImproving (i :~> r) +type RunningTest = RunTest SomeImproving + +type FinishedTest = RunTest (String, Bool) + runTests :: CompleteRunnerOptions -- ^ Top-level runner options -> [Test] -- ^ Tests to run - -> IO [RunTest] + -> IO [RunningTest] runTests ropts tests = do let test_patterns = unK $ ropt_test_patterns ropts tests' | null test_patterns = tests | otherwise = filterTests test_patterns [] tests (run_tests, actions) <- runTests' (unK $ ropt_test_options ropts) tests' - executeOnPool (unK $ ropt_threads ropts) actions + _ <- executeOnPool (unK $ ropt_threads ropts) actions return run_tests @@ -50,14 +53,14 @@ = fmap (PlusTestOptions topts) (filterTest patterns path inner_test) -runTest' :: TestOptions -> Test -> IO (RunTest, [IO ()]) +runTest' :: TestOptions -> Test -> IO (RunningTest, [IO ()]) runTest' topts (Test name testlike) = do (result, action) <- runTest (completeTestOptions topts) testlike - return (RunTest name (testTypeName testlike) result, [action]) + return (RunTest name (testTypeName testlike) (SomeImproving result), [action]) runTest' topts (TestGroup name tests) = fmap (onLeft (RunTestGroup name)) $ runTests' topts tests runTest' topts (PlusTestOptions extra_topts test) = runTest' (topts `mappend` extra_topts) test -runTests' :: TestOptions -> [Test] -> IO ([RunTest], [IO ()]) +runTests' :: TestOptions -> [Test] -> IO ([RunningTest], [IO ()]) runTests' topts = fmap (onRight concat . unzip) . mapM (runTest' topts) diff --git a/Test/Framework/Runners/Options.hs b/Test/Framework/Runners/Options.hs --- a/Test/Framework/Runners/Options.hs +++ b/Test/Framework/Runners/Options.hs @@ -12,18 +12,21 @@ data RunnerOptions' f = RunnerOptions { ropt_threads :: f Int, ropt_test_options :: f TestOptions, - ropt_test_patterns :: f [TestPattern] + ropt_test_patterns :: f [TestPattern], + ropt_xml_output :: f (Maybe (Maybe FilePath)) } instance Monoid (RunnerOptions' Maybe) where mempty = RunnerOptions { ropt_threads = Nothing, ropt_test_options = Nothing, - ropt_test_patterns = Nothing + ropt_test_patterns = Nothing, + ropt_xml_output = Nothing } mappend ro1 ro2 = RunnerOptions { ropt_threads = getLast (mappendBy (Last . ropt_threads) ro1 ro2), ropt_test_options = mappendBy ropt_test_options ro1 ro2, - ropt_test_patterns = mappendBy ropt_test_patterns ro1 ro2 + ropt_test_patterns = mappendBy ropt_test_patterns ro1 ro2, + ropt_xml_output = mappendBy ropt_xml_output ro1 ro2 } diff --git a/Test/Framework/Runners/Statistics.hs b/Test/Framework/Runners/Statistics.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/Runners/Statistics.hs @@ -0,0 +1,99 @@ +module Test.Framework.Runners.Statistics ( + TestCount, testCountTestTypes, testCountForType, adjustTestCount, testCountTotal, + TestStatistics(..), ts_pending_tests, ts_no_failures, + initialTestStatistics, updateTestStatistics, + totalRunTestsList, gatherStatistics + ) where + +import Test.Framework.Core (TestTypeName) +import Test.Framework.Runners.Core + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid + + +-- | Records a count of the various kinds of test that have been run +newtype TestCount = TestCount { unTestCount :: Map TestTypeName Int } + +testCountTestTypes :: TestCount -> [TestTypeName] +testCountTestTypes = Map.keys . unTestCount + +testCountForType :: String -> TestCount -> Int +testCountForType test_type = Map.findWithDefault 0 test_type . unTestCount + +adjustTestCount :: String -> Int -> TestCount -> TestCount +adjustTestCount test_type amount = TestCount . Map.insertWith (+) test_type amount . unTestCount + + +-- | The number of tests of all kinds recorded in the given 'TestCount' +testCountTotal :: TestCount -> Int +testCountTotal = sum . Map.elems . unTestCount + +instance Monoid TestCount where + mempty = TestCount $ Map.empty + mappend (TestCount tcm1) (TestCount tcm2) = TestCount $ Map.unionWith (+) tcm1 tcm2 + +minusTestCount :: TestCount -> TestCount -> TestCount +minusTestCount (TestCount tcm1) (TestCount tcm2) = TestCount $ Map.unionWith (-) tcm1 tcm2 + + +-- | Records information about the run of a number of tests, such +-- as how many tests have been run, how many are pending and how +-- many have passed or failed. +data TestStatistics = TestStatistics { + ts_total_tests :: TestCount, + ts_run_tests :: TestCount, + ts_passed_tests :: TestCount, + ts_failed_tests :: TestCount + } + +instance Monoid TestStatistics where + mempty = TestStatistics mempty mempty mempty mempty + mappend (TestStatistics tot1 run1 pas1 fai1) (TestStatistics tot2 run2 pas2 fai2) = TestStatistics (tot1 `mappend` tot2) (run1 `mappend` run2) (pas1 `mappend` pas2) (fai1 `mappend` fai2) + +ts_pending_tests :: TestStatistics -> TestCount +ts_pending_tests ts = ts_total_tests ts `minusTestCount` ts_run_tests ts + +ts_no_failures :: TestStatistics -> Bool +ts_no_failures ts = testCountTotal (ts_failed_tests ts) <= 0 + +-- | Create some test statistics that simply records the total number of +-- tests to be run, ready to be updated by the actual test runs. +initialTestStatistics :: TestCount -> TestStatistics +initialTestStatistics total_tests = TestStatistics { + ts_total_tests = total_tests, + ts_run_tests = mempty, + ts_passed_tests = mempty, + ts_failed_tests = mempty + } + +updateTestStatistics :: (Int -> TestCount) -> Bool -> TestStatistics -> TestStatistics +updateTestStatistics count_constructor test_suceeded test_statistics = test_statistics { + ts_run_tests = ts_run_tests test_statistics `mappend` (count_constructor 1), + ts_failed_tests = ts_failed_tests test_statistics `mappend` (count_constructor (if test_suceeded then 0 else 1)), + ts_passed_tests = ts_passed_tests test_statistics `mappend` (count_constructor (if test_suceeded then 1 else 0)) + } + + +totalRunTests :: RunTest a -> TestCount +totalRunTests (RunTest _ test_type _) = adjustTestCount test_type 1 mempty +totalRunTests (RunTestGroup _ tests) = totalRunTestsList tests + +totalRunTestsList :: [RunTest a] -> TestCount +totalRunTestsList = mconcat . map totalRunTests + +gatherStatistics :: [FinishedTest] -> TestStatistics +gatherStatistics = mconcat . map f + where + f (RunTest _ test_type (_, success)) = singleTestStatistics test_type success + f (RunTestGroup _ tests) = gatherStatistics tests + + singleTestStatistics :: String -> Bool -> TestStatistics + singleTestStatistics test_type success = TestStatistics { + ts_total_tests = one, + ts_run_tests = one, + ts_passed_tests = if success then one else mempty, + ts_failed_tests = if success then mempty else one + } + where one = adjustTestCount test_type 1 mempty diff --git a/Test/Framework/Runners/ThreadPool.hs b/Test/Framework/Runners/ThreadPool.hs --- a/Test/Framework/Runners/ThreadPool.hs +++ b/Test/Framework/Runners/ThreadPool.hs @@ -3,7 +3,6 @@ ) where import Control.Concurrent -import Control.Concurrent.Chan import Control.Monad import qualified Data.IntMap as IM @@ -30,7 +29,7 @@ -- that indicates they should terminate. We do this on another thread for -- maximum laziness (in case one the actions we are going to run depend on the -- output from previous actions..) - forkIO $ writeList2Chan input_chan (zipWith WorkerItem [0..] actions ++ replicate n WorkerTermination) + _ <- forkIO $ writeList2Chan input_chan (zipWith WorkerItem [0..] actions ++ replicate n WorkerTermination) -- Spawn workers forM_ [1..n] (const $ forkIO $ poolWorker input_chan output_chan) diff --git a/Test/Framework/Runners/XML.hs b/Test/Framework/Runners/XML.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/Runners/XML.hs @@ -0,0 +1,48 @@ +module Test.Framework.Runners.XML ( + produceReport + ) where + +import Test.Framework.Runners.Statistics ( testCountTotal, TestStatistics(..) ) +import Test.Framework.Runners.Core ( FinishedTest ) +import Test.Framework.Runners.XML.JUnitWriter ( RunDescription(..), serialize ) + +import Data.Time.Format ( formatTime ) +import Data.Time.LocalTime ( getZonedTime ) + +import System.Locale ( defaultTimeLocale ) + +import Network.HostName ( getHostName ) + + +produceReport :: TestStatistics -> [FinishedTest] -> IO String +produceReport test_statistics fin_tests = fmap serialize $ mergeResults test_statistics fin_tests + + +-- | Generates a description of the complete test run, given some +-- initial over-all test statistics and the list of tests that was +-- run. +-- +-- This is only specific to the XML code because the console output +-- @Runner@ doesn't need this level of detail to produce summary +-- information, and the per-test details are generated during +-- execution. +-- +-- This could be done better by using a State monad in the notifier +-- defined within `issueTests`. +mergeResults :: TestStatistics -> [FinishedTest] -> IO RunDescription +mergeResults test_statistics fin_tests = do + host <- getHostName + theTime <- getZonedTime + return RunDescription { + errors = 0 -- not yet available + , failedCount = testCountTotal (ts_failed_tests test_statistics) -- this includes errors + , skipped = Nothing -- not yet applicable + , hostname = Just host + , suiteName = "test-framework tests" -- not yet available + , testCount = testCountTotal (ts_total_tests test_statistics) + , time = 0.0 -- We don't currently measure the test run time. + , timeStamp = Just $ formatTime defaultTimeLocale "%a %B %e %k:%M:%S %Z %Y" theTime -- e.g. Thu May 6 22:09:10 BST 2010 + , runId = Nothing -- not applicable + , package = Nothing -- not yet available + , tests = fin_tests + } diff --git a/Test/Framework/Runners/XML/JUnitWriter.hs b/Test/Framework/Runners/XML/JUnitWriter.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/Runners/XML/JUnitWriter.hs @@ -0,0 +1,108 @@ +module Test.Framework.Runners.XML.JUnitWriter ( + RunDescription(..), + serialize, toXml, +#ifdef TEST + morphTestCase +#endif + ) where + +import Test.Framework.Runners.Core (RunTest(..), FinishedTest) + +import Data.Maybe ( fromMaybe ) +import Text.XML.Light ( ppTopElement, unqual, unode + , Attr(..), Element(..), QName(..), Content(..)) + + +-- | An overall description of the test suite run. This is currently +-- styled after the JUnit xml. It contains records that are not yet +-- used, however, it provides a sensible structure to populate as we +-- are able, and the serialiazation code behaves as though these are +-- filled. +data RunDescription = RunDescription { + errors :: Int -- ^ The number of tests that triggered error + -- conditions (unanticipated failures) + , failedCount :: Int -- ^ Count of tests that invalidated stated assertions. + , skipped :: Maybe Int -- ^ Count of tests that were provided but not run. + , hostname :: Maybe String -- ^ The hostname that ran the test suite. + , suiteName :: String -- ^ The name of the test suite. + , testCount :: Int -- ^ The total number of tests provided. + , time :: Double -- ^ The total execution time for the test suite. + , timeStamp :: Maybe String -- ^ The time stamp that identifies when this run happened. + , runId :: Maybe String -- ^ Included for completness w/ junit. + , package :: Maybe String -- ^ holdover from Junit spec. Could be + -- used to specify the module under test. + , tests :: [FinishedTest] -- ^ detailed description and results for each test run. + } deriving (Show) + + +-- | Serializes a `RunDescription` value to a `String`. +serialize :: RunDescription -> String +serialize = ppTopElement . fixClassNames . toXml + where fixClassNames = setAttributeValue (unqual "classname") (setUnsetClassName "") + +-- | Maps a `RunDescription` value to an XML Element +toXml :: RunDescription -> Element +toXml runDesc = unode "testsuite" (attrs, concatMap morphTestCase $ tests runDesc) + where + -- | Top-level attributes for the first @testsuite@ tag. + attrs :: [Attr] + attrs = map (\(x,f)->Attr (unqual x) (f runDesc)) fields + fields = [ ("errors", show . errors) + , ("failures", show . failedCount) + , ("skipped", fromMaybe "" . fmap show . skipped) + , ("hostname", fromMaybe "" . hostname) + , ("name", id . suiteName) + , ("tests", show . testCount) + , ("time", show . time) + , ("timeStamp", fromMaybe "" . timeStamp) + , ("id", fromMaybe "" . runId) + , ("package", fromMaybe "" . package) + ] + +-- | Generates XML elements for an individual test case or test group. +morphTestCase :: FinishedTest -> [Element] +morphTestCase (RunTestGroup gname testList) = map (setClassName gname) $ + concatMap morphTestCase testList + where + setClassName :: String -> Element -> Element + setClassName group e@(Element _ attribs _ _) = + e { elAttribs=setClassAttr group attribs } + + -- | Find the classname attribute and prepend gname to it. + setClassAttr :: String -> [Attr] -> [Attr] + setClassAttr _ [] = [] + setClassAttr group (a@(Attr k v):as) + | qName k == "classname" = (Attr k (updateName gname v)):as + | otherwise = a:setClassAttr group as + where + updateName prefix suffix | suffix == "" = prefix + | otherwise = prefix++"."++suffix + +morphTestCase (RunTest tName _ (tout, pass)) = case pass of + True -> [unode "testcase" caseAttrs] + False -> [unode "testcase" (caseAttrs, unode "failure" (failAttrs, tout))] + where caseAttrs = [ Attr (unqual "name") tName + , Attr (unqual "classname") "" + , Attr (unqual "time") "" + ] + failAttrs = [ Attr (unqual "message") "" + , Attr (unqual "type") "" + ] + +-- | Sets the specified attributes to the specified value in the given +-- @Element@, returning a new Element with the change. This recurses +-- deeply through the @Element@, changing all attributes. +setAttributeValue :: QName -> (Attr -> Attr) -> Element -> Element +setAttributeValue aName fn e@(Element _ attribs contents _) = e { + elAttribs = map fn attribs + , elContent = map recurse contents } + where + recurse :: Content -> Content + recurse (Elem el) = Elem $ setAttributeValue aName fn el + -- If content isn't an element, then just return the content as-is: + recurse x = x + +-- | Sets the attribute value to @newV@ iff the attribute represents a classname. +setUnsetClassName :: String -> Attr -> Attr +setUnsetClassName newV a@(Attr qn v) | qn == (unqual "classname") && v == "" = a { attrVal = newV } + | otherwise = a diff --git a/Test/Framework/Tests.hs b/Test/Framework/Tests.hs --- a/Test/Framework/Tests.hs +++ b/Test/Framework/Tests.hs @@ -1,12 +1,15 @@ module Main where import qualified Test.Framework.Tests.Runners.ThreadPool as TP +import qualified Test.Framework.Tests.Runners.XMLTests as XT import Test.HUnit - +import Test.QuickCheck -- I wish I could use my test framework to test my framework... main :: IO () main = do - runTestTT $ TestList TP.tests + _ <- runTestTT $ TestList TP.tests + _ <- runTestTT $ TestList XT.tests + quickCheck XT.prop_validXml return () diff --git a/test-framework.cabal b/test-framework.cabal --- a/test-framework.cabal +++ b/test-framework.cabal @@ -1,5 +1,5 @@ Name: test-framework -Version: 0.2.4 +Version: 0.3.0 Cabal-Version: >= 1.2.3 Category: Testing Synopsis: Framework for running and organising tests, with HUnit and QuickCheck support @@ -34,18 +34,24 @@ Test.Framework.Improving Test.Framework.Runners.Console.Colors Test.Framework.Runners.Console.ProgressBar + Test.Framework.Runners.Console.Run Test.Framework.Runners.Console.Statistics Test.Framework.Runners.Console.Table Test.Framework.Runners.Console.Utilities Test.Framework.Runners.Core Test.Framework.Runners.Processors + Test.Framework.Runners.Statistics Test.Framework.Runners.TestPattern Test.Framework.Runners.ThreadPool Test.Framework.Runners.TimedConsumption + Test.Framework.Runners.XML.JUnitWriter + Test.Framework.Runners.XML Test.Framework.Utilities Build-Depends: ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.4.0, - regex-posix >= 0.72, extensible-exceptions >= 0.1.1 + regex-posix >= 0.72, extensible-exceptions >= 0.1.1, + old-locale >= 1.0, time >= 1.1.4, + xml >= 1.3.5, hostname >= 1.0 if flag(splitBase) Build-Depends: base >= 3 && < 5, random >= 1.0, containers >= 0.1 else @@ -60,6 +66,7 @@ TypeOperators FunctionalDependencies MultiParamTypeClasses + ForeignFunctionInterface Ghc-Options: -Wall @@ -69,26 +76,34 @@ Executable test-framework-tests Main-Is: Test/Framework/Tests.hs - Build-Depends: HUnit >= 1.2, ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.4.0, regex-posix >= 0.72 - if flag(splitBase) - Build-Depends: base >= 3 && < 5, random >= 1.0, containers >= 0.1 + if !flag(tests) + Buildable: False else - Build-Depends: base < 3 + Build-Depends: HUnit >= 1.2, QuickCheck >= 2.1.0.3, + ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.4.0, + regex-posix >= 0.72, extensible-exceptions >= 0.1.1, + old-locale >= 1.0, time >= 1.1.4, + xml >= 1.3.5, hostname >= 1.0, + libxml >= 0.1.1, bytestring >= 0.9.1.5 + if flag(splitBase) + Build-Depends: base >= 3 && < 5, random >= 1.0, containers >= 0.1 + else + Build-Depends: base < 3 - Extensions: CPP - PatternGuards - ExistentialQuantification - RecursiveDo - FlexibleInstances - TypeSynonymInstances - TypeOperators - FunctionalDependencies - MultiParamTypeClasses + Extensions: CPP + PatternGuards + ExistentialQuantification + RecursiveDo + FlexibleInstances + TypeSynonymInstances + TypeOperators + FunctionalDependencies + MultiParamTypeClasses + ForeignFunctionInterface - Ghc-Options: -Wall -threaded + Cpp-Options: -DTEST - if impl(ghc) - Cpp-Options: -DCOMPILER_GHC + Ghc-Options: -Wall -threaded - if !flag(tests) - Buildable: False + if impl(ghc) + Cpp-Options: -DCOMPILER_GHC