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