HUnit (empty) → 1.1
raw patch · 8 files changed
+519/−0 lines, 8 filesdep +basebuild-type:Customsetup-changed
Dependencies added: base
Files
- HUnit.cabal +19/−0
- LICENSE +29/−0
- Setup.hs +2/−0
- Test/HUnit.lhs +11/−0
- Test/HUnit/Base.lhs +228/−0
- Test/HUnit/Lang.lhs +74/−0
- Test/HUnit/Terminal.lhs +31/−0
- Test/HUnit/Text.lhs +125/−0
+ HUnit.cabal view
@@ -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: <http://www.junit.org>.+exposed-modules:+ Test.HUnit.Base,+ Test.HUnit.Lang,+ Test.HUnit.Terminal,+ Test.HUnit.Text,+ Test.HUnit+extensions: CPP
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Test/HUnit.lhs view
@@ -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
+ Test/HUnit/Base.lhs view
@@ -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 }
+ Test/HUnit/Lang.lhs view
@@ -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)
+ Test/HUnit/Terminal.lhs view
@@ -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)
+ Test/HUnit/Text.lhs view
@@ -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