test-framework 0.2.4 → 0.3.0
raw patch · 11 files changed
+443/−205 lines, 11 filesdep +QuickCheckdep +bytestringdep +hostname
Dependencies added: QuickCheck, bytestring, hostname, libxml, old-locale, time, xml
Files
- Test/Framework/Runners/Console.hs +17/−109
- Test/Framework/Runners/Console/Run.hs +107/−0
- Test/Framework/Runners/Console/Statistics.hs +2/−57
- Test/Framework/Runners/Core.hs +15/−12
- Test/Framework/Runners/Options.hs +6/−3
- Test/Framework/Runners/Statistics.hs +99/−0
- Test/Framework/Runners/ThreadPool.hs +1/−2
- Test/Framework/Runners/XML.hs +48/−0
- Test/Framework/Runners/XML/JUnitWriter.hs +108/−0
- Test/Framework/Tests.hs +5/−2
- test-framework.cabal +35/−20
Test/Framework/Runners/Console.hs view
@@ -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
+ Test/Framework/Runners/Console/Run.hs view
@@ -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
Test/Framework/Runners/Console/Statistics.hs view
@@ -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: --
Test/Framework/Runners/Core.hs view
@@ -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)
Test/Framework/Runners/Options.hs view
@@ -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 }
+ Test/Framework/Runners/Statistics.hs view
@@ -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
Test/Framework/Runners/ThreadPool.hs view
@@ -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)
+ Test/Framework/Runners/XML.hs view
@@ -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+ }
+ Test/Framework/Runners/XML/JUnitWriter.hs view
@@ -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 "<none>")++-- | 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
Test/Framework/Tests.hs view
@@ -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 ()
test-framework.cabal view
@@ -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