diff --git a/HUnit-Plus.cabal b/HUnit-Plus.cabal new file mode 100644 --- /dev/null +++ b/HUnit-Plus.cabal @@ -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 +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Test/HUnitPlus.hs b/src/Test/HUnitPlus.hs new file mode 100644 --- /dev/null +++ b/src/Test/HUnitPlus.hs @@ -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 + diff --git a/src/Test/HUnitPlus/Base.hs b/src/Test/HUnitPlus/Base.hs new file mode 100644 --- /dev/null +++ b/src/Test/HUnitPlus/Base.hs @@ -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 diff --git a/src/Test/HUnitPlus/Execution.hs b/src/Test/HUnitPlus/Execution.hs new file mode 100644 --- /dev/null +++ b/src/Test/HUnitPlus/Execution.hs @@ -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) diff --git a/src/Test/HUnitPlus/Filter.hs b/src/Test/HUnitPlus/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Test/HUnitPlus/Filter.hs @@ -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) diff --git a/src/Test/HUnitPlus/Legacy.hs b/src/Test/HUnitPlus/Legacy.hs new file mode 100644 --- /dev/null +++ b/src/Test/HUnitPlus/Legacy.hs @@ -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 diff --git a/src/Test/HUnitPlus/Main.hs b/src/Test/HUnitPlus/Main.hs new file mode 100644 --- /dev/null +++ b/src/Test/HUnitPlus/Main.hs @@ -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 diff --git a/src/Test/HUnitPlus/Reporting.hs b/src/Test/HUnitPlus/Reporting.hs new file mode 100644 --- /dev/null +++ b/src/Test/HUnitPlus/Reporting.hs @@ -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 + } diff --git a/src/Test/HUnitPlus/Terminal.hs b/src/Test/HUnitPlus/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/Test/HUnitPlus/Terminal.hs @@ -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) diff --git a/src/Test/HUnitPlus/Text.hs b/src/Test/HUnitPlus/Text.hs new file mode 100644 --- /dev/null +++ b/src/Test/HUnitPlus/Text.hs @@ -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 diff --git a/src/Test/HUnitPlus/XML.hs b/src/Test/HUnitPlus/XML.hs new file mode 100644 --- /dev/null +++ b/src/Test/HUnitPlus/XML.hs @@ -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 + } + diff --git a/test/RunTests.hs b/test/RunTests.hs new file mode 100644 --- /dev/null +++ b/test/RunTests.hs @@ -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