    -- | 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 a. a -> IO a
    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 a. a -> IO a
    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 a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> Int
    forall a. [a] -> 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 a. a -> m a
    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 :: forall st. PutText st -> Test -> IO (Counts, st)
    runTestText (PutText String -> Bool -> st -> IO st
    put st
    us0) Test
    t = do
      (counts', 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
      us2 <- put (showCounts counts') True us1
      return (counts', 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 a. [a] -> 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 a. (a -> a -> a) -> [a] -> a
    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 a. Eq a => a -> [a] -> 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', 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
                     return 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
      c <- Test -> IO Counts
    runTestTT Test
    tests
      if (errors c == 0) && (failures c == 0)
        then exitSuccess
        else exitFailure