HUnit 1.3.1.2 → 1.6.2.0
raw patch · 15 files changed
Files
- CHANGELOG.md +20/−0
- HUnit.cabal +62/−48
- README.md +2/−2
- Test/HUnit.hs +0/−80
- Test/HUnit/Base.hs +0/−383
- Test/HUnit/Lang.hs +0/−94
- Test/HUnit/Terminal.hs +0/−42
- Test/HUnit/Text.hs +0/−131
- src/Test/HUnit.hs +80/−0
- src/Test/HUnit/Base.hs +361/−0
- src/Test/HUnit/Lang.hs +104/−0
- src/Test/HUnit/Terminal.hs +42/−0
- src/Test/HUnit/Text.hs +152/−0
- tests/HUnitTestBase.lhs +2/−2
- tests/HUnitTestExtended.hs +3/−19
CHANGELOG.md view
@@ -1,5 +1,25 @@ ## Changes +#### 1.6.2.0++- Add support for GHC 7.0.* and 7.2.*++#### 1.6.1.0++- Add `Test.HUnit.Text.runTestTTAndExit`++#### 1.6.0.0++- Generalize return type of `assertFailure` to `IO a`++#### 1.5.0.0++- Preserve actual/expected for `assertEqual` failures++#### 1.4.0.0++- Depend on `call-stack`+ #### 1.3.1.2 - Fixes the test suite on GHC 8
HUnit.cabal view
@@ -1,52 +1,66 @@-Name: HUnit-Version: 1.3.1.2-Cabal-Version: >= 1.8-License: BSD3-License-File: LICENSE-Author: Dean Herington-Maintainer: Simon Hengel <sol@typeful.net>-Stability: stable-Homepage: https://github.com/hspec/HUnit#readme-Category: Testing-Synopsis: A unit testing framework for Haskell-Description:- HUnit is a unit testing framework for Haskell, inspired by the- JUnit tool for Java, see: <http://www.junit.org>.-Build-Type: Simple-Extra-Source-Files:- CHANGELOG.md- README.md- examples/Example.hs+cabal-version: 1.12 +-- This file has been generated from package.yaml by hpack version 0.34.3.+--+-- see: https://github.com/sol/hpack++name: HUnit+version: 1.6.2.0+license: BSD3+license-file: LICENSE+author: Dean Herington+maintainer: Simon Hengel <sol@typeful.net>+stability: stable+homepage: https://github.com/hspec/HUnit#readme+bug-reports: https://github.com/hspec/HUnit/issues+category: Testing+synopsis: A unit testing framework for Haskell+description: HUnit is a unit testing framework for Haskell, inspired by the+ JUnit tool for Java, see: <http://www.junit.org>.+build-type: Simple+extra-source-files:+ CHANGELOG.md+ README.md+ source-repository head- type: git- location: https://github.com/hspec/HUnit+ type: git+ location: https://github.com/hspec/HUnit -Library- Build-Depends:- base == 4.*,- deepseq- Exposed-Modules:- Test.HUnit.Base,- Test.HUnit.Lang,- Test.HUnit.Terminal,- Test.HUnit.Text,- Test.HUnit- GHC-Options: -Wall+library+ hs-source-dirs:+ src+ build-depends:+ base ==4.*,+ call-stack >=0.3.0,+ deepseq+ exposed-modules:+ Test.HUnit.Base+ Test.HUnit.Lang+ Test.HUnit.Terminal+ Test.HUnit.Text+ Test.HUnit+ other-modules:+ Paths_HUnit+ default-language: Haskell2010+ ghc-options: -Wall -Test-Suite tests- Type: exitcode-stdio-1.0- Main-Is: HUnitTests.hs- HS-Source-Dirs: tests, examples- Build-Depends:- base == 4.*,- deepseq,- filepath,- HUnit- Other-Modules:- HUnitTests- HUnitTestBase- HUnitTestExtended- TerminalTest- Example- GHC-Options: -Wall+test-suite tests+ type: exitcode-stdio-1.0+ main-is: HUnitTests.hs+ hs-source-dirs:+ tests+ examples+ build-depends:+ HUnit,+ base ==4.*,+ call-stack >=0.3.0,+ deepseq,+ filepath+ other-modules:+ HUnitTestBase+ HUnitTestExtended+ TerminalTest+ Example+ Paths_HUnit+ default-language: Haskell2010+ ghc-options: -Wall
README.md view
@@ -10,7 +10,7 @@ easy to create, change, and execute. The [JUnit](www.junit.org) tool pioneered support for test-first development in [Java](http://java.sun.com). HUnit is an adaptation of JUnit to Haskell, a general-purpose, purely functional-programming language. (To learn more about Haskell, see www.haskell.org](http://www.haskell.org).+programming language. (To learn more about Haskell, see [www.haskell.org](http://www.haskell.org)). With HUnit, as with JUnit, you can easily create tests, name them, group them into suites, and execute them, with the framework checking the results automatically. Test@@ -143,7 +143,7 @@ With `assertString` the two are combined. With `assertEqual` you provide a "preface", an expected value, and an actual value; the failure message shows the two unequal values and is prefixed by the preface. Additional ways to create assertions are- described later under [Avanced Features](#advanced-features)+ described later under [Advanced Features](#advanced-features) Since assertions are `IO` computations, they may be combined--along with other `IO` computations--using `(>>=)`, `(>>)`, and the `do`
− Test/HUnit.hs
@@ -1,80 +0,0 @@--- | HUnit is a unit testing framework for Haskell, inspired by the JUnit tool--- for Java. This guide describes how to use HUnit, assuming you are familiar--- with Haskell, though not necessarily with JUnit.------ In the Haskell module where your tests will reside, import module--- @Test.HUnit@:------ @--- import Test.HUnit--- @------ Define test cases as appropriate:------ @--- test1 = TestCase (assertEqual "for (foo 3)," (1,2) (foo 3))--- test2 = TestCase (do (x,y) <- partA 3--- assertEqual "for the first result of partA," 5 x--- b <- partB y--- assertBool ("(partB " ++ show y ++ ") failed") b)--- @------ Name the test cases and group them together:------ @--- tests = TestList [TestLabel "test1" test1, TestLabel "test2" test2]--- @------ Run the tests as a group. At a Haskell interpreter prompt, apply the function--- @runTestTT@ to the collected tests. (The /TT/ suggests /T/ext orientation--- with output to the /T/erminal.)------ @--- \> runTestTT tests--- Cases: 2 Tried: 2 Errors: 0 Failures: 0--- \>--- @------ If the tests are proving their worth, you might see:------ @--- \> runTestTT tests--- ### Failure in: 0:test1--- for (foo 3),--- expected: (1,2)--- but got: (1,3)--- Cases: 2 Tried: 2 Errors: 0 Failures: 1--- \>--- @------ You can specify tests even more succinctly using operators and overloaded--- functions that HUnit provides:------ @--- tests = test [ "test1" ~: "(foo 3)" ~: (1,2) ~=? (foo 3),--- "test2" ~: do (x, y) <- partA 3--- assertEqual "for the first result of partA," 5 x--- partB y \@? "(partB " ++ show y ++ ") failed" ]--- @------ Assuming the same test failures as before, you would see:------ @--- \> runTestTT tests--- ### Failure in: 0:test1:(foo 3)--- expected: (1,2)--- but got: (1,3)--- Cases: 2 Tried: 2 Errors: 0 Failures: 1--- \>--- @--module Test.HUnit-(- module Test.HUnit.Base,- module Test.HUnit.Text-)-where--import Test.HUnit.Base-import Test.HUnit.Text-
− Test/HUnit/Base.hs
@@ -1,383 +0,0 @@-{-# LANGUAGE CPP #-}-#if MIN_VERSION_base(4,8,1)-#define HAS_SOURCE_LOCATIONS-{-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE ConstrainedClassMethods #-}-#endif---- | Basic definitions for the HUnit library.------ This module contains what you need to create assertions and test cases and--- combine them into test suites.------ This module also provides infrastructure for--- implementing test controllers (which are used to execute tests).--- See "Test.HUnit.Text" for a great example of how to implement a test--- controller.--module Test.HUnit.Base-(- -- ** Declaring tests- Test(..),- (~=?), (~?=), (~:), (~?),-- -- ** Making assertions- assertFailure, {- from Test.HUnit.Lang: -}- assertBool, assertEqual, assertString,- Assertion, {- from Test.HUnit.Lang: -}- (@=?), (@?=), (@?),-- -- ** Extending the assertion functionality- Assertable(..), ListAssertable(..),- AssertionPredicate, AssertionPredicable(..),- Testable(..),-- -- ** Test execution- -- $testExecutionNote- State(..), Counts(..),- Path, Node(..),- testCasePaths,- testCaseCount,- Location (..),- ReportStart, ReportProblem,- performTest-)-where--#ifdef HAS_SOURCE_LOCATIONS-import GHC.Stack-#define with_loc (?loc :: CallStack) =>-#else-#define with_loc-#endif--import Control.Monad (unless, foldM)----- Assertion Definition--- ====================--import Test.HUnit.Lang----- Conditional Assertion Functions--- ----------------------------------- | Asserts that the specified condition holds.-assertBool :: with_loc- String -- ^ The message that is displayed if the assertion fails- -> Bool -- ^ The condition- -> Assertion-assertBool msg b = unless b (assertFailure msg)---- | Signals an assertion failure if a non-empty message (i.e., a message--- other than @\"\"@) is passed.-assertString :: with_loc- String -- ^ The message that is displayed with the assertion failure- -> Assertion-assertString s = unless (null s) (assertFailure 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 :: with_loc (Eq a, Show a)- => String -- ^ The message prefix- -> a -- ^ The expected value- -> a -- ^ The actual value- -> Assertion-assertEqual preface expected actual =- unless (actual == expected) (assertFailure msg)- where msg = (if null preface then "" else preface ++ "\n") ++- "expected: " ++ show expected ++ "\n but got: " ++ show actual----- 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 be the body of a 'TestCase' or part of--- a @TestCase@; it should not be used to assert multiple, independent--- conditions.------ If more complex arrangements of assertions are needed, 'Test's and--- 'Testable' should be used.-class Assertable t- where assert :: with_loc t -> Assertion--instance Assertable ()- where assert = return--instance Assertable Bool- where assert = assertBool ""--instance (ListAssertable t) => Assertable [t]- where assert = listAssert--instance (Assertable t) => Assertable (IO t)- where assert = (>>= assert)---- | A specialized form of 'Assertable' to handle lists.-class ListAssertable t- where listAssert :: with_loc [t] -> Assertion--instance ListAssertable Char- where listAssert = assertString----- Overloaded `assertionPredicate` Function--- -------------------------------------------- | The result of an assertion that hasn't been evaluated yet.------ Most test cases follow the following steps:------ 1. Do some processing or an action.------ 2. Assert certain conditions.------ However, this flow is not always suitable. @AssertionPredicate@ allows for--- additional steps to be inserted without the initial action to be affected--- by side effects. Additionally, clean-up can be done before the test case--- has a chance to end. A potential work flow is:------ 1. Write data to a file.------ 2. Read data from a file, evaluate conditions.------ 3. Clean up the file.------ 4. Assert that the side effects of the read operation meet certain conditions.------ 5. Assert that the conditions evaluated in step 2 are met.-type AssertionPredicate = IO Bool---- | Used to signify that a data type can be converted to an assertion--- predicate.-class AssertionPredicable t- where assertionPredicate :: t -> AssertionPredicate--instance AssertionPredicable Bool- where assertionPredicate = return--instance (AssertionPredicable t) => AssertionPredicable (IO t)- where assertionPredicate = (>>= assertionPredicate)----- Assertion Construction Operators--- ----------------------------------infix 1 @?, @=?, @?=---- | Asserts that the condition obtained from the specified--- 'AssertionPredicable' holds.-(@?) :: with_loc (AssertionPredicable t)- => t -- ^ A value of which the asserted condition is predicated- -> String -- ^ A message that is displayed if the assertion fails- -> Assertion-predi @? msg = assertionPredicate predi >>= assertBool msg---- | Asserts that the specified actual value is equal to the expected value--- (with the expected value on the left-hand side).-(@=?) :: with_loc (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).-(@?=) :: with_loc (Eq a, Show a)- => a -- ^ The actual value- -> a -- ^ The expected value- -> Assertion-actual @?= expected = assertEqual "" expected actual------ 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---- Overloaded `test` Function--- ------------------------------ | Provides a way to convert data into a @Test@ or set of @Test@.-class Testable t- where test :: with_loc t -> Test--instance Testable Test- where test = id--instance (Assertable t) => Testable (IO t)- where test = TestCase . assert--instance (Testable t) => Testable [t]- where test = TestList . map test----- Test Construction Operators--- -----------------------------infix 1 ~?, ~=?, ~?=-infixr 0 ~:---- | Creates a test case resulting from asserting the condition obtained--- from the specified 'AssertionPredicable'.-(~?) :: with_loc (AssertionPredicable t)- => t -- ^ A value of which the asserted condition is predicated- -> String -- ^ A message that is displayed on test failure- -> Test-predi ~? msg = TestCase (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).-(~=?) :: with_loc (Eq a, Show a)- => a -- ^ The expected value- -> a -- ^ The actual value- -> Test-expected ~=? actual = TestCase (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).-(~?=) :: with_loc (Eq a, Show a)- => a -- ^ The actual value- -> a -- ^ The expected value- -> Test-actual ~?= expected = TestCase (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.-(~:) :: with_loc (Testable t) => String -> t -> Test-label ~: t = TestLabel label (test t)------ Test Execution--- ==============---- $testExecutionNote--- Note: the rest of the functionality in this module is intended for--- implementors of test controllers. If you just want to run your tests cases,--- simply use a test controller, such as the text-based controller in--- "Test.HUnit.Text".---- | A data structure that hold the results of tests that have been performed--- up until this point.-data Counts = Counts { cases, tried, errors, failures :: Int }- 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 { path :: Path, counts :: Counts }- deriving (Eq, Show, Read)---- | Report generator for reporting the start of a test run.-type ReportStart us = State -> us -> IO us---- | Report generator for reporting problems that have occurred during--- a test run. Problems may be errors or assertion failures.-type ReportProblem us = Maybe Location -> String -> State -> us -> IO us---- | 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 = ListItem Int | Label String- deriving (Eq, Show, Read)---- | Determines the paths for all 'TestCase's in a tree of @Test@s.-testCasePaths :: Test -> [Path]-testCasePaths t0 = tcp t0 []- where tcp (TestCase _) p = [p]- tcp (TestList ts) p =- concat [ tcp t (ListItem n : p) | (t,n) <- zip ts [0..] ]- tcp (TestLabel l t) p = tcp t (Label l : p)---- | Counts the number of 'TestCase's in a tree of @Test@s.-testCaseCount :: Test -> Int-testCaseCount (TestCase _) = 1-testCaseCount (TestList ts) = sum (map testCaseCount ts)-testCaseCount (TestLabel _ t) = testCaseCount t---- | Performs a test run with the specified report generators.------ This handles the actual running of the tests. Most developers will want--- to use @HUnit.Text.runTestTT@ instead. A developer could use this function--- to execute tests via another IO system, such as a GUI, or to output the--- results in a different manner (e.g., upload XML-formatted results to a--- webservice).------ Note that the counts in a start report do not include the test case--- being started, whereas the counts in a problem report do include the--- test case just finished. The principle is that the counts are sampled--- only between test case executions. As a result, the number of test--- case successes always equals the difference of test cases tried and--- the sum of test case errors and failures.-performTest :: ReportStart us -- ^ report generator for the test run start- -> ReportProblem us -- ^ report generator for errors during the test run- -> ReportProblem us -- ^ report generator for assertion failures during the test run- -> us- -> Test -- ^ the test to be executed- -> IO (Counts, us)-performTest reportStart reportError reportFailure initialUs initialT = do- (ss', us') <- pt initState initialUs initialT- unless (null (path ss')) $ error "performTest: Final path is nonnull"- return (counts ss', us')- where- initState = State{ path = [], counts = initCounts }- initCounts = Counts{ cases = testCaseCount initialT, tried = 0,- errors = 0, failures = 0}-- pt ss us (TestCase a) = do- us' <- reportStart ss us- r <- performTestCase a- case r of- Success -> do- return (ss', us')- Failure loc m -> do- usF <- reportFailure loc m ssF us'- return (ssF, usF)- Error loc m -> do- usE <- reportError loc m ssE us'- return (ssE, usE)- where c@Counts{ tried = n } = counts ss- ss' = ss{ counts = c{ tried = n + 1 } }- ssF = ss{ counts = c{ tried = n + 1, failures = failures c + 1 } }- ssE = ss{ counts = c{ tried = n + 1, errors = errors c + 1 } }-- pt ss us (TestList ts) = foldM f (ss, us) (zip ts [0..])- where f (ss', us') (t, n) = withNode (ListItem n) ss' us' t-- pt ss us (TestLabel label t) = withNode (Label label) ss us t-- withNode node ss0 us0 t = do (ss2, us1) <- pt ss1 us0 t- return (ss2{ path = path0 }, us1)- where path0 = path ss0- ss1 = ss0{ path = node : path0 }
− Test/HUnit/Lang.hs
@@ -1,94 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--{-# LANGUAGE CPP #-}-#if MIN_VERSION_base(4,8,1)-#define HAS_SOURCE_LOCATIONS-{-# LANGUAGE ImplicitParams #-}-#endif--module Test.HUnit.Lang (- Assertion,- assertFailure,-- Location (..),- Result (..),- performTestCase,--- * Internals--- |--- /Note:/ This is not part of the public API! It is exposed so that you can--- tinker with the internals of HUnit, but do not expect it to be stable!- HUnitFailure (..)-) where--import Control.DeepSeq-import Control.Exception as E-import Data.Typeable--#ifdef HAS_SOURCE_LOCATIONS-#if !(MIN_VERSION_base(4,9,0))-import GHC.SrcLoc-#endif-import GHC.Stack-#endif---- | When an assertion is evaluated, it will output a message if and only if the--- assertion fails.------ Test cases are composed of a sequence of one or more assertions.-type Assertion = IO ()--data Location = Location {- locationFile :: FilePath-, locationLine :: Int-, locationColumn :: Int-} deriving (Eq, Ord, Show)--data HUnitFailure = HUnitFailure (Maybe Location) String- deriving (Eq, Ord, Show, Typeable)--instance Exception HUnitFailure---- | Unconditionally signals that a failure has occured. All--- other assertions can be expressed with the form:------ @--- if conditionIsMet--- then IO ()--- else assertFailure msg--- @-assertFailure ::-#ifdef HAS_SOURCE_LOCATIONS- (?loc :: CallStack) =>-#endif- String -- ^ A message that is displayed with the assertion failure- -> Assertion-assertFailure msg = msg `deepseq` E.throwIO (HUnitFailure location msg)- where- location :: Maybe Location-#ifdef HAS_SOURCE_LOCATIONS- location = case reverse (getCallStack ?loc) of- (_, loc) : _ -> Just $ Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc)- [] -> Nothing-#else- location = Nothing-#endif--data Result = Success | Failure (Maybe Location) String | Error (Maybe Location) String- deriving (Eq, Ord, Show)---- | Performs a single test case.-performTestCase :: Assertion -- ^ an assertion to be made during the test case run- -> IO Result-performTestCase action =- (action >> return Success)- `E.catches`- [E.Handler (\(HUnitFailure loc msg) -> return $ Failure loc msg),-- -- Re-throw AsyncException, otherwise execution will not terminate on- -- SIGINT (ctrl-c). Currently, all AsyncExceptions are being thrown- -- because it's thought that none of them will be encountered during- -- normal HUnit operation. If you encounter an example where this- -- is not the case, please email the maintainer.- E.Handler (\e -> throw (e :: E.AsyncException)),-- E.Handler (\e -> return $ Error Nothing $ show (e :: E.SomeException))]
− Test/HUnit/Terminal.hs
@@ -1,42 +0,0 @@--- | This module handles the complexities of writing information to the--- terminal, including modifying text in place.--module Test.HUnit.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)
− Test/HUnit/Text.hs
@@ -1,131 +0,0 @@--- | Text-based test controller for running HUnit tests and reporting--- results as text, usually to a terminal.--module Test.HUnit.Text-(- PutText(..),- putTextToHandle, putTextToShowS,- runTestText,- showPath, showCounts,- runTestTT-)-where--import Test.HUnit.Base--import Control.Monad (when)-import System.IO (Handle, stderr, hPutStr, hPutStrLn)----- | As the general text-based test controller ('runTestText') executes a--- test, it reports each test case start, error, and failure by--- constructing a string and passing it to the function embodied in a--- 'PutText'. A report string is known as a \"line\", although it includes--- no line terminator; the function in a 'PutText' is responsible for--- terminating lines appropriately. Besides the line, the function--- receives a flag indicating the intended \"persistence\" of the line:--- 'True' indicates that the line should be part of the final overall--- report; 'False' indicates that the line merely indicates progress of--- the test execution. Each progress line shows the current values of--- the cumulative test execution counts; a final, persistent line shows--- the final count values.------ 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 -> Bool -> st -> IO st) st----- | Two reporting schemes are defined here. @putTextToHandle@ writes--- report lines to a given handle. 'putTextToShowS' accumulates--- persistent lines for return as a whole by 'runTestText'.------ @putTextToHandle@ writes persistent lines to the given handle,--- following each by a newline character. In addition, if the given flag--- is @True@, it writes progress lines to the handle as well. A progress--- line is written with no line termination, so that it can be--- overwritten by the next report line. As overwriting involves writing--- carriage return and blank characters, its proper effect is usually--- only obtained on terminal devices.--putTextToHandle- :: Handle- -> Bool -- ^ Write progress lines to handle?- -> PutText Int-putTextToHandle handle showProgress = PutText put initCnt- where- initCnt = if showProgress then 0 else -1- put line pers (-1) = do when pers (hPutStrLn handle line); return (-1)- put line True cnt = do hPutStrLn handle (erase cnt ++ line); return 0- put line False _ = do hPutStr handle ('\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 cnt = if cnt == 0 then "" else "\r" ++ replicate cnt ' ' ++ "\r"----- | Accumulates persistent lines (dropping progess 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 put id- where put line pers f = return (if pers then acc f line else f)- acc f line rest = f (line ++ '\n' : rest)----- | Executes a test, processing each report line 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.--runTestText :: PutText st -> Test -> IO (Counts, st)-runTestText (PutText put us0) t = do- (counts', us1) <- performTest reportStart reportError reportFailure us0 t- us2 <- put (showCounts counts') True us1- return (counts', us2)- where- reportStart ss us = put (showCounts (counts ss)) False us- reportError = reportProblem "Error:" "Error in: "- reportFailure = reportProblem "Failure:" "Failure in: "- reportProblem p0 p1 loc msg ss us = put line True us- where line = "### " ++ kind ++ path' ++ "\n" ++ formatLocation loc ++ msg- kind = if null path' then p0 else p1- path' = showPath (path ss)--formatLocation :: Maybe Location -> String-formatLocation Nothing = ""-formatLocation (Just loc) = locationFile loc ++ ":" ++ show (locationLine loc) ++ "\n"---- | Converts test execution counts to a string.--showCounts :: Counts -> String-showCounts Counts{ cases = cases', tried = tried',- errors = errors', failures = failures' } =- "Cases: " ++ show cases' ++ " Tried: " ++ show tried' ++- " Errors: " ++ show errors' ++ " Failures: " ++ show failures'----- | Converts a test case path to a string, separating adjacent elements by--- the colon (\':\'). An element of the path is quoted (as with 'show') when--- there is potential ambiguity.--showPath :: Path -> String-showPath [] = ""-showPath nodes = foldl1 f (map showNode nodes)- where f b a = a ++ ":" ++ b- showNode (ListItem n) = show n- showNode (Label label) = safe label (show label)- safe s ss = if ':' `elem` s || "\"" ++ s ++ "\"" /= ss then ss else s----- | Provides the \"standard\" text-based test controller. Reporting is made to--- standard error, and progress reports are included. For possible--- programmatic use, the final counts are returned.------ The \"TT\" in the name suggests \"Text-based reporting to the Terminal\".--runTestTT :: Test -> IO Counts-runTestTT t = do (counts', 0) <- runTestText (putTextToHandle stderr True) t- return counts'
+ src/Test/HUnit.hs view
@@ -0,0 +1,80 @@+-- | HUnit is a unit testing framework for Haskell, inspired by the JUnit tool+-- for Java. This guide describes how to use HUnit, assuming you are familiar+-- with Haskell, though not necessarily with JUnit.+--+-- In the Haskell module where your tests will reside, import module+-- @Test.HUnit@:+--+-- @+-- import Test.HUnit+-- @+--+-- Define test cases as appropriate:+--+-- @+-- test1 = TestCase (assertEqual "for (foo 3)," (1,2) (foo 3))+-- test2 = TestCase (do (x,y) <- partA 3+-- assertEqual "for the first result of partA," 5 x+-- b <- partB y+-- assertBool ("(partB " ++ show y ++ ") failed") b)+-- @+--+-- Name the test cases and group them together:+--+-- @+-- tests = TestList [TestLabel "test1" test1, TestLabel "test2" test2]+-- @+--+-- Run the tests as a group. At a Haskell interpreter prompt, apply the function+-- @runTestTT@ to the collected tests. (The /TT/ suggests /T/ext orientation+-- with output to the /T/erminal.)+--+-- @+-- \> runTestTT tests+-- Cases: 2 Tried: 2 Errors: 0 Failures: 0+-- \>+-- @+--+-- If the tests are proving their worth, you might see:+--+-- @+-- \> runTestTT tests+-- ### Failure in: 0:test1+-- for (foo 3),+-- expected: (1,2)+-- but got: (1,3)+-- Cases: 2 Tried: 2 Errors: 0 Failures: 1+-- \>+-- @+--+-- You can specify tests even more succinctly using operators and overloaded+-- functions that HUnit provides:+--+-- @+-- tests = test [ "test1" ~: "(foo 3)" ~: (1,2) ~=? (foo 3),+-- "test2" ~: do (x, y) <- partA 3+-- assertEqual "for the first result of partA," 5 x+-- partB y \@? "(partB " ++ show y ++ ") failed" ]+-- @+--+-- Assuming the same test failures as before, you would see:+--+-- @+-- \> runTestTT tests+-- ### Failure in: 0:test1:(foo 3)+-- expected: (1,2)+-- but got: (1,3)+-- Cases: 2 Tried: 2 Errors: 0 Failures: 1+-- \>+-- @++module Test.HUnit+(+ module Test.HUnit.Base,+ module Test.HUnit.Text+)+where++import Test.HUnit.Base+import Test.HUnit.Text+
+ src/Test/HUnit/Base.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE ConstraintKinds #-}+#define HasCallStack_ HasCallStack =>+#else+#define HasCallStack_+#endif++-- | Basic definitions for the HUnit library.+--+-- This module contains what you need to create assertions and test cases and+-- combine them into test suites.+--+-- This module also provides infrastructure for+-- implementing test controllers (which are used to execute tests).+-- See "Test.HUnit.Text" for a great example of how to implement a test+-- controller.++module Test.HUnit.Base+(+ -- ** Declaring tests+ Test(..),+ (~=?), (~?=), (~:), (~?),++ -- ** Making assertions+ assertFailure, {- from Test.HUnit.Lang: -}+ assertBool, assertEqual, assertString,+ Assertion, {- from Test.HUnit.Lang: -}+ (@=?), (@?=), (@?),++ -- ** Extending the assertion functionality+ Assertable(..), ListAssertable(..),+ AssertionPredicate, AssertionPredicable(..),+ Testable(..),++ -- ** Test execution+ -- $testExecutionNote+ State(..), Counts(..),+ Path, Node(..),+ testCasePaths,+ testCaseCount,+ ReportStart, ReportProblem,+ performTest+) where++import Control.Monad (unless, foldM)+import Data.CallStack+++-- Assertion Definition+-- ====================++import Test.HUnit.Lang+++-- Conditional Assertion Functions+-- -------------------------------++-- | Asserts that the specified condition holds.+assertBool :: HasCallStack_+ String -- ^ The message that is displayed if the assertion fails+ -> Bool -- ^ The condition+ -> Assertion+assertBool msg b = unless b (assertFailure msg)++-- | Signals an assertion failure if a non-empty message (i.e., a message+-- other than @\"\"@) is passed.+assertString :: HasCallStack_+ String -- ^ The message that is displayed with the assertion failure+ -> Assertion+assertString s = unless (null s) (assertFailure s)++-- 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 be the body of a 'TestCase' or part of+-- a @TestCase@; it should not be used to assert multiple, independent+-- conditions.+--+-- If more complex arrangements of assertions are needed, 'Test's and+-- 'Testable' should be used.+class Assertable t+ where assert :: HasCallStack_ t -> Assertion++instance Assertable ()+ where assert = return++instance Assertable Bool+ where assert = assertBool ""++instance (ListAssertable t) => Assertable [t]+ where assert = listAssert++instance (Assertable t) => Assertable (IO t)+ where assert = (>>= assert)++-- | A specialized form of 'Assertable' to handle lists.+class ListAssertable t+ where listAssert :: HasCallStack_ [t] -> Assertion++instance ListAssertable Char+ where listAssert = assertString+++-- Overloaded `assertionPredicate` Function+-- ----------------------------------------++-- | The result of an assertion that hasn't been evaluated yet.+--+-- Most test cases follow the following steps:+--+-- 1. Do some processing or an action.+--+-- 2. Assert certain conditions.+--+-- However, this flow is not always suitable. @AssertionPredicate@ allows for+-- additional steps to be inserted without the initial action to be affected+-- by side effects. Additionally, clean-up can be done before the test case+-- has a chance to end. A potential work flow is:+--+-- 1. Write data to a file.+--+-- 2. Read data from a file, evaluate conditions.+--+-- 3. Clean up the file.+--+-- 4. Assert that the side effects of the read operation meet certain conditions.+--+-- 5. Assert that the conditions evaluated in step 2 are met.+type AssertionPredicate = IO Bool++-- | Used to signify that a data type can be converted to an assertion+-- predicate.+class AssertionPredicable t+ where assertionPredicate :: t -> AssertionPredicate++instance AssertionPredicable Bool+ where assertionPredicate = return++instance (AssertionPredicable t) => AssertionPredicable (IO t)+ where assertionPredicate = (>>= assertionPredicate)+++-- Assertion Construction Operators+-- --------------------------------++infix 1 @?, @=?, @?=++-- | Asserts that the condition obtained from the specified+-- 'AssertionPredicable' holds.+(@?) :: HasCallStack_ AssertionPredicable t+ => t -- ^ A value of which the asserted condition is predicated+ -> String -- ^ A message that is displayed if the assertion fails+ -> Assertion+predi @? msg = assertionPredicate predi >>= assertBool msg++-- | Asserts that the specified actual value is equal to the expected value+-- (with the expected value on the left-hand side).+(@=?) :: HasCallStack_ (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).+(@?=) :: HasCallStack_ (Eq a, Show a)+ => a -- ^ The actual value+ -> a -- ^ The expected value+ -> Assertion+actual @?= expected = assertEqual "" expected actual++++-- 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++-- Overloaded `test` Function+-- --------------------------++-- | Provides a way to convert data into a @Test@ or set of @Test@.+class Testable t+ where test :: HasCallStack_ t -> Test++instance Testable Test+ where test = id++instance (Assertable t) => Testable (IO t)+ where test = TestCase . assert++instance (Testable t) => Testable [t]+ where test = TestList . map test+++-- Test Construction Operators+-- ---------------------------++infix 1 ~?, ~=?, ~?=+infixr 0 ~:++-- | Creates a test case resulting from asserting the condition obtained+-- from the specified 'AssertionPredicable'.+(~?) :: HasCallStack_ AssertionPredicable t+ => t -- ^ A value of which the asserted condition is predicated+ -> String -- ^ A message that is displayed on test failure+ -> Test+predi ~? msg = TestCase (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).+(~=?) :: HasCallStack_ (Eq a, Show a)+ => a -- ^ The expected value+ -> a -- ^ The actual value+ -> Test+expected ~=? actual = TestCase (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).+(~?=) :: HasCallStack_ (Eq a, Show a)+ => a -- ^ The actual value+ -> a -- ^ The expected value+ -> Test+actual ~?= expected = TestCase (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.+(~:) :: HasCallStack_ Testable t => String -> t -> Test+label ~: t = TestLabel label (test t)++++-- Test Execution+-- ==============++-- $testExecutionNote+-- Note: the rest of the functionality in this module is intended for+-- implementors of test controllers. If you just want to run your tests cases,+-- simply use a test controller, such as the text-based controller in+-- "Test.HUnit.Text".++-- | A data structure that hold the results of tests that have been performed+-- up until this point.+data Counts = Counts { cases, tried, errors, failures :: Int }+ 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 { path :: Path, counts :: Counts }+ deriving (Eq, Show, Read)++-- | Report generator for reporting the start of a test run.+type ReportStart us = State -> us -> IO us++-- | Report generator for reporting problems that have occurred during+-- a test run. Problems may be errors or assertion failures.+type ReportProblem us = Maybe SrcLoc -> String -> State -> us -> IO us++-- | 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 = ListItem Int | Label String+ deriving (Eq, Show, Read)++-- | Determines the paths for all 'TestCase's in a tree of @Test@s.+testCasePaths :: Test -> [Path]+testCasePaths t0 = tcp t0 []+ where tcp (TestCase _) p = [p]+ tcp (TestList ts) p =+ concat [ tcp t (ListItem n : p) | (t,n) <- zip ts [0..] ]+ tcp (TestLabel l t) p = tcp t (Label l : p)++-- | Counts the number of 'TestCase's in a tree of @Test@s.+testCaseCount :: Test -> Int+testCaseCount (TestCase _) = 1+testCaseCount (TestList ts) = sum (map testCaseCount ts)+testCaseCount (TestLabel _ t) = testCaseCount t++-- | Performs a test run with the specified report generators.+--+-- This handles the actual running of the tests. Most developers will want+-- to use @HUnit.Text.runTestTT@ instead. A developer could use this function+-- to execute tests via another IO system, such as a GUI, or to output the+-- results in a different manner (e.g., upload XML-formatted results to a+-- webservice).+--+-- Note that the counts in a start report do not include the test case+-- being started, whereas the counts in a problem report do include the+-- test case just finished. The principle is that the counts are sampled+-- only between test case executions. As a result, the number of test+-- case successes always equals the difference of test cases tried and+-- the sum of test case errors and failures.+performTest :: ReportStart us -- ^ report generator for the test run start+ -> ReportProblem us -- ^ report generator for errors during the test run+ -> ReportProblem us -- ^ report generator for assertion failures during the test run+ -> us+ -> Test -- ^ the test to be executed+ -> IO (Counts, us)+performTest reportStart reportError reportFailure initialUs initialT = do+ (ss', us') <- pt initState initialUs initialT+ unless (null (path ss')) $ error "performTest: Final path is nonnull"+ return (counts ss', us')+ where+ initState = State{ path = [], counts = initCounts }+ initCounts = Counts{ cases = testCaseCount initialT, tried = 0,+ errors = 0, failures = 0}++ pt ss us (TestCase a) = do+ us' <- reportStart ss us+ r <- performTestCase a+ case r of+ Success -> do+ return (ss', us')+ Failure loc m -> do+ usF <- reportFailure loc m ssF us'+ return (ssF, usF)+ Error loc m -> do+ usE <- reportError loc m ssE us'+ return (ssE, usE)+ where c@Counts{ tried = n } = counts ss+ ss' = ss{ counts = c{ tried = n + 1 } }+ ssF = ss{ counts = c{ tried = n + 1, failures = failures c + 1 } }+ ssE = ss{ counts = c{ tried = n + 1, errors = errors c + 1 } }++ pt ss us (TestList ts) = foldM f (ss, us) (zip ts [0..])+ where f (ss', us') (t, n) = withNode (ListItem n) ss' us' t++ pt ss us (TestLabel label t) = withNode (Label label) ss us t++ withNode node ss0 us0 t = do (ss2, us1) <- pt ss1 us0 t+ return (ss2{ path = path0 }, us1)+ where path0 = path ss0+ ss1 = ss0{ path = node : path0 }
+ src/Test/HUnit/Lang.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}++#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE ConstraintKinds #-}+#define HasCallStack_ HasCallStack =>+#else+#define HasCallStack_+#endif++module Test.HUnit.Lang (+ Assertion,+ assertFailure,+ assertEqual,++ Result (..),+ performTestCase,+-- * Internals+-- |+-- /Note:/ This is not part of the public API! It is exposed so that you can+-- tinker with the internals of HUnit, but do not expect it to be stable!+ HUnitFailure (..),+ FailureReason (..),+ formatFailureReason+) where++import Control.DeepSeq+import Control.Exception as E+import Control.Monad+import Data.List+import Data.Typeable+import Data.CallStack++-- | When an assertion is evaluated, it will output a message if and only if the+-- assertion fails.+--+-- Test cases are composed of a sequence of one or more assertions.+type Assertion = IO ()++data HUnitFailure = HUnitFailure (Maybe SrcLoc) FailureReason+ deriving (Eq, Show, Typeable)++instance Exception HUnitFailure++data FailureReason = Reason String | ExpectedButGot (Maybe String) String String+ deriving (Eq, Show, Typeable)++location :: HasCallStack_ Maybe SrcLoc+location = case reverse callStack of+ (_, loc) : _ -> Just loc+ [] -> Nothing++-- | Unconditionally signals that a failure has occurred.+assertFailure ::+ HasCallStack_+ String -- ^ A message that is displayed with the assertion failure+ -> IO a+assertFailure msg = msg `deepseq` E.throwIO (HUnitFailure location $ Reason msg)++-- | 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 :: HasCallStack_ (Eq a, Show a)+ => String -- ^ The message prefix+ -> a -- ^ The expected value+ -> a -- ^ The actual value+ -> Assertion+assertEqual preface expected actual =+ unless (actual == expected) $ do+ (prefaceMsg `deepseq` expectedMsg `deepseq` actualMsg `deepseq` E.throwIO (HUnitFailure location $ ExpectedButGot prefaceMsg expectedMsg actualMsg))+ where+ prefaceMsg+ | null preface = Nothing+ | otherwise = Just preface+ expectedMsg = show expected+ actualMsg = show actual++formatFailureReason :: FailureReason -> String+formatFailureReason (Reason reason) = reason+formatFailureReason (ExpectedButGot preface expected actual) = intercalate "\n" . maybe id (:) preface $ ["expected: " ++ expected, " but got: " ++ actual]++data Result = Success | Failure (Maybe SrcLoc) String | Error (Maybe SrcLoc) String+ deriving (Eq, Show)++-- | Performs a single test case.+performTestCase :: Assertion -- ^ an assertion to be made during the test case run+ -> IO Result+performTestCase action =+ (action >> return Success)+ `E.catches`+ [E.Handler (\(HUnitFailure loc reason) -> return $ Failure loc (formatFailureReason reason)),++ -- Re-throw AsyncException, otherwise execution will not terminate on+ -- SIGINT (ctrl-c). Currently, all AsyncExceptions are being thrown+ -- because it's thought that none of them will be encountered during+ -- normal HUnit operation. If you encounter an example where this+ -- is not the case, please email the maintainer.+ E.Handler (\e -> throw (e :: E.AsyncException)),++ E.Handler (\e -> return $ Error Nothing $ show (e :: E.SomeException))]
+ src/Test/HUnit/Terminal.hs view
@@ -0,0 +1,42 @@+-- | This module handles the complexities of writing information to the+-- terminal, including modifying text in place.++module Test.HUnit.Terminal (+ terminalAppearance+ ) where++import Data.Char (isPrint)+++-- | Simplifies the input string by interpreting @\\r@ and @\\b@ characters+-- specially so that the result string has the same final (or /terminal/,+-- pun intended) appearance as would the input string when written to a+-- terminal that overwrites character positions following carriage+-- returns and backspaces.++terminalAppearance :: String -> String+terminalAppearance str = ta id "" "" str++-- | The helper function @ta@ takes an accumulating @ShowS@-style function+-- that holds /committed/ lines of text, a (reversed) list of characters+-- on the current line /before/ the cursor, a (normal) list of characters+-- on the current line /after/ the cursor, and the remaining input.++ta+ :: ([Char] -> t) -- ^ An accumulating @ShowS@-style function+ -- that holds /committed/ lines of text+ -> [Char] -- ^ A (reversed) list of characters+ -- on the current line /before/ the cursor+ -> [Char] -- ^ A (normal) list of characters+ -- on the current line /after/ the cursor+ -> [Char] -- ^ The remaining input+ -> t+ta f bs as ('\n':cs) = ta (\t -> f (reverse bs ++ as ++ '\n' : t)) "" "" cs+ta f bs as ('\r':cs) = ta f "" (reverse bs ++ as) cs+ta f (b:bs) as ('\b':cs) = ta f bs (b:as) cs+ta _ "" _ ('\b': _) = error "'\\b' at beginning of line"+ta f bs as (c:cs)+ | not (isPrint c) = error "invalid nonprinting character"+ | null as = ta f (c:bs) "" cs+ | otherwise = ta f (c:bs) (tail as) cs+ta f bs as "" = f (reverse bs ++ as)
+ src/Test/HUnit/Text.hs view
@@ -0,0 +1,152 @@+-- | Text-based test controller for running HUnit tests and reporting+-- results as text, usually to a terminal.++module Test.HUnit.Text+(+ PutText(..),+ putTextToHandle, putTextToShowS,+ runTestText,+ showPath, showCounts,+ runTestTT,+ runTestTTAndExit+)+where++import Test.HUnit.Base++import Data.CallStack+import Control.Monad (when)+import System.IO (Handle, stderr, hPutStr, hPutStrLn)+import System.Exit (exitSuccess, exitFailure)+++-- | As the general text-based test controller ('runTestText') executes a+-- test, it reports each test case start, error, and failure by+-- constructing a string and passing it to the function embodied in a+-- 'PutText'. A report string is known as a \"line\", although it includes+-- no line terminator; the function in a 'PutText' is responsible for+-- terminating lines appropriately. Besides the line, the function+-- receives a flag indicating the intended \"persistence\" of the line:+-- 'True' indicates that the line should be part of the final overall+-- report; 'False' indicates that the line merely indicates progress of+-- the test execution. Each progress line shows the current values of+-- the cumulative test execution counts; a final, persistent line shows+-- the final count values.+--+-- 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 -> Bool -> st -> IO st) st+++-- | Two reporting schemes are defined here. @putTextToHandle@ writes+-- report lines to a given handle. 'putTextToShowS' accumulates+-- persistent lines for return as a whole by 'runTestText'.+--+-- @putTextToHandle@ writes persistent lines to the given handle,+-- following each by a newline character. In addition, if the given flag+-- is @True@, it writes progress lines to the handle as well. A progress+-- line is written with no line termination, so that it can be+-- overwritten by the next report line. As overwriting involves writing+-- carriage return and blank characters, its proper effect is usually+-- only obtained on terminal devices.++putTextToHandle+ :: Handle+ -> Bool -- ^ Write progress lines to handle?+ -> PutText Int+putTextToHandle handle showProgress = PutText put initCnt+ where+ initCnt = if showProgress then 0 else -1+ put line pers (-1) = do when pers (hPutStrLn handle line); return (-1)+ put line True cnt = do hPutStrLn handle (erase cnt ++ line); return 0+ put line False _ = do hPutStr handle ('\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 cnt = if cnt == 0 then "" else "\r" ++ replicate cnt ' ' ++ "\r"+++-- | Accumulates persistent lines (dropping progess 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 put id+ where put line pers f = return (if pers then acc f line else f)+ acc f line rest = f (line ++ '\n' : rest)+++-- | Executes a test, processing each report line 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.++runTestText :: PutText st -> Test -> IO (Counts, st)+runTestText (PutText put us0) t = do+ (counts', us1) <- performTest reportStart reportError reportFailure us0 t+ us2 <- put (showCounts counts') True us1+ return (counts', us2)+ where+ reportStart ss us = put (showCounts (counts ss)) False us+ reportError = reportProblem "Error:" "Error in: "+ reportFailure = reportProblem "Failure:" "Failure in: "+ reportProblem p0 p1 loc msg ss us = put line True us+ where line = "### " ++ kind ++ path' ++ "\n" ++ formatLocation loc ++ msg+ kind = if null path' then p0 else p1+ path' = showPath (path ss)++formatLocation :: Maybe SrcLoc -> String+formatLocation Nothing = ""+formatLocation (Just loc) = srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ "\n"++-- | Converts test execution counts to a string.++showCounts :: Counts -> String+showCounts Counts{ cases = cases', tried = tried',+ errors = errors', failures = failures' } =+ "Cases: " ++ show cases' ++ " Tried: " ++ show tried' +++ " Errors: " ++ show errors' ++ " Failures: " ++ show failures'+++-- | Converts a test case path to a string, separating adjacent elements by+-- the colon (\':\'). An element of the path is quoted (as with 'show') when+-- there is potential ambiguity.++showPath :: Path -> String+showPath [] = ""+showPath nodes = foldl1 f (map showNode nodes)+ where f b a = a ++ ":" ++ b+ showNode (ListItem n) = show n+ showNode (Label label) = safe label (show label)+ safe s ss = if ':' `elem` s || "\"" ++ s ++ "\"" /= ss then ss else s+++-- | Provides the \"standard\" text-based test controller. Reporting is made to+-- standard error, and progress reports are included. For possible+-- programmatic use, the final counts are returned.+--+-- The \"TT\" in the name suggests \"Text-based reporting to the Terminal\".++runTestTT :: Test -> IO Counts+runTestTT t = do (counts', 0) <- runTestText (putTextToHandle stderr True) t+ return counts'++-- | Convenience wrapper for 'runTestTT'.+-- Simply runs 'runTestTT' and then exits back to the OS,+-- using 'exitSuccess' if there were no errors or failures,+-- or 'exitFailure' if there were. For example:+--+-- > tests :: Test+-- > tests = ...+-- >+-- > main :: IO ()+-- > main = runTestTTAndExit tests++runTestTTAndExit :: Test -> IO ()+runTestTTAndExit tests = do+ c <- runTestTT tests+ if (errors c == 0) && (failures c == 0)+ then exitSuccess+ else exitFailure
tests/HUnitTestBase.lhs view
@@ -81,7 +81,7 @@ > ok :: Test > ok = test (assert ()) > bad :: String -> Test-> bad m = test (assertFailure m)+> bad m = test (assertFailure m :: Assertion) > assertTests :: Test@@ -108,7 +108,7 @@ > "assertFailure" ~: > let msg = "simple assertFailure"-> in expectFailure msg (test (assertFailure msg)),+> in expectFailure msg (test (assertFailure msg :: Assertion)), > "assertString null" ~: expectSuccess (TestCase (assertString "")),
tests/HUnitTestExtended.hs view
@@ -1,34 +1,18 @@-{-# LANGUAGE CPP #-}-module HUnitTestExtended (- extendedTests- ) where+module HUnitTestExtended (extendedTests) where import Test.HUnit import HUnitTestBase -#if MIN_VERSION_base(4,9,0)-errorCall :: a-errorCall = error "error"-#endif- extendedTests :: Test extendedTests = test [-- -- Hugs doesn't currently catch arithmetic exceptions.- "div by 0" ~:- expectUnspecifiedError (TestCase ((3 `div` 0 :: Integer) `seq` return ())),+ expectError "divide by zero" (TestCase ((3 `div` 0 :: Integer) `seq` return ())), "list ref out of bounds" ~: expectUnspecifiedError (TestCase ([1 .. 4 :: Integer] !! 10 `seq` return ())), -#if MIN_VERSION_base(4,9,0)- "error" ~:- expectError "error\nCallStack (from HasCallStack):\n error, called at tests/HUnitTestExtended.hs:11:13 in main:HUnitTestExtended" (TestCase errorCall),-#else "error" ~:- expectError "error" (TestCase (error "error")),-#endif+ expectUnspecifiedError (TestCase (error "error")), "tail []" ~: expectUnspecifiedError (TestCase (tail [] `seq` return ()))