New patches: [changed file extensions from .lhs to .hs Leif Frenzel **20070717153017] { move ./Test/HUnit.lhs ./Test/HUnit.hs move ./Test/HUnit/Base.lhs ./Test/HUnit/Base.hs move ./Test/HUnit/Lang.lhs ./Test/HUnit/Lang.hs move ./Test/HUnit/Terminal.lhs ./Test/HUnit/Terminal.hs move ./Test/HUnit/Text.lhs ./Test/HUnit/Text.hs } [un-literated code Leif Frenzel **20070717154325] { hunk ./Test/HUnit.hs 1 -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 +-- interface module for HUnit + +module Test.HUnit +( + module Test.HUnit.Base, + module Test.HUnit.Text +) +where + +import Test.HUnit.Base +import Test.HUnit.Text hunk ./Test/HUnit/Base.hs 1 -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 } +-- 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 } hunk ./Test/HUnit/Lang.hs 1 -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 Data.Dynamic -> import Control.Exception as E ( throwDyn, try, Exception(..) ) -#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 ---------------- - -#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) -> data HUnitFailure = HUnitFailure String -> -> hunitFailureTc :: TyCon -> hunitFailureTc = mkTyCon "HUnitFailure" -> {-# NOINLINE hunitFailureTc #-} -> -> instance Typeable HUnitFailure where -> typeOf _ = mkTyConApp hunitFailureTc [] - -> assertFailure msg = E.throwDyn (HUnitFailure msg) - -> performTestCase action = -> do r <- E.try action -> case r of -> Right () -> return Nothing -> Left e@(E.DynException dyn) -> -> case fromDynamic dyn of -> Just (HUnitFailure msg) -> return $ Just (True, msg) -> Nothing -> return $ Just (False, show e) -> Left e -> return $ Just (False, show e) -#else -> hunitPrefix = "HUnit:" - -> nhc98Prefix = "I/O error (user-defined), call to function `userError':\n " - -> 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 -> decode e = let s0 = ioeGetErrorString e -> (_, s1) = dropPrefix nhc98Prefix s0 -> in dropPrefix hunitPrefix s1 -> dropPrefix pref str = if pref `isPrefixOf` str -> then (True, drop (length pref) str) -> else (False, str) -#endif +-- 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 Data.Dynamic +import Control.Exception as E ( throwDyn, try, Exception(..) ) +#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 +-- --------------- + +#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) +data HUnitFailure = HUnitFailure String + +hunitFailureTc :: TyCon +hunitFailureTc = mkTyCon "HUnitFailure" +{-# NOINLINE hunitFailureTc #-} + +instance Typeable HUnitFailure where + typeOf _ = mkTyConApp hunitFailureTc [] + +assertFailure msg = E.throwDyn (HUnitFailure msg) + +performTestCase action = + do r <- E.try action + case r of + Right () -> return Nothing + Left e@(E.DynException dyn) -> + case fromDynamic dyn of + Just (HUnitFailure msg) -> return $ Just (True, msg) + Nothing -> return $ Just (False, show e) + Left e -> return $ Just (False, show e) +#else +hunitPrefix = "HUnit:" + +nhc98Prefix = "I/O error (user-defined), call to function `userError':\n " + +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 + decode e = let s0 = ioeGetErrorString e + (_, s1) = dropPrefix nhc98Prefix s0 + in dropPrefix hunitPrefix s1 + dropPrefix pref str = if pref `isPrefixOf` str + then (True, drop (length pref) str) + else (False, str) +#endif hunk ./Test/HUnit/Terminal.hs 1 -> 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 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. - -> 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) +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 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. + +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) hunk ./Test/HUnit/Text.hs 1 -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 +-- 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 } [converted existing source comments to Haddock comments and filled in rest of documentation Leif Frenzel **20070823192207] { hunk ./Test/HUnit.hs 1 --- interface module for HUnit +-- | The HUnit library. To write HUnit tests it is sufficient to import this +-- module, which simply re-exports all modules of the library. hunk ./Test/HUnit/Base.hs 1 --- basic definitions +-- | Basic definitions for the HUnit library. +-- +-- This module contains what you need to create assertions and test cases and +-- combine them into test suites. It also provides infrastructure for +-- implementing test controllers (which are used to execute tests). For an +-- exemplary implementation of a test controller, see "Test.HUnit.Text". hunk ./Test/HUnit/Base.hs 10 - {- from Test.HUnit.Lang: -} Assertion, assertFailure, - assertString, assertBool, assertEqual, + -- ** Declaring tests + Test(..), + (~=?), (~?=), (~:), (~?), + -- ** Making assertions + assertBool, assertEqual, assertString, + {- from Test.HUnit.Lang: -} + assertFailure, Assertion, + (@=?), (@?=), (@?), + -- ** Extending the assertion functionality hunk ./Test/HUnit/Base.hs 21 - (@?), (@=?), (@?=), - Test(..), Node(..), Path, + Node(..), Path, hunk ./Test/HUnit/Base.hs 23 - Testable(..), - (~?), (~=?), (~?=), (~:), + Testable(..), + -- ** Test execution + -- $testExecutionNote hunk ./Test/HUnit/Base.hs 45 -assertBool :: String -> Bool -> Assertion +-- | asserts that the specified condition holds. +assertBool :: String -- ^ a message that is displayed if the assertion fails + -> Bool -- ^ the condition that is asserted to hold + -> Assertion hunk ./Test/HUnit/Base.hs 51 -assertString :: String -> Assertion +-- | signals an assertion failure if a non-empty message is passed. +assertString :: String -- ^ a message that is displayed with the assertion failure + -> Assertion hunk ./Test/HUnit/Base.hs 56 -assertEqual :: (Eq a, Show a) => String -> a -> a -> Assertion +-- | asserts that the specified actual value is equal to the expected value. +assertEqual :: (Eq a, Show a) => String -- ^ a message that is displayed if the assertion fails + -> a -- ^ the expected value + -> a -- ^ the actual value + -> Assertion hunk ./Test/HUnit/Base.hs 115 -(@?) :: (AssertionPredicable t) => t -> String -> Assertion +-- | asserts that the condition obtained from the specified +-- 'AssertionPredicable' holds. +(@?) :: (AssertionPredicable t) => t -- ^ a value of which the asserted condition is predicated + -> String -- ^ a message that is displayed if the assertion fails + -> Assertion hunk ./Test/HUnit/Base.hs 121 - -(@=?) :: (Eq a, Show a) => a -> a -> Assertion -expected @=? actual = assertEqual "" expected actual - -(@?=) :: (Eq a, Show a) => a -> a -> Assertion + +-- | 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 hunk ./Test/HUnit/Base.hs 151 +-- | recursively counts all test cases contained in the specified test. hunk ./Test/HUnit/Base.hs 194 -(~?) :: (AssertionPredicable t) => t -> String -> Test +-- | creates a test case resulting from asserting the condition obtained +-- from the specified 'AssertionPredicable'. +(~?) :: (AssertionPredicable t) => t -- ^ a value of which the asserted condition is predicated + -> String -- ^ a message that is displayed on test failure + -> Test hunk ./Test/HUnit/Base.hs 201 -(~=?) :: (Eq a, Show a) => a -> a -> Test +-- | 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 hunk ./Test/HUnit/Base.hs 209 -(~?=) :: (Eq a, Show a) => a -> a -> Test +-- | 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 hunk ./Test/HUnit/Base.hs 217 +-- | creates a test from the specified 'Testable', with the specified +-- label attached to it. hunk ./Test/HUnit/Base.hs 226 + +-- $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". + hunk ./Test/HUnit/Base.hs 239 - + +-- | report generator for reporting the start of a test run. hunk ./Test/HUnit/Base.hs 242 - + +-- | report generator for reporting problems that have occurred during +-- a test run. Problems may be errors or assertion failures. hunk ./Test/HUnit/Base.hs 247 - --- 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) +-- | performs a test run with the specified report generators. +-- +-- 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) hunk ./Test/HUnit/Lang.hs 1 --- HUnit language support. +-- | HUnit language support. hunk ./Test/HUnit/Lang.hs 33 --- An assertion is an `IO` computation with trivial result. +-- | An assertion is an 'IO' computation with trivial result. An assertion or +-- a sequence of assertions makes up a test case. hunk ./Test/HUnit/Lang.hs 38 --- `assertFailure` signals an assertion failure with a given message. +-- | signals an assertion failure with a given message. hunk ./Test/HUnit/Lang.hs 40 -assertFailure :: String -> Assertion +assertFailure :: String -- ^ a message that is displayed with the assertion failure + -> Assertion hunk ./Test/HUnit/Lang.hs 43 --- `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 +-- | 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 hunk ./Test/HUnit/Lang.hs 51 -performTestCase :: Assertion -> IO (Maybe (Bool, String)) +performTestCase :: Assertion -- ^ an assertion to be made during the test case run + -> IO (Maybe (Bool, String)) hunk ./Test/HUnit/Terminal.hs 10 --- 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. +-- | 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. hunk ./Test/HUnit/Terminal.hs 16 --- 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. hunk ./Test/HUnit/Terminal.hs 20 + -- 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. hunk ./Test/HUnit/Text.hs 1 --- text-based test controller +-- | Text-based test controller for running HUnit tests and reporting +-- results as text, usually to a terminal. hunk ./Test/HUnit/Text.hs 20 --- 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`. +-- | 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'. hunk ./Test/HUnit/Text.hs 45 --- `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. +-- | 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. hunk ./Test/HUnit/Text.hs 64 --- `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. +-- | 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. hunk ./Test/HUnit/Text.hs 75 --- `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. +-- | 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. hunk ./Test/HUnit/Text.hs 95 --- `showCounts` converts test execution counts to a string. +-- | converts test execution counts to a string. hunk ./Test/HUnit/Text.hs 104 --- `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. +-- | 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. hunk ./Test/HUnit/Text.hs 117 --- `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". +-- | 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\". } Context: [--configure-option and --ghc-option are now provided by Cabal Ross Paterson **20070604115936] [FIX #476 (HUnit treats failures as errors) Simon Marlow **20070530100832 Patch submitted by stefanheimann via Trac ] [old nhc98 Makefiles now obsolete Malcolm.Wallace@cs.york.ac.uk**20070525133446] [remove Makefile.inc (only affects nhc98) Malcolm.Wallace@cs.york.ac.uk**20070320120854] [Remove Makefile and package.conf.in (used in the old GHC build system) Ian Lynagh **20070524145605] [TAG GHC 6.6.1 release Ian Lynagh **20070428195851] Patch bundle hash: 4dd2e2672e0214de4a0a84e1698fb1e17031732b