diff --git a/HUnit.cabal b/HUnit.cabal new file mode 100644 --- /dev/null +++ b/HUnit.cabal @@ -0,0 +1,19 @@ +name: HUnit +version: 1.1 +license: BSD3 +license-file: LICENSE +author: Dean Herington +homepage: http://hunit.sourceforge.net/ +category: Testing +build-depends: base +synopsis: A unit testing framework for Haskell +description: + HUnit is a unit testing framework for Haskell, inspired by the + JUnit tool for Java, see: . +exposed-modules: + Test.HUnit.Base, + Test.HUnit.Lang, + Test.HUnit.Terminal, + Test.HUnit.Text, + Test.HUnit +extensions: CPP diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +HUnit is Copyright (c) Dean Herington, 2002, all rights reserved, +and is distributed as free software under the following license. + +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. + +- The names of the copyright holders may not be used to endorse or +promote products derived from this software without specific prior +written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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/Test/HUnit.lhs b/Test/HUnit.lhs new file mode 100644 --- /dev/null +++ b/Test/HUnit.lhs @@ -0,0 +1,11 @@ +HUnit.lhs -- interface module for HUnit + +> module Test.HUnit +> ( +> module Test.HUnit.Base, +> module Test.HUnit.Text +> ) +> where + +> import Test.HUnit.Base +> import Test.HUnit.Text diff --git a/Test/HUnit/Base.lhs b/Test/HUnit/Base.lhs new file mode 100644 --- /dev/null +++ b/Test/HUnit/Base.lhs @@ -0,0 +1,228 @@ +HUnitBase.lhs -- basic definitions + +> module Test.HUnit.Base +> ( +> {- from Test.HUnit.Lang: -} Assertion, assertFailure, +> assertString, assertBool, assertEqual, +> Assertable(..), ListAssertable(..), +> AssertionPredicate, AssertionPredicable(..), +> (@?), (@=?), (@?=), +> Test(..), Node(..), Path, +> testCaseCount, +> Testable(..), +> (~?), (~=?), (~?=), (~:), +> Counts(..), State(..), +> ReportStart, ReportProblem, +> testCasePaths, +> performTest +> ) +> where + +> import Control.Monad (unless, foldM) + + +Assertion Definition +==================== + +> import Test.HUnit.Lang + + +Conditional Assertion Functions +------------------------------- + +> assertBool :: String -> Bool -> Assertion +> assertBool msg b = unless b (assertFailure msg) + +> assertString :: String -> Assertion +> assertString s = unless (null s) (assertFailure s) + +> assertEqual :: (Eq a, Show a) => String -> a -> a -> 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 +---------------------------- + +> class Assertable t +> where assert :: 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) + +We define the assertability of `[Char]` (that is, `String`) and leave +other types of list to possible user extension. + +> class ListAssertable t +> where listAssert :: [t] -> Assertion + +> instance ListAssertable Char +> where listAssert = assertString + + +Overloaded `assertionPredicate` Function +---------------------------------------- + +> type AssertionPredicate = IO Bool + +> 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 @?, @=?, @?= + +> (@?) :: (AssertionPredicable t) => t -> String -> Assertion +> pred @? msg = assertionPredicate pred >>= assertBool msg + +> (@=?) :: (Eq a, Show a) => a -> a -> Assertion +> expected @=? actual = assertEqual "" expected actual + +> (@?=) :: (Eq a, Show a) => a -> a -> Assertion +> actual @?= expected = assertEqual "" expected actual + + + +Test Definition +=============== + +> data Test = TestCase Assertion +> | TestList [Test] +> | TestLabel String Test + +> instance Show Test where +> showsPrec p (TestCase _) = showString "TestCase _" +> showsPrec p (TestList ts) = showString "TestList " . showList ts +> showsPrec p (TestLabel l t) = showString "TestLabel " . showString l +> . showChar ' ' . showsPrec p t + +> testCaseCount :: Test -> Int +> testCaseCount (TestCase _) = 1 +> testCaseCount (TestList ts) = sum (map testCaseCount ts) +> testCaseCount (TestLabel _ t) = testCaseCount t + + +> data Node = ListItem Int | Label String +> deriving (Eq, Show, Read) + +> type Path = [Node] -- Node order is from test case to root. + + +> testCasePaths :: Test -> [Path] +> testCasePaths t = tcp t [] +> 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) + + +Overloaded `test` Function +-------------------------- + +> class Testable t +> where test :: 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 ~: + +> (~?) :: (AssertionPredicable t) => t -> String -> Test +> pred ~? msg = TestCase (pred @? msg) + +> (~=?) :: (Eq a, Show a) => a -> a -> Test +> expected ~=? actual = TestCase (expected @=? actual) + +> (~?=) :: (Eq a, Show a) => a -> a -> Test +> actual ~?= expected = TestCase (actual @?= expected) + +> (~:) :: (Testable t) => String -> t -> Test +> label ~: t = TestLabel label (test t) + + + +Test Execution +============== + +> data Counts = Counts { cases, tried, errors, failures :: Int } +> deriving (Eq, Show, Read) + +> data State = State { path :: Path, counts :: Counts } +> deriving (Eq, Show, Read) + +> type ReportStart us = State -> us -> IO us + +> type ReportProblem us = String -> State -> us -> IO us + + +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 -> ReportProblem us -> ReportProblem us +> -> us -> Test -> IO (Counts, us) +> performTest reportStart reportError reportFailure us t = do +> (ss', us') <- pt initState us t +> unless (null (path ss')) $ error "performTest: Final path is nonnull" +> return (counts ss', us') +> where +> initState = State{ path = [], counts = initCounts } +> initCounts = Counts{ cases = testCaseCount t, tried = 0, +> errors = 0, failures = 0} + +> pt ss us (TestCase a) = do +> us' <- reportStart ss us +> r <- performTestCase a +> case r of Nothing -> do return (ss', us') +> Just (True, m) -> do usF <- reportFailure m ssF us' +> return (ssF, usF) +> Just (False, m) -> do usE <- reportError m ssE us' +> return (ssE, usE) +> where c@Counts{ tried = t } = counts ss +> ss' = ss{ counts = c{ tried = t + 1 } } +> ssF = ss{ counts = c{ tried = t + 1, failures = failures c + 1 } } +> ssE = ss{ counts = c{ tried = t + 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 } diff --git a/Test/HUnit/Lang.lhs b/Test/HUnit/Lang.lhs new file mode 100644 --- /dev/null +++ b/Test/HUnit/Lang.lhs @@ -0,0 +1,74 @@ +Test/HUnit/Lang.lhs -- HUnit language support. + +> module Test.HUnit.Lang +> ( +> Assertion, +> assertFailure, +> performTestCase +> ) +> where + + +When adapting this module for other Haskell language systems, change +the imports and the implementations but not the interfaces. + + + +Imports +------- + +> import Data.List (isPrefixOf) +#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) +> import Control.Exception (try) +#else +> import System.IO.Error (ioeGetErrorString, try) +#endif + + + +Interfaces +---------- + +An assertion is an `IO` computation with trivial result. + +> type Assertion = IO () + +`assertFailure` signals an assertion failure with a given message. + +> assertFailure :: String -> Assertion + +`performTestCase` performs a single test case. The meaning of the +result is as follows: + Nothing test case success + Just (True, msg) test case failure with the given message + Just (False, msg) test case error with the given message + +> performTestCase :: Assertion -> IO (Maybe (Bool, String)) + + +Implementations +--------------- + +> hunitPrefix = "HUnit:" + +> hugsPrefix = "IO Error: User error\nReason: " +> nhc98Prefix = "I/O error (user-defined), call to function `userError':\n " +> -- GHC prepends no prefix to the user-supplied string. + +> assertFailure msg = ioError (userError (hunitPrefix ++ msg)) + +> performTestCase action = do r <- try action +> case r of Right () -> return Nothing +> Left e -> return (Just (decode e)) +> where +#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) +> decode e = let s0 = show e +#else +> decode e = let s0 = ioeGetErrorString e +#endif +> (_, s1) = dropPrefix hugsPrefix s0 +> (_, s2) = dropPrefix nhc98Prefix s1 +> in dropPrefix hunitPrefix s2 +> dropPrefix pref str = if pref `isPrefixOf` str +> then (True, drop (length pref) str) +> else (False, str) diff --git a/Test/HUnit/Terminal.lhs b/Test/HUnit/Terminal.lhs new file mode 100644 --- /dev/null +++ b/Test/HUnit/Terminal.lhs @@ -0,0 +1,31 @@ +> 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. + +The helper function `ta` takes an accumlating `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. + +> terminalAppearance :: String -> String +> terminalAppearance str = ta id "" "" str +> where +> 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 f "" as ('\b':cs) = 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/Test/HUnit/Text.lhs b/Test/HUnit/Text.lhs new file mode 100644 --- /dev/null +++ b/Test/HUnit/Text.lhs @@ -0,0 +1,125 @@ +HUnitText.lhs -- text-based test controller + +> 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 -> 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 cnt = 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" + + +`putTextToShowS` 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 tail = f (line ++ '\n' : tail) + + +`runTestText` 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 us) t = do +> (counts, us') <- performTest reportStart reportError reportFailure us t +> us'' <- put (showCounts counts) True us' +> return (counts, us'') +> where +> reportStart ss us = put (showCounts (counts ss)) False us +> reportError = reportProblem "Error:" "Error in: " +> reportFailure = reportProblem "Failure:" "Failure in: " +> reportProblem p0 p1 msg ss us = put line True us +> where line = "### " ++ kind ++ path' ++ '\n' : msg +> kind = if null path' then p0 else p1 +> path' = showPath (path ss) + + +`showCounts` 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 + + +`showPath` converts a test case path to a string, separating adjacent +elements by ':'. 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 + + +`runTestTT` 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