    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