-- | Text-based test controller for running HUnit tests and reporting
--   results as text, usually to a terminal.

module Test.HUnit.Text
(
  PutText(..),
  putTextToHandle, putTextToShowS,
  runTestText,
  showPath, showCounts,
  runTestTT,
  runTestTTAndExit
)
where

import Test.HUnit.Base

import Data.CallStack
import Control.Monad (when)
import System.IO (Handle, stderr, hPutStr, hPutStrLn)
import System.Exit (exitSuccess, exitFailure)


-- | 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 -- ^ Write progress lines to handle?
    -> PutText Int
putTextToHandle :: Handle -> Bool -> PutText Int
putTextToHandle Handle
handle Bool
showProgress = (String -> Bool -> Int -> IO Int) -> Int -> PutText Int
forall st. (String -> Bool -> st -> IO st) -> st -> PutText st
PutText String -> Bool -> Int -> IO Int
put Int
initCnt
 where
  initCnt :: Int
initCnt = if Bool
showProgress then Int
0 else -Int
1
  put :: String -> Bool -> Int -> IO Int
put String
line Bool
pers (-1) = do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pers (Handle -> String -> IO ()
hPutStrLn Handle
handle String
line); Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (-Int
1)
  put String
line Bool
True  Int
cnt = do Handle -> String -> IO ()
hPutStrLn Handle
handle (Int -> String
erase Int
cnt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
line); Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
  put String
line Bool
False Int
_   = do Handle -> String -> IO ()
hPutStr Handle
handle (Char
'\r' Char -> String -> String
forall a. a -> [a] -> [a]
: String
line); Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
line)
    -- The "erasing" strategy with a single '\r' relies on the fact that the
    -- lengths of successive summary lines are monotonically nondecreasing.
  erase :: Int -> String
erase Int
cnt = if Int
cnt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then String
"" else String
"\r" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
cnt Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\r"


-- | 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 (String -> String)
putTextToShowS = (String -> Bool -> (String -> String) -> IO (String -> String))
-> (String -> String) -> PutText (String -> String)
forall st. (String -> Bool -> st -> IO st) -> st -> PutText st
PutText String -> Bool -> (String -> String) -> IO (String -> String)
forall (m :: * -> *) t.
Monad m =>
String -> Bool -> (String -> t) -> m (String -> t)
put String -> String
forall a. a -> a
id
 where put :: String -> Bool -> (String -> t) -> m (String -> t)
put String
line Bool
pers String -> t
f = (String -> t) -> m (String -> t)
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
pers then (String -> t) -> String -> String -> t
forall t. (String -> t) -> String -> String -> t
acc String -> t
f String
line else String -> t
f)
       acc :: (String -> t) -> String -> String -> t
acc String -> t
f String
line String
rest = String -> t
f (String
line String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest)


-- | 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 st -> Test -> IO (Counts, st)
runTestText (PutText String -> Bool -> st -> IO st
put st
us0) Test
t = do
  (Counts
counts', st
us1) <- ReportStart st
-> ReportProblem st
-> ReportProblem st
-> st
-> Test
-> IO (Counts, st)
forall us.
ReportStart us
-> ReportProblem us
-> ReportProblem us
-> us
-> Test
-> IO (Counts, us)
performTest ReportStart st
reportStart ReportProblem st
reportError ReportProblem st
reportFailure st
us0 Test
t
  st
us2 <- String -> Bool -> st -> IO st
put (Counts -> String
showCounts Counts
counts') Bool
True st
us1
  (Counts, st) -> IO (Counts, st)
forall (m :: * -> *) a. Monad m => a -> m a
return (Counts
counts', st
us2)
 where
  reportStart :: ReportStart st
reportStart State
ss st
us = String -> Bool -> st -> IO st
put (Counts -> String
showCounts (State -> Counts
counts State
ss)) Bool
False st
us
  reportError :: ReportProblem st
reportError   = String -> String -> ReportProblem st
reportProblem String
"Error:"   String
"Error in:   "
  reportFailure :: ReportProblem st
reportFailure = String -> String -> ReportProblem st
reportProblem String
"Failure:" String
"Failure in: "
  reportProblem :: String -> String -> ReportProblem st
reportProblem String
p0 String
p1 Maybe SrcLoc
loc String
msg State
ss st
us = String -> Bool -> st -> IO st
put String
line Bool
True st
us
   where line :: String
line  = String
"### " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
kind String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe SrcLoc -> String
formatLocation Maybe SrcLoc
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
         kind :: String
kind  = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path' then String
p0 else String
p1
         path' :: String
path' = Path -> String
showPath (State -> Path
path State
ss)

formatLocation :: Maybe SrcLoc -> String
formatLocation :: Maybe SrcLoc -> String
formatLocation Maybe SrcLoc
Nothing = String
""
formatLocation (Just SrcLoc
loc) = SrcLoc -> String
srcLocFile SrcLoc
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (SrcLoc -> Int
srcLocStartLine SrcLoc
loc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

-- | Converts test execution counts to a string.

showCounts :: Counts -> String
showCounts :: Counts -> String
showCounts Counts{ cases :: Counts -> Int
cases = Int
cases', tried :: Counts -> Int
tried = Int
tried',
                   errors :: Counts -> Int
errors = Int
errors', failures :: Counts -> Int
failures = Int
failures' } =
  String
"Cases: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
cases' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  Tried: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
tried' String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"  Errors: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
errors' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  Failures: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
failures'


-- | 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.

showPath :: Path -> String
showPath :: Path -> String
showPath [] = String
""
showPath Path
nodes = (String -> String -> String) -> [String] -> String
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 String -> String -> String
f ((Node -> String) -> Path -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Node -> String
showNode Path
nodes)
 where f :: String -> String -> String
f String
b String
a = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b
       showNode :: Node -> String
showNode (ListItem Int
n) = Int -> String
forall a. Show a => a -> String
show Int
n
       showNode (Label String
label) = String -> String -> String
safe String
label (String -> String
forall a. Show a => a -> String
show String
label)
       safe :: String -> String -> String
safe String
s String
ss = if Char
':' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
s Bool -> Bool -> Bool
|| String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
ss then String
ss else String
s


-- | 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 :: Test -> IO Counts
runTestTT Test
t = do (Counts
counts', Int
0) <- PutText Int -> Test -> IO (Counts, Int)
forall st. PutText st -> Test -> IO (Counts, st)
runTestText (Handle -> Bool -> PutText Int
putTextToHandle Handle
stderr Bool
True) Test
t
                 Counts -> IO Counts
forall (m :: * -> *) a. Monad m => a -> m a
return Counts
counts'

-- | Convenience wrapper for 'runTestTT'.
--   Simply runs 'runTestTT' and then exits back to the OS,
--   using 'exitSuccess' if there were no errors or failures,
--   or 'exitFailure' if there were. For example:
--
--   > tests :: Test
--   > tests = ...
--   >
--   > main :: IO ()
--   > main = runTestTTAndExit tests

runTestTTAndExit :: Test -> IO ()
runTestTTAndExit :: Test -> IO ()
runTestTTAndExit Test
tests = do
  Counts
c <- Test -> IO Counts
runTestTT Test
tests
  if (Counts -> Int
errors Counts
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) Bool -> Bool -> Bool
&& (Counts -> Int
failures Counts
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
    then IO ()
forall a. IO a
exitSuccess
    else IO ()
forall a. IO a
exitFailure