ConsoleReporter.hs

-- vim:fdm=marker
{-# LANGUAGE BangPatterns, ImplicitParams, MultiParamTypeClasses, FlexibleContexts, CApiFFI, NamedFieldPuns #-}
-- | Console reporter ingredient.
--
-- @since 0.11.3
module Test.Tasty.Ingredients.ConsoleReporter
  ( consoleTestReporter
  , consoleTestReporterWithHook
  , Quiet(..)
  , HideSuccesses(..)
  , MinDurationToReport(..)
  , AnsiTricks(..)
  -- * Internals
  -- | The following functions and datatypes are internals that are exposed to
  -- simplify the task of rolling your own custom console reporter UI.

  -- ** Output colouring
  , UseColor(..)
  , useColor
  -- ** Test failure statistics
  , Statistics(..)
  , computeStatistics
  , printStatistics
  , printStatisticsNoTime
  -- ** Outputting results
  , TestOutput(..)
  , buildTestOutput
  , foldTestOutput
  , withConsoleFormat
  ) where

import Prelude hiding (fail, EQ)
import Control.Monad (join, unless, void, when, (<=<))
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Reader (Reader, runReader, ask)
import Control.Monad.Trans.State (evalState, evalStateT, get, modify, put)
import Control.Concurrent.STM
import Control.Exception
import Test.Tasty.Core
import Test.Tasty.Providers.ConsoleFormat
import Test.Tasty.Run
import Test.Tasty.Ingredients
import Test.Tasty.Ingredients.ListTests
import Test.Tasty.Options
import Test.Tasty.Options.Core
import Test.Tasty.Patterns
import Test.Tasty.Patterns.Printer
import Test.Tasty.Patterns.Types
import Test.Tasty.Runners.Reducers
import Test.Tasty.Runners.Utils
import Text.Printf
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import Data.Char
#ifdef USE_WCWIDTH
import Foreign.C.Types (CInt(..), CWchar(..))
#endif
import Data.List (isInfixOf)
import Data.Maybe
import Data.Monoid (Any(..))
import qualified Data.Semigroup as Sem
import Data.Typeable
import Options.Applicative hiding (action, str, Success, Failure)
import System.IO
import System.Console.ANSI
#if !MIN_VERSION_base(4,11,0)
import Data.Foldable (foldMap)
#endif
import System.IO.Unsafe

--------------------------------------------------
-- TestOutput base definitions
--------------------------------------------------
-- {{{
-- | 'TestOutput' is an intermediary between output formatting and output
-- printing. It lets us have several different printing modes (normal; print
-- failures only; quiet).
--
-- @since 0.12
data TestOutput
  = -- | Printing a test.
    PrintTest
      String
        -- ^ Name of the test.
      (IO ())
        -- ^ Action that prints the test name.
      (Progress -> IO ())
        -- ^ Action that prints the progress of the test.  /Since: 1.5/
      (Result -> IO ())
        -- ^ Action that renders the result of the test.
  | -- | Printing a test group.
    PrintHeading
      String
        -- ^ Name of the test group
      (IO ())
        -- ^ Action that prints the heading of a test group.
      TestOutput
        -- ^ The 'TestOutput' for that test group.
  | -- | Inactive test (e.g. not matching the current pattern).
    Skip
  | -- | Two sets of 'TestOutput' on the same level.
    Seq TestOutput TestOutput

-- The monoid laws should hold observationally w.r.t. the semantics defined
-- in this module.
--
-- @since 0.12.0.1
instance Sem.Semigroup TestOutput where
  (<>) = Seq
instance Monoid TestOutput where
  mempty = Skip
#if !MIN_VERSION_base(4,11,0)
  mappend = (Sem.<>)
#endif

applyHook :: ([TestName] -> Result -> IO Result) -> TestOutput -> TestOutput
applyHook hook = go []
  where
    go path (PrintTest name printName printProgress printResult) =
      PrintTest name printName printProgress (printResult <=< hook (name : path))
    go path (PrintHeading name printName printBody) =
      PrintHeading name printName (go (name : path) printBody)
    go path (Seq a b) = Seq (go path a) (go path b)
    go _ Skip = mempty

type Level = Int

-- TODO before the next major release:
-- refactor this as an argument to 'buildTestOutput'
-- to avoid unsafePerformIO.
-- (We cannot add another argument to 'buildTestOutput'
-- in the middle of tasty-1.5 series, because it is exported)
terminalWidth :: Maybe Int
terminalWidth = unsafePerformIO $ do
  isTerminalStdin <- hIsTerminalDevice stdin
  if isTerminalStdin
  then fmap (fmap snd) getTerminalSize
  else pure Nothing
{-# NOINLINE terminalWidth #-}

-- | How wide could 'resultShortDescription' be (in non-extreme scenarios)?
-- Think of something like "OK", "FAIL (12.34s)", "TIMEOUT (100.00s)".
--
-- The field is freeform and test providers can put an arbitrarily long data,
-- so we just settle for a reasonable (over)approximation.
approxMaxResultShortDescriptionWidth :: Int
approxMaxResultShortDescriptionWidth = 20

-- | Build the 'TestOutput' for a 'TestTree' and 'OptionSet'. The @colors@
-- ImplicitParam controls whether the output is colored.
--
-- @since 0.11.3
buildTestOutput :: (?colors :: Bool) => OptionSet -> TestTree -> TestOutput
buildTestOutput opts tree =
  let
    -- Do not retain the reference to the tree more than necessary
    !rawAlignment = computeAlignment opts tree
    !alignment = case terminalWidth of
      Nothing -> rawAlignment
      Just width -> min (width - approxMaxResultShortDescriptionWidth) rawAlignment

    MinDurationToReport{minDurationMicros} = lookupOption opts

    runSingleTest
      :: (IsTest t, ?colors :: Bool)
      => OptionSet -> TestName -> t -> Ap (Reader Level) TestOutput
    runSingleTest _opts name _test = Ap $ do
      level <- ask

      let
        indentedNameWidth = indentSize * level + stringWidth name
        postNamePadding = alignment - indentedNameWidth

        testNamePadded = printf "%s%s: %s"
          (indent level)
          name
          (replicate postNamePadding ' ')

        printTestName = do
          withoutLineWrap $ putStr testNamePadded
          hFlush stdout

        printTestProgress progress
          -- We cannot display progress properly if a terminal
          -- does not support manipulations with cursor position.
          | not getAnsiTricks = pure ()

          | progress == emptyProgress = pure ()

          | otherwise = do
              let
                msg = case (cleanupProgressText $ progressText progress, 100 * progressPercent progress) of
                        ("",  pct) -> printf "%.0f%% " pct
                        (txt, 0.0) -> printf "%s" txt
                        (txt, pct) -> printf "%s: %.0f%% " txt pct
              putChar '\r'
              -- A new progress message may be shorter than the previous one
              -- so we must clean whole line and print anew.
              clearLine
              withoutLineWrap $ do
                putStr testNamePadded
                infoOk msg
              hFlush stdout

        printTestResult result = do
          rDesc <- formatMessage $ resultDescription result

          -- use an appropriate printing function
          let
            printFn =
              case resultOutcome result of
                Success -> ok
                Failure TestDepFailed -> skipped
                _ -> fail
            time = resultTime result

          withoutLineWrap $ do
            when getAnsiTricks $ do
              putChar '\r'
              clearLine
              putStr testNamePadded

          printFn (resultShortDescription result)
          when (floor (time * 1e6) >= minDurationMicros) $
            printFn (printf " (%.2fs)" time)
          printFn "\n"

          when (not $ null rDesc) $
            (if resultSuccessful result then infoOk else infoFail) $
              printf "%s%s\n" (indent $ level + 1) (formatDesc (level+1) rDesc)
          case resultDetailsPrinter result of
            ResultDetailsPrinter action -> action level withConsoleFormat

      return $ PrintTest name printTestName printTestProgress printTestResult

    runGroup :: OptionSet -> TestName -> [Ap (Reader Level) TestOutput] -> Ap (Reader Level) TestOutput
    runGroup _opts name grp = Ap $ do
      level <- ask
      let
        printHeading = withoutLineWrap $ printf "%s%s\n" (indent level) name
        printBody = runReader (getApp (mconcat grp)) (level + 1)
      return $ PrintHeading name printHeading printBody

  in
    flip runReader 0 $ getApp $
      foldTestTree
        trivialFold
          { foldSingle = runSingleTest
          , foldGroup = runGroup
          }
          opts tree
  where
    AnsiTricks{getAnsiTricks} = lookupOption opts
    -- We must ensure these lines don't wrap, otherwise the wrong
    -- line will be cleared later or the test tree printing will
    -- itself wrap.
    withoutLineWrap :: IO () -> IO ()
#if MIN_VERSION_ansi_terminal(1,1,2)
    withoutLineWrap m | getAnsiTricks =
      bracket_ disableLineWrap enableLineWrap m
#endif
    withoutLineWrap m = m


-- | Make sure the progress text does not contain any newlines or line feeds,
-- lest our ANSI magic breaks. Since the progress text is expected to be short,
-- we simply drop anything after a newline.
cleanupProgressText :: String -> String
cleanupProgressText = map (\c -> if isSpace c then ' ' else c)
                    . takeWhile (\c -> c /= '\n' && c /= '\r' && c /= '\t')

-- | Fold function for the 'TestOutput' tree into a 'Monoid'.
--
-- @since 0.12
foldTestOutput
  :: Monoid b
  => (String -> IO () -> IO Result -> (Result -> IO ()) -> b)
  -- ^ Eliminator for test cases. The @IO ()@ prints the testname. The
  -- @IO Result@ blocks until the test is finished, returning it's 'Result'.
  -- The @Result -> IO ()@ function prints the formatted output.
  -> (String -> IO () -> b -> b)
  -- ^ Eliminator for test groups. The @IO ()@ prints the test group's name.
  -- The @b@ is the result of folding the test group.
  -> TestOutput -- ^ The @TestOutput@ being rendered.
  -> StatusMap -- ^ The @StatusMap@ received by the 'TestReporter'
  -> b
foldTestOutput foldTest foldHeading outputTree smap =
  flip evalState 0 $ getApp $ go outputTree where

  go (PrintTest name printName printProgress printResult) = Ap $ do
    ix <- get
    put $! ix + 1
    let
      statusVar =
        fromMaybe (error "internal error: index out of bounds") $
        IntMap.lookup ix smap

    return $ foldTest name printName (ppProgressOrResult statusVar printProgress) printResult

  go (PrintHeading name printName printBody) = Ap $
    foldHeading name printName <$> getApp (go printBody)
  go (Seq a b) = mappend (go a) (go b)
  go Skip = mempty

-- }}}

--------------------------------------------------
-- TestOutput modes
--------------------------------------------------

ppProgressOrResult :: TVar Status -> (Progress -> IO ()) -> IO Result
ppProgressOrResult statusVar ppProgress = go emptyProgress where
  go old_p = either (\p -> ppProgress p *> go p) return =<< (atomically $ do
    status <- readTVar statusVar
    case status of
      Executing p
        | p == old_p -> retry
        | otherwise -> pure $ Left p
      Done r      -> pure $ Right r
      _           -> retry
    )

-- {{{
consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()
consoleOutput toutput smap =
  getTraversal . fst $ foldTestOutput foldTest foldHeading toutput smap
  where
    foldTest _name printName getResult printResult =
      ( Traversal $ do
          printName :: IO ()
          r <- getResult
          printResult r
      , Any True)
    foldHeading _name printHeading (printBody, Any nonempty) =
      ( Traversal $ do
          when nonempty $ do
            printHeading :: IO ()
            getTraversal printBody
      , Any nonempty
      )

consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()
consoleOutputHidingSuccesses toutput smap =
  void . getApp $ foldTestOutput foldTest foldHeading toutput smap
  where
    foldTest _name printName getResult printResult =
      Ap $ do
          printName :: IO ()
          r <- getResult
          if resultSuccessful r
            then do clearThisLine; return $ Any False
            else do printResult r :: IO (); return $ Any True

    foldHeading _name printHeading printBody =
      Ap $ do
        printHeading :: IO ()
        Any failed <- getApp printBody
        unless failed clearAboveLine
        return $ Any failed

    clearAboveLine = do cursorUpLine 1; clearThisLine
    clearThisLine = do clearLine; setCursorColumn 0

streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()
streamOutputHidingSuccesses toutput smap =
  void . flip evalStateT [] . getApp $
    foldTestOutput foldTest foldHeading toutput smap
  where
    foldTest _name printName getResult printResult =
      Ap $ do
          r <- liftIO $ getResult
          if resultSuccessful r
            then return $ Any False
            else do
              stack <- get
              put []

              liftIO $ do
                sequence_ $ reverse stack
                printName :: IO ()
                printResult r :: IO ()

              return $ Any True

    foldHeading _name printHeading printBody =
      Ap $ do
        modify (printHeading :)
        Any failed <- getApp printBody
        unless failed $
          modify $ \stack ->
            case stack of
              _:rest -> rest
              [] -> [] -- shouldn't happen anyway
        return $ Any failed

-- }}}

--------------------------------------------------
-- Statistics
--------------------------------------------------
-- {{{

-- | Track the number of tests that were run and failures of a 'TestTree' or
-- sub-tree.
--
-- @since 0.11.3
data Statistics = Statistics
  { statTotal :: !Int -- ^ Number of active tests (e.g., that match the
                      -- pattern specified on the commandline), inactive tests
                      -- are not counted.
  , statFailures :: !Int -- ^ Number of active tests that failed.
  }

-- | @since 0.12.0.1
instance Sem.Semigroup Statistics where
  Statistics t1 f1 <> Statistics t2 f2 = Statistics (t1 + t2) (f1 + f2)
instance Monoid Statistics where
  mempty = Statistics 0 0
#if !MIN_VERSION_base(4,11,0)
  mappend = (Sem.<>)
#endif

-- | @computeStatistics@ computes a summary 'Statistics' for
-- a given state of the 'StatusMap'.
-- Useful in combination with 'printStatistics'.
--
-- @since 1.2.3
computeStatistics :: StatusMap -> IO Statistics
computeStatistics = getApp . foldMap (\var -> Ap $
  (\r -> Statistics 1 (if resultSuccessful r then 0 else 1))
    <$> getResultFromTVar var)

reportStatistics :: (?colors :: Bool) => Statistics -> IO ()
reportStatistics st = case statFailures st of
    0 -> ok $ printf "All %d tests passed" (statTotal st)
    fs -> fail $ printf "%d out of %d tests failed" fs (statTotal st)

-- | @printStatistics@ reports test success/failure statistics and time it took
-- to run. The 'Time' results is intended to be filled in by the 'TestReporter'
-- callback. The @colors@ ImplicitParam controls whether coloured output is
-- used.
--
-- @since 0.11.3
printStatistics :: (?colors :: Bool) => Statistics -> Time -> IO ()
printStatistics st time = do
  printf "\n"
  reportStatistics st
  case statFailures st of
    0 -> ok $ printf " (%.2fs)\n" time
    _ -> fail $ printf " (%.2fs)\n" time

-- | @printStatisticsNoTime@ reports test success/failure statistics
-- The @colors@ ImplicitParam controls whether coloured output is used.
--
-- @since 0.12
printStatisticsNoTime :: (?colors :: Bool) => Statistics -> IO ()
printStatisticsNoTime st = reportStatistics st >> printf "\n"

-- | Wait until
--
-- * all tests have finished successfully, and return 'True', or
--
-- * at least one test has failed, and return 'False'
statusMapResult
  :: Int -- ^ lookahead
  -> StatusMap
  -> IO Bool
statusMapResult lookahead0 smap
  | IntMap.null smap = return True
  | otherwise =
      join . atomically $
        IntMap.foldrWithKey f finish smap mempty lookahead0
  where
    f :: Int
      -> TVar Status
      -> (IntSet.IntSet -> Int -> STM (IO Bool))
      -> (IntSet.IntSet -> Int -> STM (IO Bool))
    -- ok_tests is a set of tests that completed successfully
    -- lookahead is the number of unfinished tests that we are allowed to
    -- look at
    f key tvar k ok_tests lookahead
      | lookahead <= 0 =
          -- We looked at too many unfinished tests.
          next_iter ok_tests
      | otherwise = do
          this_status <- readTVar tvar
          case this_status of
            Done r ->
              if resultSuccessful r
                then k (IntSet.insert key ok_tests) lookahead
                else return $ return False
            _ -> k ok_tests (lookahead-1)

    -- next_iter is called when we end the current iteration,
    -- either because we reached the end of the test tree
    -- or because we exhausted the lookahead
    next_iter :: IntSet.IntSet -> STM (IO Bool)
    next_iter ok_tests =
      -- If we made no progress at all, wait until at least some tests
      -- complete.
      -- Otherwise, reduce the set of tests we are looking at.
      if IntSet.null ok_tests
        then retry
        else return $ statusMapResult lookahead0 (IntMap.withoutKeys smap ok_tests)

    finish :: IntSet.IntSet -> Int -> STM (IO Bool)
    finish ok_tests _ = next_iter ok_tests

-- }}}

--------------------------------------------------
-- Console test reporter
--------------------------------------------------
-- {{{

-- | A simple console UI.
--
-- @since 0.4
consoleTestReporter :: Ingredient
consoleTestReporter = TestReporter consoleTestReporterOptions $ \opts tree ->
  let
    TestPattern pattern = lookupOption opts
    tests = testsNames opts tree
    hook = (return .) . appendPatternIfTestFailed tests pattern
    TestReporter _ cb = consoleTestReporterWithHook hook
  in cb opts tree

appendPatternIfTestFailed
  :: [TestName] -- ^ list of (pre-intercalated) test names
  -> Maybe Expr -- ^ current pattern, if any
  -> [TestName] -- ^ name of current test, represented as a list of group names
  -> Result     -- ^ vanilla result
  -> Result
appendPatternIfTestFailed [_] _ _ res = res -- if there is only one test, nothing to refine
appendPatternIfTestFailed _ _ [] res  = res -- should be impossible
appendPatternIfTestFailed tests currentPattern (name : names) res = case resultOutcome res of
  Success -> res
  Failure{} -> res { resultDescription = resultDescription res ++ msg }
  where
    msg = "\nUse -p '" ++ escapeQuotes (printAwkExpr pattern) ++ "' to rerun this test only."

    escapeQuotes = concatMap $ \c -> if c == '\'' then "'\\''" else [c]

    findPattern [_] pat _ = ERE pat
    findPattern _  pat [] = EQ (Field (IntLit 0)) (StringLit pat)
    findPattern ts pat (n : ns) = let pat' = n ++ '.' : pat in
      findPattern (filter (pat' `isInfixOf`) ts) pat' ns

    individualPattern = findPattern (filter (name `isInfixOf`) tests) name names

    pattern = maybe id And currentPattern individualPattern

consoleTestReporterOptions :: [OptionDescription]
consoleTestReporterOptions =
  [ Option (Proxy :: Proxy Quiet)
  , Option (Proxy :: Proxy HideSuccesses)
  , Option (Proxy :: Proxy MinDurationToReport)
  , Option (Proxy :: Proxy UseColor)
  , Option (Proxy :: Proxy AnsiTricks)
  ]

-- | A simple console UI with a hook to postprocess results,
-- depending on their names and external conditions
-- (e. g., its previous outcome, stored in a file).
-- Names are listed in reverse order:
-- from test's own name to a name of the outermost test group.
--
-- @since 1.4.2
consoleTestReporterWithHook :: ([TestName] -> Result -> IO Result) -> Ingredient
consoleTestReporterWithHook hook = TestReporter consoleTestReporterOptions $
  \opts tree -> Just $ \smap -> do

  let
    whenColor = lookupOption opts
    Quiet quiet = lookupOption opts
    HideSuccesses hideSuccesses = lookupOption opts
    NumThreads numThreads = lookupOption opts
    AnsiTricks ansiTricks = lookupOption opts

  if quiet
    then do
      b <- statusMapResult numThreads smap
      return $ \_time -> return b
    else

      do
      isTerm <- hSupportsANSI stdout
      isTermColor <- hSupportsANSIColor stdout

      (\k -> if isTerm
        -- When killing with Ctrl+C 'showCursor' can fail
        -- to restore terminal cursor if not flushed explicitly
        then (do hideCursor; k) `finally` (do showCursor; hFlush stdout)
        else k) $ do

          hSetBuffering stdout LineBuffering

          let
            ?colors = useColor whenColor isTermColor

          let
            -- 'buildTestOutput' is a pure function and cannot query 'hSupportsANSI' itself.
            -- We also would rather not pass @isTerm@ as an extra argument,
            -- since it's a breaking change, thus resorting to tweaking @opts@.
            opts' = changeOption (\(AnsiTricks x) -> AnsiTricks (x && isTerm)) opts
            toutput = applyHook hook $ buildTestOutput opts' tree

          case () of { _
            | hideSuccesses && isTerm && ansiTricks ->
                consoleOutputHidingSuccesses toutput smap
            | hideSuccesses ->
                streamOutputHidingSuccesses toutput smap
            | otherwise -> consoleOutput toutput smap
          }

          return $ \time -> do
            stats <- computeStatistics smap
            printStatistics stats time
            return $ statFailures stats == 0

-- | Do not print test results (see README for details).
--
-- @since 0.8
newtype Quiet = Quiet Bool
  deriving (Eq, Ord)
instance IsOption Quiet where
  defaultValue = Quiet False
  parseValue = fmap Quiet . safeReadBool
  optionName = return "quiet"
  optionHelp = return "Do not produce any output; indicate success only by the exit code"
  optionCLParser = mkFlagCLParser (short 'q') (Quiet True)

-- | Report only failed tests.
--
-- At the moment, this option only works globally. As an argument
-- to 'Test.Tasty.localOption', it does nothing.
--
-- @since 0.8
newtype HideSuccesses = HideSuccesses Bool
  deriving (Eq, Ord)
instance IsOption HideSuccesses where
  defaultValue = HideSuccesses False
  parseValue = fmap HideSuccesses . safeReadBool
  optionName = return "hide-successes"
  optionHelp = return "Do not print tests that passed successfully"
  optionCLParser = mkFlagCLParser mempty (HideSuccesses True)

-- | The minimum amount of time a test can take before tasty
-- prints timing information.
--
-- @since 1.5
newtype MinDurationToReport = MinDurationToReport { minDurationMicros :: Integer }
  deriving (Eq, Ord)
instance IsOption MinDurationToReport where
  defaultValue = MinDurationToReport 10000
  parseValue = fmap MinDurationToReport . parseDuration
  optionName = return "min-duration-to-report"
  optionHelp =
    return . unwords $
      [ "The minimum amount of time a test can take before tasty prints timing information"
      , "(suffixes: ms,s,m,h; default: s)"
      ]
  optionCLParser = mkOptionCLParser (metavar "DURATION")

-- | When to use color on the output
--
-- @since 0.11.3
data UseColor
  = Never
  | Always
  | Auto -- ^ Only if stdout is an ANSI color supporting terminal
  deriving (Eq, Ord)

-- | Control color output
instance IsOption UseColor where
  defaultValue = Auto
  parseValue = parseUseColor
  optionName = return "color"
  optionHelp = return "When to use colored output"
  optionCLParser = mkOptionCLParser $ metavar "never|always|auto"
  showDefaultValue = Just . displayUseColor

-- | By default, when the option @--hide-successes@ is given and the output
-- goes to an ANSI-capable terminal, we employ some ANSI terminal tricks to
-- display the name of the currently running test and then erase it if it
-- succeeds.
--
-- These tricks sometimes fail, however—in particular, when the test names
-- happen to be longer than the width of the terminal window. See
--
-- * <https://github.com/UnkindPartition/tasty/issues/152>
--
-- * <https://github.com/UnkindPartition/tasty/issues/250>
--
-- When that happens, this option can be used to disable the tricks. In
-- that case, the test name will be printed only once the test fails.
--
-- @since 1.3
newtype AnsiTricks = AnsiTricks { getAnsiTricks :: Bool }

instance IsOption AnsiTricks where
  defaultValue = AnsiTricks True
  parseValue = fmap AnsiTricks . safeReadBool
  optionName = return "ansi-tricks"
  optionHelp = return $
    -- Multiline literals don't work because of -XCPP.
    "Enable various ANSI terminal tricks. " ++
    "Can be set to 'true' or 'false'."
  showDefaultValue = Just . displayBool . getAnsiTricks

displayBool :: Bool -> String
displayBool b =
  case b of
    False -> "false"
    True  -> "true"

-- | @useColor when isTerm@ decides if colors should be used,
--   where @isTerm@ indicates whether @stdout@ is a terminal device.
--
--   @since 0.11.3
useColor :: UseColor -> Bool -> Bool
useColor when_ isTerm =
  case when_ of
    Never  -> False
    Always -> True
    Auto   -> isTerm

parseUseColor :: String -> Maybe UseColor
parseUseColor s =
  case map toLower s of
    "never"  -> return Never
    "always" -> return Always
    "auto"   -> return Auto
    _        -> Nothing

displayUseColor :: UseColor -> String
displayUseColor uc =
  case uc of
    Never  -> "never"
    Always -> "always"
    Auto   -> "auto"

-- }}}

--------------------------------------------------
-- Various utilities
--------------------------------------------------
-- {{{
getResultFromTVar :: TVar Status -> IO Result
getResultFromTVar var =
  atomically $ do
    status <- readTVar var
    case status of
      Done r -> return r
      _ -> retry

-- }}}

--------------------------------------------------
-- Formatting
--------------------------------------------------
-- {{{

indentSize :: Int
indentSize = 2

indent :: Int -> String
indent n = replicate (indentSize * n) ' '

-- handle multi-line result descriptions properly
formatDesc
  :: Int -- indent
  -> String
  -> String
formatDesc n desc =
  let
    -- remove all trailing linebreaks
    chomped = reverse . dropWhile (== '\n') . reverse $ desc

    multiline = '\n' `elem` chomped

    -- we add a leading linebreak to the description, to start it on a new
    -- line and add an indentation
    paddedDesc = flip concatMap chomped $ \c ->
      if c == '\n'
        then c : indent n
        else [c]
  in
    if multiline
      then paddedDesc
      else chomped

-- | Compute the amount of space needed to align \"OK\"s and \"FAIL\"s
computeAlignment :: OptionSet -> TestTree -> Int
computeAlignment opts =
  max 0 .
  foldTestTree0
    minBound
    TreeFold
      { foldSingle = \_ name _ -> stringWidth name
      , foldGroup = \_ _ m -> if null m then minBound else maximum m + indentSize
      , foldResource = \_ _ f -> f $ throwIO NotRunningTests
      , foldAfter = \_ _ _ b -> b
      }
    opts

-- | Compute the length/width of the string as it would appear in a monospace
--   terminal. This takes into account that even in a “mono”space font, not
--   all characters actually have the same width, in particular, most CJK
--   characters have twice the same as Western characters.
--
--   (This only works properly on Unix at the moment; on Windows, the function
--   treats every character as width-1 like 'Data.List.length' does.)
stringWidth :: String -> Int
#ifdef USE_WCWIDTH
stringWidth = Prelude.sum . map charWidth
 where charWidth c = case wcwidth (fromIntegral (ord c)) of
        -1 -> 1  -- many chars have "undefined" width; default to 1 for these.
        w  -> fromIntegral w
foreign import capi safe "wchar.h wcwidth" wcwidth :: CWchar -> CInt
#else
stringWidth = length
#endif

-- (Potentially) colorful output
ok, fail, skipped, infoOk, infoFail :: (?colors :: Bool) => String -> IO ()
fail     = output failFormat
ok       = output okFormat
skipped  = output skippedFormat
-- Just default foreground color for 'infoOk'; do not apply 'infoOkFormat',
-- because terminal's background could be white itself. See #298.
infoOk   = putStr
infoFail = output infoFailFormat

output
  :: (?colors :: Bool)
  => ConsoleFormat
  -> String
  -> IO ()
output format = withConsoleFormat format . putStr

-- | Run action with console configured for a specific output format
--
-- This function does not apply any output formats if colors are disabled at command
-- line or console detection.
--
-- Can be used by providers that wish to provider specific result details printing,
-- while reusing the tasty formats and coloring logic.
--
-- @since 1.3.1
withConsoleFormat :: (?colors :: Bool) => ConsoleFormatPrinter
withConsoleFormat format action
  | ?colors =
    (do
      setSGR
        [ SetColor Foreground (colorIntensity format) (color format)
        , SetConsoleIntensity (consoleIntensity format)
        ]
      action
    ) `finally` setSGR []
  | otherwise = action

-- }}}