content: -- 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 re-using 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
  
  -- }}}
  