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