HUnit-Plus (empty) → 0.3.0
raw patch · 14 files changed
+2889/−0 lines, 14 filesdep +Cabaldep +basedep +bytestringsetup-changed
Dependencies added: Cabal, base, bytestring, cmdargs, containers, deepseq, directory, hashable, hexpat, hostname, old-locale, parsec, time, timeit
Files
- HUnit-Plus.cabal +58/−0
- LICENSE +27/−0
- Setup.hs +2/−0
- src/Test/HUnitPlus.hs +84/−0
- src/Test/HUnitPlus/Base.hs +608/−0
- src/Test/HUnitPlus/Execution.hs +268/−0
- src/Test/HUnitPlus/Filter.hs +377/−0
- src/Test/HUnitPlus/Legacy.hs +39/−0
- src/Test/HUnitPlus/Main.hs +438/−0
- src/Test/HUnitPlus/Reporting.hs +313/−0
- src/Test/HUnitPlus/Terminal.hs +47/−0
- src/Test/HUnitPlus/Text.hs +297/−0
- src/Test/HUnitPlus/XML.hs +230/−0
- test/RunTests.hs +101/−0
+ HUnit-Plus.cabal view
@@ -0,0 +1,58 @@+Name: HUnit-Plus+Category: Testing, Test+Version: 0.3.0+License: BSD3+License-File: LICENSE+Author: Eric McCorkle+Maintainer: Eric McCorkle <emc2@metricspace.net>+Stability: Beta+Synopsis: A test framework building on HUnit.+Homepage: https://github.com/emc2/HUnit-Plus+Bug-Reports: https://github.com/emc2/HUnit-Plus/issues+Copyright: Copyright (c) 2014 Eric McCorkle. All rights reserved.+Description:+ HUnit-Plus is a testing framework for Haskell that builds on the+ HUnit test framework. HUnit-Plus provides functions and operators+ for creating assertions and tests similar to those provided by the+ HUnit framework. Unlike HUnit, HUnit-Plus uses the same data+ structures as cabal's "Distribution.TestSuite" framework, allowing+ full compatibility with cabal's testing facilities.++ HUnit-Plus also provides expanded reporting capabilities, including+ the ability to generate JUnit-style XML reports, along with a very+ flexible mechanism for selecting which tests to be executed.+ Lastly, HUnit-Plus provides a wrapper which generates standalone+ test-execution programs from a set of test suites.+Build-type: Simple+Cabal-version: >= 1.16++Source-Repository head+ Type: git+ Location: git@github.com:emc2/HUnit-Plus.git++Test-Suite RunTests+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ Main-Is: RunTests.hs+ hs-source-dirs: src test+ build-depends: base >= 4.4.0 && < 5, Cabal >= 1.16.0, deepseq, hexpat, timeit,+ cmdargs, hashable, containers, time, old-locale, hostname,+ parsec, bytestring, directory+ ghc-options: -fhpc++Library+ default-language: Haskell2010+ hs-source-dirs: src+ build-depends: base >= 4.4.0 && < 5, Cabal >= 1.16.0, deepseq, hexpat, timeit,+ cmdargs, hashable, containers, time, old-locale, hostname,+ parsec, bytestring+ exposed-modules: Test.HUnitPlus.Base+ Test.HUnitPlus.Execution+ Test.HUnitPlus.Filter+ Test.HUnitPlus.Main+ Test.HUnitPlus.Legacy+ Test.HUnitPlus.Reporting+ Test.HUnitPlus.Terminal+ Test.HUnitPlus.Text+ Test.HUnitPlus.XML+ Test.HUnitPlus
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Eric McCorkle+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice, this+ list of conditions and the following disclaimer in the documentation and/or+ other materials provided with the distribution.++* Neither the name of the {organization} nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Test/HUnitPlus.hs view
@@ -0,0 +1,84 @@+-- | HUnit-Plus is a unit testing framework for Haskell, based on the+-- older HUnit framework.+--+-- To use HUnit-Plus, first import the module "Test.HUnitPlus":+--+-- > import Test.HUnitPlus+--+-- HUnit-Plus provides the same succinct syntax for defining test as+-- HUnit. However, HUnit-Plus tests use the data structures from+-- "Distribution.TestSuite" to describe tests, as opposed to the data+-- structures used by HUnit.+-- +-- > test1 = "test1" ~: (assertEqual "for (foo 3)," (1,2) (foo 3))+-- > test2 = "test2" ~: (do (x,y) <- partA 3+-- > assertEqual "for the first result of partA," 5 x+-- > b <- partB y+-- > assertBool ("(partB " ++ show y ++ ") failed") b)+--+-- You can also use the datatypes in "Distribution.TestSuite" to+-- define your tests, or import tests that were defined that way.+--+-- > test3 = Test (TestInstance { ... })+-- >+-- > testgroup1 = Group { ... }+--+-- Additionally, you can use the "Test.HUnitPlus.Legacy" module to+-- define tests in the old HUnit fashion. The test-creation operators+-- will convert them into HUnit-Plus tests.+--+-- > import qualified Test.HUnitPlus.Legacy as Legacy+-- > test4 = "test4" ~: Test (assertEqual "a == b" a b)+-- > testgroup2 = TestList [TestLabel "testFoo" testBar,+-- > TestLabel "testBar" testBar]+--+-- You can add tags to tests as well:+--+-- > test1Tags = testTags ["demo"] test1+-- > test5 = testNameTags "test5" ["demo"] (a @?= b)+--+-- You can also create groups of tests:+--+-- > testgroup3 = "group3" ~: [ test1, test2, testgroup1, test3 ]+--+-- At the top level, group tests into suites.+--+-- > suite = TestSuite { suiteName = "suite",+-- > suiteTests = [ testgroup3, test4 ],+-- > ... }+--+-- The 'createMain' function in "Test.HUnitPlus.Main" can be used to+-- easily define a @main@ for a test execution program.+--+-- > main = createMain suite+--+-- The resulting program has a number of options for executing tests+-- and reporting the results, which are documented in+-- "Test.HUnitPlus.Main", as well as in the program's \"usage\"+-- output. Briefly, you can execute all tests by running the program+-- without arguments.+--+-- > $> ./testprog+--+-- You can select tests to be run by supplying a filter:+--+-- > $> ./testprog group3.test1+-- > $> ./testprog @demo+--+-- You can also generate various kinds of reports, and control console+-- output:+--+-- > $> ./testprog --xmlreport --txtreport --consolemode=quiet --testlist=tests+--+-- You can also use the 'topLevel' function to supply options to test+-- execution and get the result, allowing limited integration with a+-- larger test execution framework. ("Test.HUnitPlus.Execution" has+-- even more options).+module Test.HUnitPlus(+ module Test.HUnitPlus.Base,+ module Test.HUnitPlus.Main+ ) where++import Test.HUnitPlus.Base+import Test.HUnitPlus.Main+
+ src/Test/HUnitPlus/Base.hs view
@@ -0,0 +1,608 @@+{-# OPTIONS_GHC -Wall -Werror -funbox-strict-fields #-}+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable #-}++-- | Basic definitions for the HUnitPlus library.+--+-- This module contains what you need to create assertions and test+-- cases and combine them into test suites.+--+-- The assertion and test definition operators are the same as those+-- found in the HUnit library. However, an important note is that the+-- behavior of assertions in HUnit-Plus differs from those in HUnit.+-- HUnit-Plus assertions do /not/ stop executing a test if they fail,+-- and are designed so that multiple assertions can be made by a+-- single test. HUnit-Plus contains several \"abort\" functions,+-- which can be used to terminate a test immediately.+--+-- HUnit-Plus test execution handles exceptions. An uncaught+-- exception will cause the test to report an error (along with any+-- failures and/or errors that have occurred so far), and test+-- execution and reporting will continue.+--+-- The data structures for describing tests are the same as those in+-- the "Distribution.TestSuite" module used by cabal's testing+-- facilities. This allows for easy interfacing with cabal's+-- @detailed@ testing scheme.+--+-- This gives rise to a grid possible use cases: creating a test using+-- the HUnit-Plus facilities vs. executing an existing+-- "Distribution.TestSuite" test which was not created by the+-- facilities in this module, and executing a test with HUnit-Plus vs+-- executing it with another test framework. The 'executeTest'+-- function is designed to cope with either possible origin of a test,+-- and the 'Testable' instances are designed to produce tests which+-- work as expected in either possible execution environment.+module Test.HUnitPlus.Base(+ -- * Test Definition+ Test(..),+ TestInstance(..),+ TestSuite(..),++ -- ** Extended Test Creation+ Testable(..),++ (~=?),+ (~?=),+ (~:),+ (~?),+++ -- * Assertions+ Assertion,+ assertSuccess,+ assertFailure,+ abortFailure,+ abortError,+ assertBool,+ assertString,+ assertStringWithPrefix,+ assertEqual,+ -- ** Extended Assertion Functionality+ Assertable(..),+ (@=?),+ (@?=),+ (@?),++ -- * Low-level Test Functions+ executeTest,+ logAssert,+ logFailure,+ logError,+ withPrefix,+ getErrors,+ getFailures+ ) where++import Control.Exception hiding (assert)+import Data.Foldable+import Data.IORef+import Data.Typeable+import Data.Word+import Distribution.TestSuite+import Prelude hiding (concat, sum, sequence_)+import System.IO.Unsafe+import System.TimeIt+import Test.HUnitPlus.Reporting++-- | An 'Exception' used to abort test execution immediately.+data TestException =+ TestException {+ -- | Whether this is a failure or an error.+ teError :: !Bool,+ -- | The failure (or error) message.+ teMsg :: !String+ } deriving (Show, Typeable)++instance Exception TestException++-- Test Wrapper Definition+-- =====================+data TestInfo =+ TestInfo {+ -- | Current counts of assertions, tried, failed, and errors.+ tiAsserts :: !Word,+ -- | Events that have been logged+ tiEvents :: ![(Word, String)],+ -- | Whether or not the result of the test computation is already+ -- reflected here. This is used to differentiate between black+ -- box test and tests we've built with these tools.+ tiIgnoreResult :: !Bool,+ -- | String to attach to every failure message as a prefix.+ tiPrefix :: !String+ }++errorCode :: Word+errorCode = 0++failureCode :: Word+failureCode = 1++sysOutCode :: Word+sysOutCode = 2++sysErrCode :: Word+sysErrCode = 3++{-# NOINLINE testinfo #-}+testinfo :: IORef TestInfo+testinfo = unsafePerformIO $ newIORef undefined++-- | Does the actual work of executing a test. This maintains the+-- necessary bookkeeping recording assertions and failures, It also+-- sets up exception handlers and times the test.+executeTest :: Reporter us+ -- ^ The reporter to use for reporting results.+ -> State+ -- ^ The HUnit internal state.+ -> us+ -- ^ The reporter state.+ -> IO Progress+ -- ^ The test to run.+ -> IO (Double, State, us)+executeTest rep @ Reporter { reporterCaseProgress = reportCaseProgress }+ ss usInitial runTest =+ let+ -- Run the test until a finished result is produced+ finishTestCase time us action =+ let+ handleExceptions :: SomeException -> IO Progress+ handleExceptions ex =+ case fromException ex of+ Just TestException { teError = True, teMsg = msg } ->+ do+ logError msg+ return (Finished (Error msg))+ Just TestException { teError = False, teMsg = msg } ->+ do+ logFailure msg+ return (Finished (Fail msg))+ Nothing ->+ do+ return (Finished (Error ("Uncaught exception in test: " +++ show ex)))++ caughtAction = catch action handleExceptions+ in do+ (inctime, progress) <- timeItT caughtAction+ case progress of+ Progress msg nextAction ->+ do+ usNext <- reportCaseProgress msg ss us+ finishTestCase (time + inctime) usNext nextAction+ Finished res -> return (res, us, time + inctime)+ in do+ resetTestInfo+ (res, usFinished, time) <- finishTestCase 0 usInitial runTest+ (ssReported, usReported) <- reportTestInfo res rep ss usFinished+ return (time, ssReported, usReported)++-- | Interface between invisible 'TestInfo' and the rest of the test+-- execution framework.+reportTestInfo :: Result -> Reporter us -> State -> us -> IO (State, us)+reportTestInfo result Reporter { reporterError = reportError,+ reporterFailure = reportFailure,+ reporterSystemOut = reportSystemOut,+ reporterSystemErr = reportSystemErr }+ ss @ State { stCounts = c @ Counts { cAsserts = asserts,+ cFailures = failures,+ cErrors = errors } }+ initialUs =+ let+ handleEvent (us, hasFailure, hasError) (code, msg)+ | code == errorCode =+ do+ us' <- reportError msg ss us+ return (us', hasFailure, True)+ | code == failureCode =+ do+ us' <- reportFailure msg ss us+ return (us', True, hasError)+ | code == sysOutCode =+ do+ us' <- reportSystemOut msg ss us+ return (us', hasFailure, hasError)+ | code == sysErrCode =+ do+ us' <- reportSystemErr msg ss us+ return (us', hasFailure, hasError)+ | otherwise = fail ("Internal error: bad code " ++ show code)+ in do+ TestInfo { tiAsserts = currAsserts,+ tiEvents = currEvents,+ tiIgnoreResult = ignoreRes } <- readIORef testinfo+ (eventsUs, hasFailure, hasError) <-+ foldlM handleEvent (initialUs, False, False) (reverse currEvents)+ case result of+ Error msg | not ignoreRes ->+ do+ finalUs <- reportError msg ss eventsUs+ return $! (ss { stCounts =+ c { cAsserts = asserts + fromIntegral currAsserts,+ cErrors = errors + 1 } },+ finalUs)+ Fail msg | not ignoreRes ->+ do+ finalUs <- reportFailure msg ss eventsUs+ return $! (ss { stCounts =+ c { cAsserts = asserts + fromIntegral currAsserts,+ cFailures = failures + 1 } },+ finalUs)+ _ -> return $! (ss { stCounts =+ c { cAsserts = asserts + fromIntegral currAsserts,+ cFailures =+ if hasFailure+ then failures + 1+ else failures,+ cErrors =+ if hasError+ then errors + 1+ else errors } },+ eventsUs)++-- | Indicate that the result of a test is already reflected in the testinfo.+ignoreResult :: IO ()+ignoreResult = modifyIORef testinfo (\t -> t { tiIgnoreResult = True })++resetTestInfo :: IO ()+resetTestInfo = writeIORef testinfo TestInfo { tiAsserts = 0,+ tiEvents = [],+ tiIgnoreResult = False,+ tiPrefix = "" }++-- | Execute the given computation with a message prefix.+withPrefix :: String -> IO () -> IO ()+withPrefix prefix c =+ do+ t @ TestInfo { tiPrefix = oldprefix } <- readIORef testinfo+ writeIORef testinfo t { tiPrefix = prefix ++ oldprefix }+ c+ modifyIORef testinfo (\t' -> t' { tiPrefix = oldprefix })++-- | Record that one assertion has been checked.+logAssert :: IO ()+logAssert = modifyIORef testinfo (\t -> t { tiAsserts = tiAsserts t + 1 })++-- | Record an error, along with a message.+logError :: String -> IO ()+logError msg =+ modifyIORef testinfo (\t -> t { tiEvents = (errorCode, tiPrefix t ++ msg) :+ tiEvents t })++-- | Record a failure, along with a message.+logFailure :: String -> IO ()+logFailure msg =+ modifyIORef testinfo (\t -> t { tiEvents = (failureCode, tiPrefix t ++ msg) :+ tiEvents t })++-- | Get a combined failure message, if there is one.+getFailures :: IO (Maybe String)+getFailures =+ do+ TestInfo { tiEvents = events } <- readIORef testinfo+ case map snd (filter ((== failureCode) . fst) events) of+ [] -> return $ Nothing+ fails -> return $ (Just (concat (reverse fails)))++-- | Get a combined failure message, if there is one.+getErrors :: IO (Maybe String)+getErrors =+ do+ TestInfo { tiEvents = events } <- readIORef testinfo+ case map snd (filter ((== errorCode) . fst) events) of+ [] -> return $ Nothing+ errors -> return $ (Just (concat (reverse errors)))++-- Assertion Definition+-- ====================++type Assertion = IO ()++-- Conditional Assertion Functions+-- -------------------------------++-- | Unconditionally signal that a failure has occurred. This will+-- not stop execution, but will record the failure, resulting in a+-- failed test.+assertFailure :: String+ -- ^ The failure message+ -> Assertion+assertFailure msg = logAssert >> logFailure msg++-- | Signal that an assertion succeeded. This will log that an+-- assertion has been made.+assertSuccess :: Assertion+assertSuccess = logAssert++-- | Signal than an error has occurred and stop the test immediately.+abortError :: String -> Assertion+abortError msg = throw TestException { teError = True, teMsg = msg }++-- | Signal that a failure has occurred and stop the test immediately.+-- Note that if an error has been logged already, the test will be+-- reported as an error.+abortFailure :: String -> Assertion+abortFailure msg = throw TestException { teError = False, teMsg = msg }++-- | Asserts that the specified condition holds.+assertBool :: String+ -- ^ The message that is displayed if the assertion fails+ -> Bool+ -- ^ The condition+ -> Assertion+assertBool msg b = if b then assertSuccess else assertFailure msg++-- | Signals an assertion failure if a non-empty message (i.e., a message+-- other than @\"\"@) is passed.+assertString :: String+ -- ^ The message that is displayed with the assertion failure + -> Assertion+assertString = assertStringWithPrefix ""++-- | Signals an assertion failure if a non-empty message (i.e., a+-- message other than @\"\"@) is passed. Allows a prefix to be+-- supplied for the assertion failure message.+assertStringWithPrefix :: String+ -- ^ Prefix to attach to the string if not null+ -> String+ -- ^ String to assert is null+ -> Assertion+assertStringWithPrefix prefix s = assertBool (prefix ++ s) (null s)++-- | Asserts that the specified actual value is equal to the expected value.+-- The output message will contain the prefix, the expected value, and the +-- actual value.+-- +-- If the prefix is the empty string (i.e., @\"\"@), then the prefix is omitted+-- and only the expected and actual values are output.+assertEqual :: (Eq a, Show a)+ => String+ -- ^ The message prefix+ -> a+ -- ^ The expected value + -> a+ -- ^ The actual value+ -> Assertion+assertEqual preface expected actual =+ let+ msg = (if null preface then "" else preface ++ "\n") +++ "expected: " ++ show expected ++ "\nbut got: " ++ show actual+ in+ assertBool msg (actual == expected)++-- Overloaded `assert` Function+-- ----------------------------++-- | Allows the extension of the assertion mechanism.+-- +-- Since an 'Assertion' can be a sequence of @Assertion@s and @IO@+-- actions, there is a fair amount of flexibility of what can be+-- achieved. As a rule, the resulting 'Assertion' should not assert+-- multiple, independent conditions.+-- +-- If more complex arrangements of assertions are needed, 'Test's and+-- 'Testable' should be used.+class Assertable t where+ -- | Assertion with a failure message+ assertWithMsg :: String -> t -> Assertion++ -- | Assertion with no failure message+ assert :: t -> Assertion+ assert = assertWithMsg ""++instance Assertable () where+ assertWithMsg _ = return++instance Assertable Bool where+ assertWithMsg msg = assertBool msg++instance Assertable Result where+ assertWithMsg _ Pass = assertSuccess+ assertWithMsg "" (Error errstr) = logError errstr+ assertWithMsg prefix (Error errstr) = logError (prefix ++ errstr)+ assertWithMsg "" (Fail failstr) = assertFailure failstr+ assertWithMsg prefix (Fail failstr) = assertFailure (prefix ++ failstr)++instance Assertable Progress where+ assertWithMsg msg (Progress _ cont) = assertWithMsg msg cont+ assertWithMsg msg (Finished res) = assertWithMsg msg res++instance (ListAssertable t) => Assertable [t] where+ assertWithMsg msg = listAssert msg++instance (Assertable t) => Assertable (IO t) where+ assertWithMsg msg t = t >>= assertWithMsg msg++-- | A specialized form of 'Assertable' to handle lists.+class ListAssertable t where+ listAssert :: String -> [t] -> Assertion++instance ListAssertable Char where+ listAssert msg = assertStringWithPrefix msg++instance ListAssertable Assertion where+ listAssert msg asserts = withPrefix msg (sequence_ asserts)++-- Assertion Construction Operators+-- --------------------------------++infix 1 @?, @=?, @?=++-- | Shorthand for 'assertBool'.+(@?) :: (Assertable t) =>+ t+ -- ^ A value of which the asserted condition is predicated+ -> String+ -- ^ A message that is displayed if the assertion fails+ -> Assertion+predi @? msg = assertWithMsg msg predi++-- | Asserts that the specified actual value is equal to the expected value+-- (with the expected value on the left-hand side).+(@=?) :: (Eq a, Show a)+ => a+ -- ^ The expected value+ -> a+ -- ^ The actual value+ -> Assertion+expected @=? actual = assertEqual "" expected actual++-- | Asserts that the specified actual value is equal to the expected value+-- (with the actual value on the left-hand side).+(@?=) :: (Eq a, Show a)+ => a+ -- ^ The actual value+ -> a+ -- ^ The expected value+ -> Assertion+actual @?= expected = assertEqual "" expected actual++-- Test Definition+-- ===============++-- | Definition for a test suite. This is intended to be a top-level+-- (ie. non-nestable) container for tests. Test suites have a name, a+-- list of options with default values (which can be overridden either+-- at runtime or statically using 'ExtraOptions'), and a set of+-- 'Test's to be run.+--+-- Individual tests are described using definitions found in cabal's+-- "Distribution.TestSuite" module, to allow for straightforward+-- integration with cabal testing facilities.+data TestSuite =+ TestSuite {+ -- | The name of the test suite.+ suiteName :: !String,+ -- | Whether or not to run the tests concurrently.+ suiteConcurrently :: !Bool,+ -- | A list of all options used by this suite, and the default+ -- values for those options.+ suiteOptions :: [(String, String)],+ -- | The tests in the suite.+ suiteTests :: [Test]+ }++-- Overloaded `test` Function+-- --------------------------++{-# NOINLINE syntheticName #-}+syntheticName :: String+syntheticName = "__synthetic__"+{-+handleException :: SomeException -> IO ()+handleException e = logError ("Exception occurred during test:\n" ++ show e)+-}+wrapTest :: IO a -> IO Progress+wrapTest t =+ do+ ignoreResult+ _ <- t+ checkTestInfo++checkTestInfo :: IO Progress+checkTestInfo =+ do+ errors <- getErrors+ case errors of+ Nothing ->+ do+ failures <- getFailures+ case failures of+ Nothing -> return $ (Finished Pass)+ Just failstr -> return $ (Finished (Fail failstr))+ Just errstr -> return $ (Finished (Error errstr))++-- | Provides a way to convert data into a @Test@ or set of @Test@.+class Testable t where+ -- | Create a test with a given name and tag set from a @Testable@ value+ testNameTags :: String -> [String] -> t -> Test++ -- | Create a test with a given name and no tags from a @Testable@ value+ testName :: String -> t -> Test+ testName testname t = testNameTags testname [] t++ -- | Create a test with a given name and no tags from a @Testable@ value+ testTags :: [String] -> t -> Test+ testTags tagset t = testNameTags syntheticName tagset t++ -- | Create a test with a synthetic name and no tags from a @Testable@ value+ test :: Testable t => t -> Test+ test t = testNameTags syntheticName [] t++instance Testable Test where+ testNameTags newname newtags g @ Group { groupTests = testlist } =+ g { groupName = newname, groupTests = map (testTags newtags) testlist }+ testNameTags newname newtags (Test t @ TestInstance { tags = oldtags }) =+ Test t { name = newname, tags = newtags ++ oldtags }+ testNameTags newname newtags (ExtraOptions opts t) =+ ExtraOptions opts (testNameTags newname newtags t)++ testTags newtags g @ Group { groupTests = testlist } =+ g { groupTests = map (testTags newtags) testlist }+ testTags newtags (Test t @ TestInstance { tags = oldtags }) =+ Test t { tags = newtags ++ oldtags }+ testTags newtags (ExtraOptions opts t) =+ ExtraOptions opts (testTags newtags t)++ testName newname g @ Group {} = g { groupName = newname }+ testName newname (Test t) = Test t { name = newname }+ testName newname (ExtraOptions opts t) =+ ExtraOptions opts (testName newname t)++ test = id++instance (Assertable t) => Testable (IO t) where+ testNameTags testname testtags t =+ Test TestInstance { name = testname, tags = testtags,+ run = wrapTest (t >>= assert),+ options = [], setOption = undefined }++instance (Testable t) => Testable [t] where+ testNameTags testname testtags ts =+ Group { groupName = testname, groupTests = map (testTags testtags) ts,+ concurrently = True }++-- Test Construction Operators+-- ---------------------------++infix 1 ~?, ~=?, ~?=+infixr 0 ~:++-- | Creates a test case resulting from asserting the condition obtained +-- from the specified 'AssertionPredicable'.+(~?) :: (Assertable t)+ => t+ -- ^ A value of which the asserted condition is predicated+ -> String+ -- ^ A message that is displayed on test failure+ -> Test+predi ~? msg = test (predi @? msg)++-- | Shorthand for a test case that asserts equality (with the expected +-- value on the left-hand side, and the actual value on the right-hand+-- side).+(~=?) :: (Eq a, Show a)+ => a+ -- ^ The expected value + -> a+ -- ^ The actual value+ -> Test+expected ~=? actual = test (expected @=? actual)++-- | Shorthand for a test case that asserts equality (with the actual +-- value on the left-hand side, and the expected value on the right-hand+-- side).+(~?=) :: (Eq a, Show a)+ => a+ -- ^ The actual value+ -> a+ -- ^ The expected value + -> Test+actual ~?= expected = test (actual @?= expected)++-- | Creates a test from the specified 'Testable', with the specified +-- label attached to it.+-- +-- Since 'Test' is @Testable@, this can be used as a shorthand way of+-- attaching a 'TestLabel' to one or more tests.+(~:) :: (Testable t) => String -> t -> Test+label ~: t = testName label t
+ src/Test/HUnitPlus/Execution.hs view
@@ -0,0 +1,268 @@+{-# OPTIONS_GHC -Wall -Werror #-}++-- | Functions for executing test cases, test paths, and test suites.+-- These functions are provided for the sake of convenience and+-- testing; however, the preferred way of using HUnit-Plus is to use+-- the "Test.HUnitPlus.Main#createMain" to create a test program+-- directly from a list of test suites.+module Test.HUnitPlus.Execution(+ performTestCase,+ performTest,+ performTestSuite,+ performTestSuites+ ) where++import Control.Monad (unless, foldM)+import Distribution.TestSuite+import Data.Map(Map)+import Prelude hiding (elem)+import System.TimeIt+import Test.HUnitPlus.Base+import Test.HUnitPlus.Filter+import Test.HUnitPlus.Reporting++import qualified Data.Set as Set+import qualified Data.Map as Map++-- | Execute an individual test case.+performTestCase :: Reporter us+ -- ^ Report generator for the test run.+ -> State+ -- ^ HUnit-Plus internal state.+ -> us+ -- ^ State for the report generator.+ -> TestInstance+ -- ^ The test to be executed.+ -> IO (State, us)+performTestCase rep @ Reporter { reporterStartCase = reportStartCase,+ reporterError = reportError,+ reporterEndCase = reportEndCase }+ ss @ State { stCounts = c @ Counts { cTried = tried,+ cCases = cases },+ stName = oldname, stOptions = optmap,+ stOptionDescs = descs } initialUs+ initTi @ TestInstance { name = testname,+ options = testdescs,+ setOption = setopt } =+ let+ -- First, apply all the options+ alldescs = testdescs ++ descs+ -- Add the name to the state we use to run the tests++ -- Update the state before running+ ssWithName = ss { stName = testname, stCounts = c { cTried = tried + 1,+ cCases = cases + 1 } }++ -- Fold function for applying options+ applyOptions (us, ti) OptionDescr { optionName = optname,+ optionDefault = def } =+ let+ setresult :: Either String TestInstance+ setresult =+ case Map.lookup optname optmap of+ Just optval -> setopt optname optval+ Nothing -> case def of+ Just optval -> setopt optname optval+ Nothing -> Right ti+ in case setresult of+ Left errmsg ->+ do+ newUs <- reportError errmsg ssWithName us+ return $! (newUs, ti)+ Right newTi -> return $! (us, newTi)+ in do+ -- Get all the rest of the information from the resulting test instance+ (usOpts, TestInstance { run = runTest }) <-+ foldM applyOptions (initialUs, initTi) alldescs+ -- Call the reporter's start case function+ usStarted <- reportStartCase ssWithName usOpts+ -- Actually run the test+ (time, ssFinal, usFinal) <- executeTest rep ssWithName usStarted runTest+ -- Call the reporters end case function+ usEnded <- reportEndCase time ssFinal usFinal+ -- Restore the old name before returning+ return $ (ssFinal { stName = oldname }, usEnded)++-- | Log a skipped test case.+skipTestCase :: Reporter us+ -- ^ Report generator for the test run.+ -> State+ -- ^ HUnit-Plus internal state.+ -> us+ -- ^ State for the report generator.+ -> TestInstance+ -- ^ The test to be executed.+ -> IO (State, us)+skipTestCase Reporter { reporterSkipCase = reportSkipCase }+ ss @ State { stCounts = c @ Counts { cSkipped = skipped,+ cCases = cases },+ stName = oldname } us+ TestInstance { name = testname } =+ let+ ss' = ss { stCounts = c { cSkipped = skipped + 1, cCases = cases + 1 },+ stName = testname }+ in do+ us' <- reportSkipCase ss' us+ return $! (ss' { stName = oldname }, us')++-- | Execute a given test (which may be a group), with the specified+-- selector and report generators. Only tests which match the+-- selector will be executed. The rest will be logged as skipped.+performTest :: Reporter us+ -- ^ Report generator for the test run.+ -> Selector+ -- ^ The selector to apply to all tests in the suite.+ -> State+ -- ^ HUnit-Plus internal state.+ -> us+ -- ^ State for the report generator.+ -> Test+ -- ^ The test to be executed.+ -> IO (State, us)+performTest rep initSelector initState initialUs initialTest =+ let+ -- The recursive worker function that actually runs all the tests+ --+ -- We need to actually run through all the tests, so we can record+ -- the ones we skip. So we keep a Maybe Selector, where Nothing+ -- represents tests that aren't actually going to be executed.+ --+ -- We also have to keep a set of tags by which we're filtering.+ -- The empty tag set means we don't actually filter at all.+ performTest' Selector { selectorInners = inners, selectorTags = currtags }+ ss us Group { groupTests = testlist, groupName = gname } =+ let+ -- Build the new selector+ selector' =+ -- Try looking up the group in the inners+ case Map.lookup gname inners of+ -- If we don't find anything, we can only keep executing+ -- if our tag state allows it.+ Nothing -> Selector { selectorInners = Map.empty,+ selectorTags = currtags }+ -- Otherwise, combine the inner's tag state with ours and+ -- carry on.+ Just inner @ Selector { selectorTags = innertags } ->+ inner { selectorTags = combineTags currtags innertags }++ -- Update the path for running the group's tests+ oldpath = stPath ss+ ssWithPath = ss { stPath = Label gname : oldpath }++ foldfun (ss', us') t = performTest' selector' ss' us' t+ in do+ -- Run the tests with the updated path+ (ssAfter, usAfter) <- foldM foldfun (ssWithPath, us) testlist+ -- Return the state, reset to the old path+ return $! (ssAfter { stPath = oldpath }, usAfter)+ performTest' Selector { selectorInners = inners, selectorTags = currtags }+ ss us (Test t @ TestInstance { name = testname,+ tags = testtags }) =+ let+ -- Get the final tag state+ finaltags =+ -- Try looking up the group in the inners+ case Map.lookup testname inners of+ -- If we don't find anything, we can only keep executing+ -- if our tag state allows it.+ Nothing -> currtags+ -- Otherwise, combine the inner's tag state with ours and+ -- carry on.+ Just Selector { selectorTags = innertags } ->+ combineTags currtags innertags+ -- Decide if we can execute the test+ canExecute =+ case finaltags of+ Nothing -> False+ Just set+ | set == Set.empty -> True+ | otherwise -> any (\tag -> Set.member tag set) testtags+ in+ if canExecute+ then performTestCase rep ss us t+ else skipTestCase rep ss us t+ performTest' selector ss @ State { stOptionDescs = descs }+ us (ExtraOptions newopts inner) =+ performTest' selector ss { stOptionDescs = descs ++ newopts } us inner+ in do+ (ss', us') <- performTest' initSelector initState initialUs initialTest+ unless (null (stPath ss')) $ error "performTest: Final path is nonnull"+ return $! (ss', us')++-- | Decide whether to execute a test suite based on a map from suite+-- names to selectors. If the map contains a selector for the test+-- suite, execute all tests matching the selector, and log the rest as+-- skipped. If the map does not contain a selector, do not execute+-- the suite, and do /not/ log its tests as skipped.+performTestSuite :: Reporter us+ -- ^ Report generator to use for running the test suite.+ -> Map String Selector+ -- ^ The map containing selectors for each suite.+ -> us+ -- ^ State for the report generator.+ -> TestSuite+ -- ^ Test suite to be run.+ -> IO (Counts, us)+performTestSuite rep @ Reporter { reporterStartSuite = reportStartSuite,+ reporterEndSuite = reportEndSuite }+ filters initialUs+ TestSuite { suiteName = sname, suiteTests = testlist,+ suiteOptions = suiteOpts } =+ case Map.lookup sname filters of+ Just selector ->+ let+ initState = State { stCounts = zeroCounts, stName = sname,+ stPath = [], stOptions = Map.fromList suiteOpts,+ stOptionDescs = [] }++ foldfun (c, us) testcase = performTest rep selector c us testcase+ in do+ startedUs <- reportStartSuite initState initialUs+ (time, (finishedState, finishedUs)) <-+ timeItT (foldM foldfun (initState, startedUs) testlist)+ endedUs <- reportEndSuite time finishedState finishedUs+ return $! (stCounts finishedState, endedUs)+ _ ->+ return $! (Counts { cCases = 0, cTried = 0, cErrors = 0, cFailures = 0,+ cAsserts = 0, cSkipped = 0 }, initialUs)++-- | Top-level function for a test run. Given a set of suites and a+-- map from suite names to selectors, execute all suites that have+-- selectors. For any test suite, only the tests specified by its+-- selector will be executed; the rest will be logged as skipped.+-- Suites that do not have a selector will be omitted entirely, and+-- their tests will /not/ be logged as skipped.+performTestSuites :: Reporter us+ -- ^ Report generator to use for running the test suite.+ -> Map String Selector+ -- ^ The processed filter to use.+ -> [TestSuite]+ -- ^ Test suite to be run.+ -> IO (Counts, us)+performTestSuites rep @ Reporter { reporterStart = reportStart,+ reporterEnd = reportEnd }+ filters suites =+ let+ initialCounts = Counts { cCases = 0, cTried = 0, cErrors = 0,+ cFailures = 0, cAsserts = 0, cSkipped = 0 }++ combineCounts Counts { cCases = cases1, cTried = tried1,+ cErrors = errors1, cFailures = failures1,+ cAsserts = asserts1, cSkipped = skipped1 }+ Counts { cCases = cases2, cTried = tried2,+ cErrors = errors2, cFailures = failures2,+ cAsserts = asserts2, cSkipped = skipped2 } =+ Counts { cCases = cases1 + cases2, cTried = tried1 + tried2,+ cErrors = errors1 + errors2, cFailures = failures1 + failures2,+ cAsserts = asserts1 + asserts2, cSkipped = skipped1 + skipped2 }++ foldfun (accumCounts, accumUs) suite =+ do+ (suiteCounts, suiteUs) <- performTestSuite rep filters accumUs suite+ return $! (combineCounts accumCounts suiteCounts, suiteUs)+ in do+ initialUs <- reportStart+ (time, (finishedCounts, finishedUs)) <-+ timeItT (foldM foldfun (initialCounts, initialUs) suites)+ endedUs <- reportEnd time finishedCounts finishedUs+ return $! (finishedCounts, endedUs)
+ src/Test/HUnitPlus/Filter.hs view
@@ -0,0 +1,377 @@+{-# OPTIONS_GHC -Wall -Werror -funbox-strict-fields #-}++-- | Sets HUnit-Plus tests can be specified using 'Filter's. These+-- are used by "Test.HUnitPlus.Execution" and "Test.HUnitPlus.Main" to+-- select which tests are run. Filters can specify tests belonging to+-- a certain suite, starting with a certain path, having a certain+-- tag, or combinations thereof.+--+-- Filters are optimized for the behavior of programs created by the+-- 'createMain' function, which runs a test if it matches /any/ of the+-- filters specified. There is also a string format for filters,+-- which is how filters are specified in testlist files and+-- command-line arguments. The format is optimized for simplicity,+-- and as such, it is not necessarily possible to describe a given+-- "Filter" with a single textual representation of a filter.+--+-- The format for filters is as follows:+--+-- \[/suite/\]\[/path/\]\[/tags/\]+--+-- Where at least one of the /suite/, /path/, or /tags/ elements are present+--+-- The /suite/ element is a comma-separated list of suite names (alphanumeric,+-- no spaces), enclosed in brackets ('[' ']').+--+-- The /path/ element is a series of path elements (alphanumeric, no+-- spaces), separated by dots ('.').+--+-- The /tags/ element consists of a '\@' character, followed by a+-- comma-separated list of tag names (alphanumeric, no spaces).+--+-- The following are examples of textual filters, and their meanings:+--+-- * @first.second.third@: Run all tests starting with the path+-- @first.second.third@. If there is a test named+-- @first.second.third@, it will be run.+--+-- * @[unit]@: Run all tests in the suite 'unit'.+--+-- * @[unit,stress]@: Run all tests in the suites 'unit' and 'stress'+--+-- * @\@parser@: Run all tests with the 'parser' tag+--+-- * @\@parser,lexer@: Run all tests with the 'parser' /or/ the 'lexer' tags.+--+-- * @backend.codegen\@asm@: Run all tests starting with the path+-- @backend.codegen@ with the 'asm' tag.+--+-- * @[stress]\@net@: Run all tests in the 'stress' suite with the tag 'net'.+--+-- * @[perf,profile]inner.outer@: Run all tests in the 'perf' and+-- 'profile' suites that start with the path @inner.outer@.+--+-- * @[whitebox]network.protocol\@security@: Run all tests in the+-- 'whitebox' suite beginning with the path @network.protocol@ that+-- have the 'security' tag.+--+-- The most common use case of filters is to select a single failing+-- test to run, as part of fixing it. In this case, a single filter+-- consisting of the path to the test will have this effect.+module Test.HUnitPlus.Filter(+ Selector(..),+ Filter(..),+ combineTags,+ passFilter,+ allSelector,+ combineSelectors,+ suiteSelectors,+ parseFilter,+ parseFilterFile,+ parseFilterFileContent+ ) where++import Control.Exception+import Data.Foldable(foldl)+import Data.Either+import Data.Map(Map)+import Data.Maybe+import Data.Set(Set)+import Prelude hiding (foldl, elem)+import System.IO.Error+import Text.ParserCombinators.Parsec hiding (try)++import qualified Data.Set as Set+import qualified Data.Map as Map++-- | A tree-like structure that represents a set of tests within a+-- given suite.+data Selector =+ Selector {+ -- | @Selector@s for subgroups of this one. The entry for each+ -- path element contains the @Selector@ to be used for that+ -- group (or test). An empty map actually means 'select all+ -- tests'.+ selectorInners :: Map String Selector,+ -- | Tags by which to filter all tests. The empty set actually+ -- means 'run all tests regardless of tags'. 'Nothing' means+ -- that all tests will be skipped (though this will be+ -- overridden by any @Selector@s in @selectorInners@.+ selectorTags :: !(Maybe (Set String))+ }+ deriving (Eq, Ord, Show)++-- | Specifies zero or more test suites, to which the given 'Selector'+-- is then applied. If no test suites are specified, then the+-- 'Selector' applies to all test suites.+data Filter =+ Filter {+ -- | The test suites to which the 'Selector' applies. The empty+ -- set actually means 'all suites'.+ filterSuites :: !(Set String),+ -- | The 'Selector' to apply.+ filterSelector :: !Selector+ }+ deriving (Ord, Eq, Show)++-- | Combine two 'selectorTags' fields into one. This operation represents the+-- union of the tests that are selected by the two fields.+combineTags :: Maybe (Set String) -> Maybe (Set String) -> Maybe (Set String)+-- Nothing means we can't execute, so if the other side says we can,+-- we can.+combineTags Nothing t = t+combineTags t Nothing = t+combineTags (Just a) (Just b)+ -- The empty set means we execute everything, so it absorbs+ | a == Set.empty || b == Set.empty = Just $! Set.empty+ -- Otherwise, we do set union+ | otherwise = Just $! Set.union a b++-- | Take the difference of one set of tags from another.+diffTags :: Maybe (Set String) -> Maybe (Set String) -> Maybe (Set String)+-- Nothing means we can't execute, so if the other side says we can,+-- we can.+diffTags Nothing _ = Nothing+diffTags t Nothing = t+diffTags (Just a) (Just b)+ | a == Set.empty = Just Set.empty+ | b == Set.empty = Nothing+ -- Otherwise, we do set union+ | otherwise =+ let+ diff = Set.difference a b+ in+ if diff == Set.empty+ then Nothing+ else Just $! diff++-- | A 'Filter' that selects all tests in all suites.+passFilter :: Filter+passFilter = Filter { filterSuites = Set.empty, filterSelector = allSelector }++-- | A 'Selector' that selects all tests.+allSelector :: Selector+allSelector = Selector { selectorInners = Map.empty,+ selectorTags = Just Set.empty }++reduceSelector :: Maybe (Set String) -> Selector -> Maybe Selector+reduceSelector parentTags Selector { selectorInners = inners,+ selectorTags = tags } =+ let+ newTags = diffTags tags parentTags+ newParentTags = combineTags parentTags tags+ newInners = Map.mapMaybe (reduceSelector newParentTags) inners+ in+ if newTags == Nothing && newInners == Map.empty+ then Nothing+ else Just $! Selector { selectorInners = inners, selectorTags = tags }++-- | Combine two 'Selector's into a single 'Selector'.+combineSelectors :: Selector -> Selector -> Selector+combineSelectors selector1 selector2 =+ let+ combineSelectors' :: Maybe (Set String) -> Selector -> Selector ->+ Maybe Selector+ combineSelectors' parentTags+ s1 @ Selector { selectorInners = inners1,+ selectorTags = tags1 }+ s2 @ Selector { selectorInners = inners2,+ selectorTags = tags2 }+ | s1 == allSelector || s2 == allSelector = Just allSelector+ | otherwise =+ let+ combinedTags = combineTags tags1 tags2+ newTags = diffTags combinedTags parentTags+ newParentTags = combineTags combinedTags parentTags++ firstpass :: Map String Selector -> String -> Selector ->+ Map String Selector+ firstpass accum elem inner =+ case Map.lookup elem inners1 of+ Just inner' -> case combineSelectors' newParentTags inner inner' of+ Just entry -> Map.insert elem entry accum+ Nothing -> accum+ Nothing -> case reduceSelector newParentTags inner of+ Just entry -> Map.insert elem entry accum+ Nothing -> accum++ secondpass :: Map String Selector -> String -> Selector ->+ Map String Selector+ secondpass accum elem inner =+ case Map.lookup elem accum of+ Nothing -> case reduceSelector newParentTags inner of+ Just entry -> Map.insert elem entry accum+ Nothing -> accum+ Just _ -> accum++ firstPassMap = Map.foldlWithKey firstpass Map.empty inners2+ newInners = Map.foldlWithKey secondpass firstPassMap inners1+ in+ if newTags == Nothing && newInners == Map.empty+ then Nothing+ else Just $! Selector { selectorInners = newInners,+ selectorTags = newTags }+ in+ case combineSelectors' Nothing selector1 selector2 of+ Just out -> out+ Nothing -> error ("Got Nothing back from combineSelectors " +++ show selector1 ++ " " ++ show selector2)++-- | Collect all the selectors from filters that apply to all suites.+collectUniversals :: Filter -> Set Selector -> Set Selector+collectUniversals Filter { filterSuites = suites,+ filterSelector = selector } accum+ | suites == Set.empty = Set.insert selector accum+ | otherwise = accum++-- | Build a map from suite names to the selectors that get run on them.+collectSelectors :: Filter+ -- ^ The current filter+ -> Map String (Set Selector)+ -- ^ The map from suites to + -> Map String (Set Selector)+collectSelectors Filter { filterSuites = suites, filterSelector = selector }+ suitemap =+ foldl (\suitemap' suite -> Map.insertWith Set.union suite+ (Set.singleton selector)+ suitemap')+ suitemap suites++-- | Take a list of test suite names and a list of 'Filter's, and+-- build a 'Map' that says for each test suite, what (combined)+-- 'Selector' should be used to select tests.+suiteSelectors :: [String]+ -- ^ The names of all test suites.+ -> [Filter]+ -- ^ The list of 'Filter's from which to build the map.+ -> Map String Selector+suiteSelectors allsuites filters+ -- Short-circuit case if we have no filters, we run everything+ | filters == [] =+ foldl (\suitemap suite -> Map.insert suite allSelector suitemap)+ Map.empty allsuites+ | otherwise =+ let+ -- First, pull out all the universals+ universals = foldr collectUniversals Set.empty filters+ -- If we have any universals, then seed the initial map with them,+ -- otherwise, use the empty map.+ initMap =+ if universals /= Set.empty+ then foldl (\suitemap suite -> Map.insert suite universals suitemap)+ Map.empty allsuites+ else Map.empty++ -- Now collect all the suite-specific selectors+ suiteMap :: Map String (Set Selector)+ suiteMap = foldr collectSelectors initMap filters+ in+ Map.map (foldl1 combineSelectors . Set.elems) suiteMap++namesParser :: GenParser Char st [String]+namesParser = sepBy1 (many1 alphaNum) (string ",")++pathParser :: GenParser Char st [String]+pathParser = sepBy (many1 alphaNum) (string ".")++suitesParser :: GenParser Char st [String]+suitesParser = between (string "[") (string "]") namesParser++tagsParser :: GenParser Char st [String]+tagsParser = char '@' >> namesParser++filterParser :: GenParser Char st ([String], [String], [String])+filterParser =+ do+ suites <- option [] (suitesParser)+ path <- pathParser+ tagselector <- option [] tagsParser+ return (suites, path, tagselector)++makeFilter :: ([String], [String], [String]) -> Filter+makeFilter (suites, path, tags) =+ let+ withTags = case tags of+ [] -> allSelector+ _ -> allSelector { selectorTags = Just $! Set.fromList tags }++ genPath [] = withTags+ genPath (elem : rest) =+ Selector { selectorInners = Map.singleton elem $! genPath rest,+ selectorTags = Nothing }++ withPath = genPath path+ in+ Filter { filterSuites = Set.fromList suites, filterSelector = withPath }++-- | Parse a 'Filter' expression. The format for filter expressions is+-- described in the module documentation.+parseFilter :: String+ -- ^ The name of the source.+ -> String+ -- ^ The input.+ -> Either String Filter+parseFilter sourcename input =+ case parse filterParser sourcename input of+ Left e -> Left (show e)+ Right res -> Right (makeFilter res)++commentParser :: GenParser Char st ()+commentParser =+ do+ _ <- char '#'+ _ <- many (noneOf "\n")+ return $ ()++lineParser :: GenParser Char st (Maybe Filter)+lineParser =+ do+ _ <- many space+ content <- filterParser+ _ <- many space+ optional commentParser+ case content of+ ([], [], []) -> return $ Nothing+ _ -> return $ (Just (makeFilter content))++-- | Parse content from a testlist file. The file must contain one+-- filter per line. Leading and trailing spaces are ignored, as are+-- lines that contain no filter. A @\#@ will cause the parser to skip+-- the rest of the line.+parseFilterFileContent :: String+ -- ^ The name of the input file.+ -> String+ -- ^ The file content.+ -> Either [String] [Filter]+parseFilterFileContent sourcename input =+ let+ inputlines = lines input+ results = map (parse lineParser sourcename) inputlines+ in case partitionEithers results of+ ([], maybes) -> Right (catMaybes maybes)+ (errs, _) -> Left (map show errs)++-- | Given a 'FilePath', get the contents of the file and parse it as+-- a testlist file.+parseFilterFile :: FilePath -> IO (Either [String] [Filter])+parseFilterFile filename =+ do+ input <- try (readFile filename)+ case input of+ Left e+ | isAlreadyInUseError e ->+ return (Left ["Error reading testlist file " ++ filename +++ ": File is already in use"])+ | isDoesNotExistError e ->+ return (Left ["Error reading testlist file " ++ filename +++ ": File does not exist"])+ | isPermissionError e ->+ return (Left ["Error reading testlist file " ++ filename +++ ": Permission denied"])+ | otherwise ->+ return (Left ["Cannot read testlist file " ++ filename +++ ": Miscellaneous error"])+ Right contents ->+ case parseFilterFileContent filename contents of+ Left errs -> return (Left errs)+ Right out -> return (Right out)
+ src/Test/HUnitPlus/Legacy.hs view
@@ -0,0 +1,39 @@+{-# OPTIONS_GHC -Wall -Werror #-}++-- | The legacy test definitions for compatibility with the original+-- HUnit library. These are not guaranteed to be compatible for all+-- cases, but they should work for most. The 'Testable' instance+-- converts them into "Distribution.TestSuite" tests, with no tags.+--+-- These are deprecated in favor of the test definitions from the+-- Cabal "Distribution.TestSuite" module, plus the 'TestSuite'+-- definition in "Test.HUnitPlus.Base".+module Test.HUnitPlus.Legacy(+ Test(..)+ ) where++import Test.HUnitPlus.Base hiding (Test)++-- Test Definition+-- ===============++-- | The basic structure used to create an annotated tree of test cases.+data Test+ -- | A single, independent test case composed.+ = TestCase Assertion+ -- | A set of @Test@s sharing the same level in the hierarchy.+ | TestList [Test]+ -- | A name or description for a subtree of the @Test@s.+ | TestLabel String Test++instance Show Test where+ showsPrec _ (TestCase _) = showString "TestCase _"+ showsPrec _ (TestList ts) = showString "TestList " . showList ts+ showsPrec p (TestLabel l t) = showString "TestLabel " . showString l+ . showChar ' ' . showsPrec p t++instance Testable Test where+ testNameTags testname testtags (TestCase a) = testNameTags testname testtags a+ testNameTags testname testtags (TestList l) = testNameTags testname testtags l+ testNameTags _ testtags (TestLabel testname t) =+ testNameTags testname testtags t
+ src/Test/HUnitPlus/Main.hs view
@@ -0,0 +1,438 @@+{-# OPTIONS_GHC -Wall -Werror -funbox-strict-fields #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | A mostly-complete test selection and execution program for+-- running HUnit-Plus tests. The only thing missing are the actual+-- test suites, which are provided as parameters to 'createMain'.+--+-- Given a set of test suites, module can be used to create a test+-- execution program as follows:+--+-- >module Main(main) where+-- >+-- >import Test.HUnitPlus.Main+-- >import MyProgram.Tests(testsuites)+-- >+-- >main :: IO ()+-- >main = createMain testsuites+--+-- Where @testsuites@ is a list of 'TestSuite's.+-- +-- The resulting program, when executed with no arguments will execute+-- all test suites and write a summary to @stdout@. Additionally, the+-- test program has a number of options that control reporting and+-- test execution.+--+-- A summary of the options follows:+--+-- * @-c /mode/, --consolemode=/mode/@: Set the behavior of console+-- reporting to /mode/. Can be 'quiet', 'terminal', 'text', and+-- 'verbose'. Default is 'terminal'.+--+-- * @-t [/file/], --txtreport[=/file/]@: Write a text report to+-- /file/ (if specified; if not, the default is 'report.txt').+-- Formatting of the report is the same as the 'verbose' terminal+-- mode.+--+-- * @-x [/file/], --xmlreport[=/file/]@: Write a JUnit-style XML+-- report to /file/ (if specified; if not, the default is 'report.xml').+--+-- * @-l /file/, --testlist=/file/@: Read a testlist from /file/. The+-- file must contain a number of filters, one per line. Empty lines+-- or lines beginning with '#' are ignored. Multiple files may be+-- specified. The filters from all files are combined, and added to+-- any filters specified on the command line.+--+-- Any additional arguments are assumed to be filters, which specify a+-- set of tests to be run. For more information on the format of+-- filters, see the 'Filter' module. If no filters are+-- given either on the command line or in testlist files, then all+-- tests will be run.+module Test.HUnitPlus.Main(+ Opts(..),+ ConsoleMode(..),+ opts,+ createMain,+ topLevel+ ) where++import Control.Exception+import Data.ByteString.Lazy(hPut)+import Data.Either+import Data.Map(Map)+import System.Console.CmdArgs hiding (Quiet)+import System.Exit+import System.IO+import Test.HUnitPlus.Base hiding (name)+import Test.HUnitPlus.Execution+import Test.HUnitPlus.Filter+import Test.HUnitPlus.Reporting hiding (Node)+import Test.HUnitPlus.Text+import Test.HUnitPlus.XML+import Text.XML.Expat.Format+import Text.XML.Expat.Tree(Node)++-- | Console mode options.+data ConsoleMode =+ -- | Do not generate any console output.+ Quiet+ -- | Report test counts interactively during execution, updating the+ -- number of tests run, skipped, failed, and errored as they+ -- execute.+ | Terminal+ -- | Report a summary of tests run, skipped, failed, and errored+ -- after execution.+ | Text+ -- | Report extra information as tests execute.+ | Verbose+ deriving (Typeable, Data, Show)++-- | Command-line options for generated programs.+data Opts =+ Opts {+ -- | A file to which to write a JUnit-style XML report. The list+ -- must contain a single value, or be empty, or else the test+ -- program will report bad options. If the list is empty, no XML+ -- report will be generated.+ xmlreport :: ![String],+ -- | Filters in string format, specifying which tests should be+ -- run. If no filters are given, then all tests will be run. For+ -- information on the string format, see "Test.HUnitPlus.Filter".+ filters :: ![String],+ -- | A file to which to write a plain-text report. The list must+ -- contain a single value, or be empty, or else the test program+ -- will report bad options. If the list is empty, no report will+ -- be generated.+ txtreport :: ![String],+ -- | The behavior of the console output.+ consmode :: ![ConsoleMode],+ -- | Files from which to read testlists. Multiple files may be+ -- specified. The contents will be parsed and added to the list+ -- of filters specified on the command line.+ testlist :: ![String]+ }+ deriving (Typeable, Show, Data)++-- | Command-line options for the "System.Console.CmdArgs" module.+opts :: Opts+opts =+ Opts {+ testlist = []+ &= explicit+ &= name "l"+ &= name "testlist"+ &= help "Read test filters from FILE"+ &= typFile,+ xmlreport = []+ &= help "Output an XML report, with an optional filename for the report (default is \"report.xml\")"+ &= opt "report.xml"+ &= typFile,+ txtreport = []+ &= help "Output a plain text report, with an optional filename for the report (default is \"report.txt\")"+ &= opt "report.txt"+ &= typFile,+ consmode = []+ &= explicit+ &= name "c"+ &= name "consolemode"+ &= help "Specify console output behavior. MODE is one of: \"quiet\", \"terminal\", \"text\", \"verbose\" (Default is \"terminal\")"+ &= typ "MODE",+ filters = []+ &= args+ &= typ "FILTERS"+ } &= summary "HUnit-Plus Standard Test Runner"+ &= program "runtests"+ &= noAtExpand+ &= details ["FILTERS specifies one or more test filters, which select " +++ "which tests will be run. If no filters are provided, all " +++ "tests will be selected. If multiple filters are " +++ "specified, tests that match any of the filters will be " +++ "selected. The format for a filter is " +++ "[SUITE::][PATH][@TAGS]. All components are optional.",+ "",+ "SUITE specifies the suite in which selected tests are " +++ "found. If no suite is specified, then the filter will be " +++ "applied to all tests.",+ "",+ "PATH is a path of the form [NAME.]*NAME. All tests whose " +++ "paths start with the path will be selected. If no path is " +++ "specified, then all tests matching the rest of the filter " +++ "will be selected",+ "",+ "TAGS is a comma separated list of tags. All tests with " +++ "any of the given tags will be selected. If no tags are " +++ "specified, then all tests matching the rest of the filter " +++ "will be selected"+ ]++-- | Read and parse a single test list file+parseTestLists :: Opts+ -- ^ The command line options+ -> IO (Either [String] [Filter])+parseTestLists Opts { testlist = filenames, filters = cmdfilters } =+ let+ cmdresults = map (either (Left . (: [])) (Right . (: [])) .+ parseFilter "command line") cmdfilters+ in do+ fileresults <- mapM parseFilterFile filenames+ case partitionEithers (fileresults ++ cmdresults) of+ ([], allfilters) -> return (Right (concat allfilters))+ (errs, _) -> return (Left (concat errs))++-- | Translate an @IOError@ into an error message+interpretException :: String+ -- ^ Prefix to attach to error messages+ -> IOError+ -- ^ Exception to interpret+ -> String+interpretException prefix e = prefix ++ show e++-- | Get the file for reporting XML data+withReportHandles :: Opts+ -- ^ The command line options+ -> (Maybe Handle -> Maybe Handle -> IO a)+ -- ^ A monad parameterized by the xml report handle+ -- and the text report handle.+ -> IO (Either [String] a)+withReportHandles Opts { xmlreport = [], txtreport = [] } cmd =+ cmd Nothing Nothing >>= return . Right+withReportHandles Opts { xmlreport = [ xmlfile ], txtreport = [] } cmd =+ let+ runcmd xmlhandle =+ do+ res <- try (cmd (Just xmlhandle) Nothing)+ case res of+ Left e ->+ return (Left [interpretException "Error generating report file: " e])+ Right res' -> return (Right res')+ in do+ res <- try (withFile xmlfile WriteMode runcmd)+ case res of+ Left e ->+ return (Left [interpretException "Error opening XML report file: " e])+ Right res' -> return res'+withReportHandles Opts { xmlreport = [], txtreport = [ txtfile ] } cmd =+ let+ runcmd txthandle =+ do+ res <- try (cmd Nothing (Just txthandle))+ case res of+ Left e ->+ return (Left [interpretException "Error generating report file: " e])+ Right res' -> return (Right res')+ in do+ res <- try (withFile txtfile WriteMode runcmd)+ case res of+ Left e ->+ return (Left [interpretException "Error opening text report file: " e])+ Right res' -> return res'+withReportHandles Opts { xmlreport = [ xmlfile ], txtreport = [ txtfile ] } cmd =+ let+ runWithXML xmlhandle =+ let+ runcmd txthandle =+ do+ res <- try (cmd (Just xmlhandle) (Just txthandle))+ case res of+ Left e ->+ return (Left [interpretException+ "Error generating report file: " e])+ Right res' -> return (Right res')+ in do+ res <- try (withFile txtfile WriteMode runcmd)+ case res of+ Left e ->+ return (Left [interpretException+ "Error opening text report file: " e])+ Right res' -> return res'+ in do+ res <- try (withFile xmlfile WriteMode runWithXML)+ case res of+ Left e ->+ return (Left [interpretException "Error opening XML report file: " e])+ Right res' -> return res'+withReportHandles Opts { xmlreport = _ : _ : _, txtreport = _ : _ : _ } _ =+ return (Left ["Cannot specify multiple files for XML reports",+ "Cannot specify multiple files for text reports"])+withReportHandles Opts { xmlreport = _ : _ : _ } _ =+ return (Left ["Cannot specify multiple files for XML reports"])+withReportHandles Opts { txtreport = _ : _ : _ } _ =+ return (Left ["Cannot specify multiple files for text reports"])++-- | Create a standard test execution program from a set of test+-- suites. The resulting @main@ will process command line options as+-- described, execute the appropirate tests, and exit with success if+-- all tests passed, and fail otherwise.+createMain :: [TestSuite] -> IO ()+createMain suites =+ do+ cmdopts <- cmdArgs opts+ res <- topLevel suites cmdopts+ case res of+ Left errs ->+ do+ mapM_ (putStr . (++ "\n")) errs+ exitFailure+ Right False -> exitFailure+ Right True -> exitSuccess++-- | Top-level function for executing test suites. 'createMain' is+-- simply a wrapper around this function. This function allows users+-- to supply their own options, and to decide what to do with the+-- result of test execution.+topLevel :: [TestSuite] -> Opts -> IO (Either [String] Bool)+topLevel suites cmdopts @ Opts { consmode = cmodeopt } =+ let+ cmode = case cmodeopt of+ [] -> Right Terminal+ [ cmode' ] -> Right cmode'+ _ -> Left "Cannot specify multiple terminal output options"++ suitenames = map suiteName suites+ in do+ testlistres <- parseTestLists cmdopts+ case (testlistres, cmode) of+ (Left terrs, Left merrs) -> return (Left (merrs : terrs))+ (Left terrs, _) -> return (Left terrs)+ (_, Left merrs) -> return (Left [merrs])+ (Right testlists, Right mode) ->+ let+ normfilters = suiteSelectors suitenames testlists+ in+ withReportHandles cmdopts (executeTests suites normfilters mode)++executeTests :: [TestSuite]+ -- ^ The test suites to run+ -> Map String Selector+ -- ^ The filters to use+ -> ConsoleMode+ -- ^ The mode to use for console output+ -> Maybe Handle+ -- ^ The @Handle@ for XML reporting+ -> Maybe Handle+ -- ^ The @Handle@ for text reporting+ -> IO Bool+executeTests suites testlists cmode xmlhandle txthandle =+ let+ textTerminalReporter = textReporter (putTextToHandle stdout) False+ verboseTerminalReporter = textReporter (putTextToHandle stdout) True++ writeXML :: Handle -> [[Node String String]] -> IO ()+ writeXML outhandle [[tree]] = hPut outhandle (format tree)+ writeXML _ _ =+ error "Internal error in XML reporting: extra nodes on node stack"++ -- Unfortunately, the polymorphic typing of reporters mandates+ -- doing things this way...+ runTests :: ConsoleMode -> Maybe Handle -> Maybe Handle -> IO Counts+ runTests Quiet Nothing Nothing =+ let+ quietReporter = defaultReporter { reporterStart = return () }+ in do+ (out, ()) <- performTestSuites quietReporter testlists suites+ return out+ runTests Terminal Nothing Nothing =+ do+ (out, _) <- performTestSuites terminalReporter testlists suites+ return out+ runTests Text Nothing Nothing =+ do+ (out, _) <- performTestSuites textTerminalReporter testlists suites+ return out+ runTests Verbose Nothing Nothing =+ do+ (out, _) <- performTestSuites verboseTerminalReporter testlists suites+ return out+ runTests Quiet (Just xmlhandle') Nothing =+ do+ (out, tree) <- performTestSuites xmlReporter testlists suites+ writeXML xmlhandle' tree+ return out+ runTests Terminal (Just xmlhandle') Nothing =+ let+ rep = combinedReporter xmlReporter terminalReporter+ in do+ (out, (tree, _)) <- performTestSuites rep testlists suites+ writeXML xmlhandle' tree+ return out+ runTests Text (Just xmlhandle') Nothing =+ let+ rep = combinedReporter xmlReporter textTerminalReporter+ in do+ (out, (tree, _)) <- performTestSuites rep testlists suites+ writeXML xmlhandle' tree+ return out+ runTests Verbose (Just xmlhandle') Nothing =+ let+ rep = combinedReporter xmlReporter verboseTerminalReporter+ in do+ (out, (tree, _)) <- performTestSuites rep testlists suites+ writeXML xmlhandle' tree+ return out+ runTests Quiet Nothing (Just texthandle') =+ let+ txtrep = textReporter (putTextToHandle texthandle') True+ in do+ (out, _) <- performTestSuites txtrep testlists suites+ return out+ runTests Terminal Nothing (Just texthandle') =+ let+ txtrep = textReporter (putTextToHandle texthandle') True+ rep = combinedReporter terminalReporter txtrep+ in do+ (out, _) <- performTestSuites rep testlists suites+ return out+ runTests Text Nothing (Just texthandle') =+ let+ txtrep = textReporter (putTextToHandle texthandle') True+ rep = combinedReporter textTerminalReporter txtrep+ in do+ (out, _) <- performTestSuites rep testlists suites+ return out+ runTests Verbose Nothing (Just texthandle') =+ let+ txtrep = textReporter (putTextToHandle texthandle') True+ rep = combinedReporter verboseTerminalReporter txtrep+ in do+ (out, _) <- performTestSuites rep testlists suites+ return out+ runTests Quiet (Just xmlhandle') (Just texthandle') =+ let+ txtrep = textReporter (putTextToHandle texthandle') True+ rep = combinedReporter xmlReporter txtrep+ in do+ (out, (tree, _)) <- performTestSuites rep testlists suites+ writeXML xmlhandle' tree+ return out+ runTests Terminal (Just xmlhandle') (Just texthandle') =+ let+ txtrep = textReporter (putTextToHandle texthandle') True+ termrep = combinedReporter terminalReporter txtrep+ rep = combinedReporter xmlReporter termrep+ in do+ (out, (tree, _)) <- performTestSuites rep testlists suites+ writeXML xmlhandle' tree+ return out+ runTests Text (Just xmlhandle') (Just texthandle') =+ let+ txtrep = textReporter (putTextToHandle texthandle') True+ termrep = combinedReporter textTerminalReporter txtrep+ rep = combinedReporter xmlReporter termrep+ in do+ (out, (tree, _)) <- performTestSuites rep testlists suites+ writeXML xmlhandle' tree+ return out+ runTests Verbose (Just xmlhandle') (Just texthandle') =+ let+ txtrep = textReporter (putTextToHandle texthandle') True+ termrep = combinedReporter verboseTerminalReporter txtrep+ rep = combinedReporter xmlReporter termrep+ in do+ (out, (tree, _)) <- performTestSuites rep testlists suites+ writeXML xmlhandle' tree+ return out+ in do+ res <- runTests cmode xmlhandle txthandle+ case res of+ Counts { cErrors = 0, cFailures = 0 } -> return True+ _ -> return False
+ src/Test/HUnitPlus/Reporting.hs view
@@ -0,0 +1,313 @@+{-# OPTIONS_GHC -Wall -Werror -funbox-strict-fields #-}++-- | Reporting functionality for HUnit-Plus. Test reporting is now+-- defined using a set of events. A 'Reporter' contains handlers for+-- these events, which have access to and update a 'Reporter'-defined+-- state value. The handlers in a 'Reporter' are called at+-- appropriate points during text execution.+--+-- This module also contains a basic 'defaultReporter' that simply+-- passes the state value through unchanged. It also defines+-- 'combinedReporter', which facilitates \"gluing\" two 'Reporter's+-- together.+module Test.HUnitPlus.Reporting(+ Node(..),+ State(..),+ Counts(..),+ Reporter(..),+ Path,+ zeroCounts,+ showPath,+ defaultReporter,+ combinedReporter+ ) where++import Data.List+import Data.Word+import Data.Map(Map)+import Distribution.TestSuite++-- | A record that holds the results of tests that have been performed+-- up until this point.+data Counts =+ Counts {+ -- | Number of total cases.+ cCases :: !Word,+ -- | Number of cases tried.+ cTried :: !Word,+ -- | Number of cases that failed with an error.+ cErrors :: !Word,+ -- | Number of cases that failed.+ cFailures :: !Word,+ -- | Number of cases that were skipped.+ cSkipped :: !Word,+ -- | Total number of assertions checked.+ cAsserts :: !Word+ }+ deriving (Eq, Show, Read)++-- | Keeps track of the remaining tests and the results of the performed tests.+-- As each test is performed, the path is removed and the counts are+-- updated as appropriate.+data State =+ State {+ -- | The name of the case or suite currently being run.+ stName :: !String,+ -- | The path to the test case currently being run.+ stPath :: !Path,+ -- | The current test statistics.+ stCounts :: !Counts,+ -- | The current option values.+ stOptions :: !(Map String String),+ -- | The current option descriptions we know about.+ stOptionDescs :: ![OptionDescr]+ }+ deriving (Eq, Show, Read)++-- | Uniquely describes the location of a test within a test hierarchy.+-- Node order is from test case to root.+type Path = [Node]++-- | Composed into 'Path's.+data Node = Label String+ deriving (Eq, Show, Read)++-- | Report generator. This record type contains a number of+-- functions that are called at various points throughout a test run.+data Reporter us = Reporter {+ -- | Called at the beginning of a test run.+ reporterStart :: IO us,+ -- | Called at the end of a test run.+ reporterEnd :: Double+ -- The total time it took to run the tests+ -> Counts+ -- The counts from running the tests+ -> us+ -- The user state for this test reporter+ -> IO us,+ -- | Called at the start of a test suite run.+ reporterStartSuite :: State+ -- Options given to the test suite+ -> us+ -- The user state for this test reporter+ -> IO us,+ -- | Called at the end of a test suite run.+ reporterEndSuite :: Double+ -- The total time it tgook to run the test suite+ -> State+ -- The counts from running the tests+ -> us+ -- The user state for this test reporter+ -> IO us,+ -- | Called at the start of a test case run.+ reporterStartCase :: State+ -- The HUnit internal state+ -> us+ -- The user state for this test reporter+ -> IO us,+ -- | Called to report progress of a test case run.+ reporterCaseProgress :: String+ -- A progress message+ -> State+ -- The HUnit internal state+ -> us+ -- The user state for this test reporter+ -> IO us,+ -- | Called at the end of a test case run.+ reporterEndCase :: Double+ -- The total time it took to run the test suite+ -> State+ -- The HUnit internal state+ -> us+ -- The user state for this test reporter+ -> IO us,+ -- | Called when skipping a test case.+ reporterSkipCase :: State+ -- The HUnit internal state+ -> us+ -- The user state for this test reporter+ -> IO us,+ -- | Called to report output printed to the system output stream.+ reporterSystemOut :: String+ -- The content printed to system out+ -> State+ -- The HUnit internal state+ -> us+ -- The user state for this test reporter+ -> IO us,+ -- | Called to report output printed to the system error stream.+ reporterSystemErr :: String+ -- The content printed to system out+ -> State+ -- The HUnit internal state+ -> us+ -- The user state for this test reporter+ -> IO us,+ -- | Called when a test fails.+ reporterFailure :: String+ -- A message relating to the error+ -> State+ -- The HUnit internal state+ -> us+ -- The user state for this test reporter+ -> IO us,+ -- | Called when a test reports an error.+ reporterError :: String+ -- A message relating to the error+ -> State+ -- The HUnit internal state+ -> us+ -- The user state for this test reporter+ -> IO us+ }++-- | A 'Counts' with all zero counts.+zeroCounts :: Counts+zeroCounts = Counts { cCases = 0, cTried = 0, cErrors = 0,+ cFailures = 0, cAsserts = 0, cSkipped = 0 }++-- | A reporter containing default actions, which are to do nothing+-- and return the user state unmodified.+defaultReporter :: Reporter a+defaultReporter = Reporter {+ reporterStart = fail "Must define a reporterStart value",+ reporterEnd = \_ _ us -> return us,+ reporterStartSuite = \_ us -> return us,+ reporterEndSuite = \_ _ us -> return us,+ reporterStartCase = \_ us -> return us,+ reporterCaseProgress = \_ _ us -> return us,+ reporterEndCase = \_ _ us -> return us,+ reporterSkipCase = \_ us -> return us,+ reporterSystemOut = \_ _ us -> return us,+ reporterSystemErr = \_ _ us -> return us,+ reporterFailure = \_ _ us -> return us,+ reporterError = \_ _ us -> return us+ }++-- | Converts a test case path to a string, separating adjacent elements by +-- a dot (\'.\'). An element of the path is quoted (as with 'show') when+-- there is potential ambiguity.+showPath :: Path -> String+showPath [] = ""+showPath nodes =+ let+ showNode (Label label) = safe label (show label)+ safe s ss = if '.' `elem` s || "\"" ++ s ++ "\"" /= ss then ss else s+ in+ intercalate "." (reverse (map showNode nodes))++-- | Combines two 'Reporter's into a single reporter that calls both.+combinedReporter :: Reporter us1 -> Reporter us2 -> Reporter (us1, us2)+combinedReporter Reporter { reporterStart = reportStart1,+ reporterEnd = reportEnd1,+ reporterStartSuite = reportStartSuite1,+ reporterEndSuite = reportEndSuite1,+ reporterStartCase = reportStartCase1,+ reporterCaseProgress = reportCaseProgress1,+ reporterEndCase = reportEndCase1,+ reporterSkipCase = reportSkipCase1,+ reporterSystemOut = reportSystemOut1,+ reporterSystemErr = reportSystemErr1,+ reporterFailure = reportFailure1,+ reporterError = reportError1+ }+ Reporter { reporterStart = reportStart2,+ reporterEnd = reportEnd2,+ reporterStartSuite = reportStartSuite2,+ reporterEndSuite = reportEndSuite2,+ reporterStartCase = reportStartCase2,+ reporterCaseProgress = reportCaseProgress2,+ reporterEndCase = reportEndCase2,+ reporterSkipCase = reportSkipCase2,+ reporterSystemOut = reportSystemOut2,+ reporterSystemErr = reportSystemErr2,+ reporterFailure = reportFailure2,+ reporterError = reportError2+ } =+ let+ reportStart =+ do+ us1 <- reportStart1+ us2 <- reportStart2+ return $! (us1, us2)++ reportEnd time counts (us1, us2) =+ do+ us1' <- reportEnd1 time counts us1+ us2' <- reportEnd2 time counts us2+ return $! (us1', us2')++ reportStartSuite ss (us1, us2) =+ do+ us1' <- reportStartSuite1 ss us1+ us2' <- reportStartSuite2 ss us2+ return $! (us1', us2')++ reportEndSuite time ss (us1, us2) =+ do+ us1' <- reportEndSuite1 time ss us1+ us2' <- reportEndSuite2 time ss us2+ return $! (us1', us2')++ reportStartCase ss (us1, us2) =+ do+ us1' <- reportStartCase1 ss us1+ us2' <- reportStartCase2 ss us2+ return $! (us1', us2')++ reportCaseProgress msg ss (us1, us2) =+ do+ us1' <- reportCaseProgress1 msg ss us1+ us2' <- reportCaseProgress2 msg ss us2+ return $! (us1', us2')++ reportEndCase time ss (us1, us2) =+ do+ us1' <- reportEndCase1 time ss us1+ us2' <- reportEndCase2 time ss us2+ return $! (us1', us2')++ reportSkipCase ss (us1, us2) =+ do+ us1' <- reportSkipCase1 ss us1+ us2' <- reportSkipCase2 ss us2+ return $! (us1', us2')++ reportSystemOut msg ss (us1, us2) =+ do+ us1' <- reportSystemOut1 msg ss us1+ us2' <- reportSystemOut2 msg ss us2+ return $! (us1', us2')++ reportSystemErr msg ss (us1, us2) =+ do+ us1' <- reportSystemErr1 msg ss us1+ us2' <- reportSystemErr2 msg ss us2+ return $! (us1', us2')++ reportFailure msg ss (us1, us2) =+ do+ us1' <- reportFailure1 msg ss us1+ us2' <- reportFailure2 msg ss us2+ return $! (us1', us2')++ reportError msg ss (us1, us2) =+ do+ us1' <- reportError1 msg ss us1+ us2' <- reportError2 msg ss us2+ return $! (us1', us2')+ in+ Reporter {+ reporterStart = reportStart,+ reporterEnd = reportEnd,+ reporterStartSuite = reportStartSuite,+ reporterEndSuite = reportEndSuite,+ reporterStartCase = reportStartCase,+ reporterCaseProgress = reportCaseProgress,+ reporterEndCase = reportEndCase,+ reporterSkipCase = reportSkipCase,+ reporterSystemOut = reportSystemOut,+ reporterSystemErr = reportSystemErr,+ reporterFailure = reportFailure,+ reporterError = reportError+ }
+ src/Test/HUnitPlus/Terminal.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS_GHC -Wall -Werror #-}++-- | This module handles the complexities of writing information to+-- the terminal, including modifying text in place. This code is+-- imported from the original HUnit library.+module Test.HUnitPlus.Terminal(+ terminalAppearance+ ) where++import Data.Char (isPrint)+++-- | Simplifies the input string by interpreting @\\r@ and @\\b@ characters+-- specially so that the result string has the same final (or /terminal/,+-- pun intended) appearance as would the input string when written to a+-- terminal that overwrites character positions following carriage+-- returns and backspaces.++terminalAppearance :: String -> String+terminalAppearance str = ta id "" "" str++-- | The helper function @ta@ takes an accumulating @ShowS@-style function+-- that holds /committed/ lines of text, a (reversed) list of characters+-- on the current line /before/ the cursor, a (normal) list of characters+-- on the current line /after/ the cursor, and the remaining input.++ta :: ([Char] -> t)+ -- ^ An accumulating @ShowS@-style function+ -- that holds /committed/ lines of text+ -> [Char]+ -- ^ A (reversed) list of characters+ -- on the current line /before/ the cursor+ -> [Char]+ -- ^ A (normal) list of characters+ -- on the current line /after/ the cursor+ -> [Char]+ -- ^ The remaining input+ -> t+ta f bs as ('\n':cs) = ta (\t -> f (reverse bs ++ as ++ '\n' : t)) "" "" cs+ta f bs as ('\r':cs) = ta f "" (reverse bs ++ as) cs+ta f (b:bs) as ('\b':cs) = ta f bs (b:as) cs+ta _ "" _ ('\b': _) = error "'\\b' at beginning of line"+ta f bs as (c:cs) + | not (isPrint c) = error "invalid nonprinting character"+ | null as = ta f (c:bs) "" cs+ | otherwise = ta f (c:bs) (tail as) cs+ta f bs as "" = f (reverse bs ++ as)
+ src/Test/HUnitPlus/Text.hs view
@@ -0,0 +1,297 @@+{-# OPTIONS_GHC -Wall -Werror #-}++-- | Text-based reporting functionality for reporting either as text,+-- or to the terminal. This module is an adaptation of code from the+-- original HUnit library.+--+-- Note that the test execution function in this module are included+-- for (a measure of) compatibility with HUnit, but are deprecated in+-- favor of the function in the "Test.HUnitPlus.Main" module.+module Test.HUnitPlus.Text(+ -- * Utilities+ PutText(..),+ putTextToHandle,+ putTextToShowS,+ showCounts,+ -- * Text Reporting+ textReporter,+ runTestText,+ runSuiteText,+ runSuitesText,+ -- * Terminal reporting+ terminalReporter,+ runTestTT,+ runSuiteTT,+ runSuitesTT+ ) where++import Distribution.TestSuite+import Test.HUnitPlus.Base+import Test.HUnitPlus.Execution+import Test.HUnitPlus.Filter+import Test.HUnitPlus.Reporting++import Control.Monad (when)+import System.IO (Handle, stderr, hPutStr, hPutStrLn)+import Text.Printf(printf)++import qualified Data.Map as Map+++-- | The text-based reporters ('textReporter' and 'terminalReporter')+-- construct strings and pass them to the function embodied in a+-- 'PutText'. This function handles the string in one of several+-- ways. Two schemes are defined here. 'putTextToHandle' writes+-- report lines to a given handle. 'putTextToShowS' accumulates lines+-- for return as a whole.+-- +-- The 'PutText' function is also passed, and returns, an arbitrary state+-- value (called 'st' here). The initial state value is given in the+-- 'PutText'; the final value is returned by 'runTestText'.++data PutText st = PutText (String -> st -> IO st) st++-- | Writes persistent lines to the given handle.+putTextToHandle :: Handle -> PutText ()+putTextToHandle handle = PutText (\line () -> hPutStr handle line) ()++-- | Accumulates lines for return by 'runTestText'. The+-- accumulated lines are represented by a @'ShowS' ('String' ->+-- 'String')@ function whose first argument is the string to be+-- appended to the accumulated report lines.+putTextToShowS :: PutText ShowS+putTextToShowS =+ PutText (\line func -> return (\rest -> func (line ++ rest))) id++-- | Create a 'Reporter' that outputs a textual report for+-- non-terminal output.+textReporter :: PutText us+ -- ^ The method for outputting text.+ -> Bool+ -- ^ Whether or not to output verbose text.+ -> Reporter us+textReporter (PutText put initUs) verbose =+ let+ reportProblem p0 p1 msg ss us =+ let+ kind = if null path then p0 else p1+ path = showPath (stPath ss)+ line = "### " ++ kind ++ path ++ ": " ++ msg ++ "\n"+ in+ put line us++ reportOutput p0 p1 msg ss us =+ let+ kind = if null path then p0 else p1+ path = showPath (stPath ss)+ line = "### " ++ kind ++ path ++ ": " ++ msg ++ "\n"+ in+ if verbose then put line us+ else return us++ reportStartCase ss us =+ let+ path = showPath (stPath ss)+ line = if null path then "Test case starting\n"+ else "Test case " ++ path ++ " starting\n"+ in+ if verbose then put line us+ else return us++ reportEndCase time ss us =+ let+ path = showPath (stPath ss)+ timestr = printf "%.6f" time+ line = if null path then "Test completed in " ++ timestr ++ " sec\n"+ else "Test " ++ path ++ " completed in " ++ timestr ++ " sec\n"+ in+ if verbose then put line us+ else return us+ in+ defaultReporter {+ reporterStart = return initUs,+ reporterStartCase = reportStartCase,+ reporterEndCase = reportEndCase,+ reporterSystemOut = reportOutput "STDOUT " "STDOUT from ",+ reporterSystemErr = reportOutput "STDERR" "STDERR from ",+ reporterError = reportProblem "Error " "Error in ",+ reporterFailure = reportProblem "Failure" "Failure in "+ }++-- | Execute a test, processing text output according to the given+-- reporting scheme. The reporting scheme's state is threaded through+-- calls to the reporting scheme's function and finally returned,+-- along with final count values. The text is output in non-terminal+-- mode.+--+-- This function is deprecated. The preferred way to run tests is to+-- use the functions in "Test.HUnitPlus.Main".+runTestText :: PutText us+ -- ^ A function which accumulates output.+ -> Bool+ -- ^ Whether or not to run the test in verbose mode.+ -> Test+ -- ^ The test to run+ -> IO (Counts, us)+runTestText puttext @ (PutText put us0) verbose t =+ let+ initState = State { stCounts = zeroCounts, stName = "",+ stPath = [], stOptions = Map.empty,+ stOptionDescs = [] }++ reporter = textReporter puttext verbose+ in do+ (ss1, us1) <- ((performTest $! reporter) allSelector $! initState) us0 t+ us2 <- put (showCounts (stCounts ss1) ++ "\n") us1+ return (stCounts ss1, us2)++-- | Execute a test suite, processing text output according to the+-- given reporting scheme. The reporting scheme's state is threaded+-- through calls to the reporting scheme's function and finally+-- returned, along with final count values. The text is output in+-- non-terminal mode.+--+-- This function is deprecated. The preferred way to run tests is to+-- use the functions in "Test.HUnitPlus.Main".+runSuiteText :: PutText us+ -- ^ A function which accumulates output.+ -> Bool+ -- ^ Whether or not to run the tests in verbose mode.+ -> TestSuite+ -- ^ The test suite to run.+ -> IO (Counts, us)+runSuiteText puttext @ (PutText put us0) verbose+ suite @ TestSuite { suiteName = sname } =+ let+ selectorMap = Map.singleton sname allSelector+ reporter = textReporter puttext verbose+ in do+ (counts, us1) <- ((performTestSuite $! reporter) $!selectorMap) us0 suite+ us2 <- put (showCounts counts ++ "\n") us1+ return (counts, us2)++-- | Execute the given test suites, processing text output according+-- to the given reporting scheme. The reporting scheme's state is+-- threaded through calls to the reporting scheme's function and+-- finally returned, along with final count values. The text is+-- output in non-terminal mode.+--+-- This function is deprecated. The preferred way to run tests is to+-- use the functions in "Test.HUnitPlus.Main".+runSuitesText :: PutText us+ -- ^ A function which accumulates output+ -> Bool+ -- ^ Whether or not to run the test in verbose mode.+ -> [TestSuite]+ -- ^ The test to run+ -> IO (Counts, us)+runSuitesText puttext @ (PutText put _) verbose suites =+ let+ suiteNames = map suiteName suites+ selectorMap = foldl (\suitemap sname ->+ Map.insert sname allSelector suitemap)+ Map.empty suiteNames+ reporter = textReporter puttext verbose+ in do+ (counts, us1) <- ((performTestSuites $! reporter) $! selectorMap) suites+ us2 <- put (showCounts counts ++ "\n") us1+ return (counts, us2)++-- | Converts test execution counts to a string.+showCounts :: Counts -> String+showCounts Counts { cCases = cases, cTried = tried,+ cErrors = errors, cFailures = failures,+ cAsserts = asserts, cSkipped = skipped } =+ "Cases: " ++ show cases ++ " Tried: " ++ show tried +++ " Errors: " ++ show errors ++ " Failures: " ++ show failures +++ " Assertions: " ++ show asserts ++ " Skipped: " ++ show skipped++-- | Terminal output function, used by the run*TT function and+-- terminal reporters.+termPut :: String -> Bool -> Int -> IO Int+termPut line pers (-1) = do when pers (hPutStrLn stderr line); return (-1)+termPut line True cnt = do hPutStrLn stderr (erase cnt ++ line); return 0+termPut line False _ = do hPutStr stderr ('\r' : line); return (length line)++-- The "erasing" strategy with a single '\r' relies on the fact that the+-- lengths of successive summary lines are monotonically nondecreasing.+erase :: Int -> String+erase cnt = if cnt == 0 then "" else "\r" ++ replicate cnt ' ' ++ "\r"++-- | A reporter that outputs lines indicating progress to the+-- terminal. Reporting is made to standard error, and progress+-- reports are included.+terminalReporter :: Reporter Int+terminalReporter =+ let+ reportProblem p0 p1 msg ss us =+ let+ line = "### " ++ kind ++ path ++ '\n' : msg+ path = showPath (stPath ss)+ kind = if null path then p0 else p1+ in+ termPut line True us+ in+ defaultReporter {+ reporterStart = return 0,+ reporterEndCase =+ (\_ ss us -> termPut (showCounts (stCounts ss)) False us),+ reporterError = reportProblem "Error:" "Error in: ",+ reporterFailure = reportProblem "Failure:" "Failure in: "+ }++-- | Execute a test, processing text output according to the given+-- reporting scheme. The reporting scheme's state is threaded through+-- calls to the reporting scheme's function and finally returned,+-- along with final count values. The text is output in terminal+-- mode.+--+-- This function is deprecated. The preferred way to run tests is to+-- use the functions in "Test.HUnitPlus.Main".+runTestTT :: Test -> IO Counts+runTestTT t =+ let+ initState = State { stCounts = zeroCounts, stName = "",+ stPath = [], stOptions = Map.empty,+ stOptionDescs = [] }+ in do+ (ss1, us1) <- (performTest terminalReporter allSelector $! initState) 0 t+ 0 <- termPut (showCounts (stCounts ss1)) True us1+ return (stCounts ss1)++-- | Execute a test suite, processing text output according to the+-- given reporting scheme. The reporting scheme's state is threaded+-- through calls to the reporting scheme's function and finally+-- returned, along with final count values. The text is output in+-- terminal mode.+--+-- This function is deprecated. The preferred way to run tests is to+-- use the functions in "Test.HUnitPlus.Main".+runSuiteTT :: TestSuite -> IO Counts+runSuiteTT suite @ TestSuite { suiteName = sname } =+ let+ selectorMap = Map.singleton sname allSelector+ in do+ (counts, us) <- (performTestSuite terminalReporter $! selectorMap) 0 suite+ 0 <- termPut (showCounts counts ++ "\n") True us+ return counts++-- | Execute the given test suites, processing text output according+-- to the given reporting scheme. The reporting scheme's state is+-- threaded through calls to the reporting scheme's function and+-- finally returned, along with final count values. The text is+-- output in terminal mode.+--+-- This function is deprecated. The preferred way to run tests is to+-- use the functions in "Test.HUnitPlus.Main".+runSuitesTT :: [TestSuite] -> IO Counts+runSuitesTT suites =+ let+ suiteNames = map suiteName suites+ selectorMap = foldl (\suitemap sname ->+ Map.insert sname allSelector suitemap)+ Map.empty suiteNames+ in do+ (counts, us) <- (performTestSuites terminalReporter $! selectorMap) suites+ 0 <- termPut (showCounts counts ++ "\n") True us+ return counts
+ src/Test/HUnitPlus/XML.hs view
@@ -0,0 +1,230 @@+{-# OPTIONS_GHC -Wall -Werror -funbox-strict-fields #-}++-- | 'Reporter' for running HUnit tests and reporting results as+-- JUnit-style XML reports. This uses the hexpat library for XML+-- generation. This module also contains functions for creating the+-- various nodes in a JUnit XML report.+module Test.HUnitPlus.XML(+ -- * XML Generation+ propertyElem,+ propertiesElem,+ systemOutElem,+ systemErrElem,+ failureElem,+ errorElem,+ testcaseElem,+ skippedTestElem,+ testSuiteElem,+ testSuitesElem,+ -- * Reporter+ xmlReporter+ ) where++import Data.Map(Map)+import Data.Time+import Data.Word+import Network.HostName+import System.Locale+import Test.HUnitPlus.Reporting(Reporter(..), State(..), Counts(..),+ defaultReporter, showPath)+import Text.XML.Expat.Tree++import qualified Data.Map as Map++-- | Generate an element for a property definition+propertyElem :: (String, String)+ -- ^ The name/value pair+ -> Node String String+propertyElem (name, value) = Element { eName = "property", eChildren = [],+ eAttributes = [("name", name),+ ("value", value)] }++-- | Generate an element for a set of property definitions+propertiesElem :: [(String, String)]+ -- ^ A list of name/value pairs to make into properties+ -> Node String String+propertiesElem props = Element { eName = "properties", eAttributes = [],+ eChildren = map propertyElem props }++-- | Generate an element representing output to stdout+systemOutElem :: String+ -- ^ The stdout output+ -> Node String String+systemOutElem content = Element { eName = "system-out", eAttributes = [],+ eChildren = [Text content] }++-- | Generate an element representing output to stderr+systemErrElem :: String+ -- ^ The stderr output+ -> Node String String+systemErrElem content = Element { eName = "system-err", eAttributes = [],+ eChildren = [Text content] }++-- | Generate an element representing a test failure.+failureElem :: String+ -- ^ A message associated with the failure+ -> Node String String+failureElem message = Element { eAttributes = [("message", message)],+ eName = "failure", eChildren = [] }++-- | Generate an element representing an error in a test.+errorElem :: String+ -- ^ A message associated with the error+ -> Node String String+errorElem message = Element { eAttributes = [("message", message)],+ eName = "error", eChildren = [] }++-- | Generate an element for a single test case.+testcaseElem :: String+ -- ^ The name of the test+ -> String+ -- ^ The path to the test (reported as \"classname\")+ -> Word+ -- ^ The number of assertions in the test+ -> Double+ -- ^ The execution time of the test+ -> [Node String String]+ -- ^ Elements representing the events that happened+ -- during test execution.+ -> Node String String+testcaseElem name classname assertions time children =+ Element { eName = "testcase", eChildren = children,+ eAttributes = [("name", name),+ ("classname", classname),+ ("assertions", show assertions),+ ("time", show time)] }++-- | Generate an element for a skipped test case+skippedTestElem :: String+ -- ^ The name of the test+ -> String+ -- ^ The path of the test+ -> Node String String+skippedTestElem name classname =+ let+ skippedElem = Element { eName = "skipped", eAttributes = [],+ eChildren = [] }+ in+ Element { eAttributes = [("name", name), ("classname", classname)],+ eName = "testcase", eChildren = [skippedElem] }++-- | Generate an element for a test suite run+testSuiteElem :: String+ -- ^ The name of the test suite+ -> Map String String+ -- ^ The properties defined for this suite+ -> Word+ -- ^ The number of tests+ -> Word+ -- ^ The number of failures+ -> Word+ -- ^ The number of errors+ -> Word+ -- ^ The number of skipped tests+ -> String+ -- ^ The hostname of the machine on which this was run+ -> UTCTime+ -- ^ The timestamp at which time this was run+ -> Double+ -- ^ The execution time for the test suite+ -> [Node String String]+ -- ^ The testcases and output nodes for the test suite+ -> Node String String+testSuiteElem name propmap tests failures errors skipped+ hostname timestamp time content =+ let+ contentWithProps =+ case Map.assocs propmap of+ [] -> content+ props -> propertiesElem props : content+ timestr = formatTime defaultTimeLocale "%c" timestamp+ in+ Element { eName = "testsuite", eChildren = contentWithProps,+ eAttributes = [("name", name),+ ("hostname", hostname),+ ("timestamp", timestr),+ ("time", show time),+ ("tests", show tests),+ ("failures", show failures),+ ("errors", show errors),+ ("skipped", show skipped)] }++-- | Generate the top-level element containing all test suites+testSuitesElem :: Double+ -- ^ The execution time of all suites+ -> [Node String String]+ -- ^ Elements representing all the test suites+ -> Node String String+testSuitesElem time suites =+ Element { eName = "testsuites", eChildren = suites,+ eAttributes = [("time", show time)] }++-- | A reporter that generates JUnit XML reports+xmlReporter :: Reporter [[Node String String]]+xmlReporter =+ let+ reportStart = return [[]]++ reportEnd time _ [suites] = return [[testSuitesElem time (reverse suites)]]+ reportEnd _ _ _ = fail "Extra information on node stack"++ reportStartSuite _ stack = return ([] : stack)++ reportEndSuite time State { stName = name, stOptions = options,+ stCounts = Counts { cCases = cases,+ cErrors = errors,+ cFailures = failures,+ cSkipped = skipped } }+ (events : rest : stack) =+ do+ hostname <- getHostName+ timestamp <- getCurrentTime+ return ((testSuiteElem name options cases failures errors skipped+ hostname timestamp time (reverse events) :+ rest) : stack)+ reportEndSuite _ _ stack =+ fail ("Node stack underflow in end suite.\n" ++ show stack)++ reportStartCase _ stack = return ([] : stack)++ reportEndCase time State { stName = name, stPath = testpath,+ stCounts = Counts { cAsserts = asserts } }+ (events : rest : stack) =+ return ((testcaseElem name (showPath testpath)+ asserts time (reverse events) : rest) : stack)+ reportEndCase _ _ _ = fail "Node stack underflow in end case"++ reportSkipCase State { stName = name, stPath = testpath } (rest : stack) =+ return ((skippedTestElem name (showPath testpath) : rest) : stack)+ reportSkipCase _ _ = fail "Node stack underflow in skip case"++ reportFailure msg _ (rest : stack) =+ return ((failureElem msg : rest) : stack)+ reportFailure _ _ _ = fail "Node stack underflow in report failure"++ reportError msg _ (rest : stack) =+ return ((errorElem msg : rest) : stack)+ reportError _ _ _ = fail "Node stack underflow in report error"++ reportSystemOut msg _ (rest : stack) =+ return ((systemOutElem msg : rest) : stack)+ reportSystemOut _ _ _ = fail "Node stack underflow in system out"++ reportSystemErr msg _ (rest : stack) =+ return ((systemErrElem msg : rest) : stack)+ reportSystemErr _ _ _ = fail "Node stack underflow in system err"+ in+ defaultReporter {+ reporterStart = reportStart,+ reporterEnd = reportEnd,+ reporterStartSuite = reportStartSuite,+ reporterEndSuite = reportEndSuite,+ reporterStartCase = reportStartCase,+ reporterEndCase = reportEndCase,+ reporterSkipCase = reportSkipCase,+ reporterFailure = reportFailure,+ reporterError = reportError,+ reporterSystemOut = reportSystemOut,+ reporterSystemErr = reportSystemErr+ }+
+ test/RunTests.hs view
@@ -0,0 +1,101 @@+module Main where++import Control.Monad+import Data.ByteString.Lazy hiding (intercalate, reverse, putStr)+import Data.List+import Data.Word+import Distribution.TestSuite+import Prelude hiding (writeFile)+import System.Exit+import Tests+import Text.XML.Expat.Format+import Text.XML.Expat.Tree++-- We can't use HUnit-Plus to test HUnit-Plus, so whip out a quick and+-- simple test execution program.++data Counts =+ Counts {+ cTried :: !Word,+ cErrors :: !Word,+ cFailures :: !Word+ }++instance Show Counts where+ show Counts { cTried = tried, cErrors = errors, cFailures = failures } =+ "Tried: " ++ show tried ++ " Errors: " ++ show errors +++ " Failures: " ++ show failures++zeroCounts :: Counts+zeroCounts = Counts { cTried = 0, cErrors = 0, cFailures = 0 }++finishTest :: IO Progress -> IO Result+finishTest runTest =+ do+ res <- runTest+ case res of+ Progress _ rest -> finishTest rest+ Finished res -> return res++runTest :: [String] -> (Counts, [Node String String]) -> Test ->+ IO (Counts, [Node String String])+runTest path (counts, trees) (Test TestInstance { run = runTest,+ name = tname }) =+ let+ pathstr = intercalate "." (reverse path)+ Counts { cTried = tried, cErrors = errors, cFailures = failed } = counts+ in do+ res <- finishTest runTest+ case res of+ Pass -> return+ (counts { cTried = tried + 1 },+ Element { eName = "testcase", eChildren = [],+ eAttributes = [("name", tname),+ ("classname", pathstr)] } :+ trees)+ Error str -> return+ (counts { cTried = tried + 1, cErrors = errors + 1 },+ Element { eName = "testcase", eAttributes = [("name", tname),+ ("classname", pathstr)],+ eChildren = [Element { eName = "error",+ eChildren = [Text str],+ eAttributes = [] }] } :+ trees)+ Fail str -> return+ (counts { cTried = tried + 1, cFailures = failed + 1 },+ Element { eName = "testcase", eAttributes = [("name", tname),+ ("classname", pathstr)],+ eChildren = [Element { eName = "failure",+ eChildren = [Text str],+ eAttributes = [] }] } :+ trees)++runTest path (counts, trees) Group { groupName = gname, groupTests = gtests } =+ let+ newpath = gname : path+ in+ foldM (runTest newpath) (counts, trees) gtests+runTest _ _ (ExtraOptions _ _) = error "ExtraOptions not supported"++wrapTrees :: Counts -> [Node String String] -> Node String String+wrapTrees Counts { cTried = tried, cErrors = errors, cFailures = failed } trees =+ Element { eName = "testsuites", eAttributes = [],+ eChildren = [Element { eName = "testsuite",+ eAttributes = [("name", "Test"),+ ("package", "HUnit-Plus"),+ ("tests", show tried),+ ("failures", show failed),+ ("errors", show errors),+ ("skipped", "0")],+ eChildren = trees }] }++main :: IO ()+main =+ do+ tests' <- tests+ (counts, trees) <- foldM (runTest []) (zeroCounts, []) tests'+ writeFile "report.xml" (format (indent 2 (wrapTrees counts trees)))+ putStr (show counts ++ "\n")+ case counts of+ Counts { cErrors = 0, cFailures = 0 } -> exitSuccess+ _ -> exitFailure