{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
module Test.Hspec.Core.Formatters.Internal (
  Formatter(..)
, Item(..)
, Result(..)
, FailureReason(..)
, FormatM
, formatterToFormat

, getConfig
, getConfigValue
, FormatConfig(..)

, getSuccessCount
, getPendingCount
, getFailCount
, getTotalCount
, getExpectedTotalCount

, FailureRecord(..)
, getFailMessages
, usedSeed

, printTimes
, getCPUTime
, getRealTime

, write
, writeLine
, writeTransient

, withInfoColor
, withSuccessColor
, withPendingColor
, withFailColor

, outputUnicode

, useDiff
, diffContext
, externalDiffAction
, prettyPrint
, prettyPrintFunction
, extraChunk
, missingChunk

, unlessExpert

#ifdef TEST
, runFormatM
, splitLines
#endif
) where

import           Prelude ()
import           Test.Hspec.Core.Compat

import qualified System.IO as IO
import           System.IO (stdout)
import           System.Console.ANSI
import           Control.Monad.Trans.Reader (ReaderT(..), ask)
import           Control.Monad.IO.Class
import           Data.Char (isSpace)
import           Data.List (groupBy)
import qualified System.CPUTime as CPUTime

import           Test.Hspec.Core.Format
import           Test.Hspec.Core.Clock

data Formatter = Formatter {
-- | evaluated before a test run
  Formatter -> FormatM ()
formatterStarted :: FormatM ()

-- | evaluated before each spec group
, Formatter -> Path -> FormatM ()
formatterGroupStarted :: Path -> FormatM ()

-- | evaluated after each spec group
, Formatter -> Path -> FormatM ()
formatterGroupDone :: Path -> FormatM ()

-- | used to notify the progress of the currently evaluated example
, Formatter -> Path -> Progress -> FormatM ()
formatterProgress :: Path -> Progress -> FormatM ()

-- | evaluated before each spec item
, Formatter -> Path -> FormatM ()
formatterItemStarted :: Path -> FormatM ()

-- | evaluated after each spec item
, Formatter -> Path -> Item -> FormatM ()
formatterItemDone :: Path -> Item -> FormatM ()

-- | evaluated after a test run
, Formatter -> FormatM ()
formatterDone :: FormatM ()
}

data FailureRecord = FailureRecord {
  FailureRecord -> Maybe Location
failureRecordLocation :: Maybe Location
, FailureRecord -> Path
failureRecordPath     :: Path
, FailureRecord -> FailureReason
failureRecordMessage  :: FailureReason
}

formatterToFormat :: Formatter -> FormatConfig -> IO Format
formatterToFormat :: Formatter -> FormatConfig -> IO Format
formatterToFormat Formatter{FormatM ()
Path -> FormatM ()
Path -> Progress -> FormatM ()
Path -> Item -> FormatM ()
formatterDone :: FormatM ()
formatterItemDone :: Path -> Item -> FormatM ()
formatterItemStarted :: Path -> FormatM ()
formatterProgress :: Path -> Progress -> FormatM ()
formatterGroupDone :: Path -> FormatM ()
formatterGroupStarted :: Path -> FormatM ()
formatterStarted :: FormatM ()
formatterDone :: Formatter -> FormatM ()
formatterItemDone :: Formatter -> Path -> Item -> FormatM ()
formatterItemStarted :: Formatter -> Path -> FormatM ()
formatterProgress :: Formatter -> Path -> Progress -> FormatM ()
formatterGroupDone :: Formatter -> Path -> FormatM ()
formatterGroupStarted :: Formatter -> Path -> FormatM ()
formatterStarted :: Formatter -> FormatM ()
..} FormatConfig
config = forall (m :: * -> *).
MonadIO m =>
(m () -> IO ()) -> (Event -> m ()) -> IO Format
monadic (forall a. FormatConfig -> FormatM a -> IO a
runFormatM FormatConfig
config) forall a b. (a -> b) -> a -> b
$ \ case
  Event
Started -> FormatM ()
formatterStarted
  GroupStarted Path
path -> Path -> FormatM ()
formatterGroupStarted Path
path
  GroupDone Path
path -> Path -> FormatM ()
formatterGroupDone Path
path
  Progress Path
path Progress
progress -> Path -> Progress -> FormatM ()
formatterProgress Path
path Progress
progress
  ItemStarted Path
path -> Path -> FormatM ()
formatterItemStarted Path
path
  ItemDone Path
path Item
item -> do
    case Item -> Result
itemResult Item
item of
      Success {} -> FormatM ()
increaseSuccessCount
      Pending {} -> FormatM ()
increasePendingCount
      Failure Maybe Location
loc FailureReason
err -> FailureRecord -> FormatM ()
addFailure forall a b. (a -> b) -> a -> b
$ Maybe Location -> Path -> FailureReason -> FailureRecord
FailureRecord (Maybe Location
loc forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Item -> Maybe Location
itemLocation Item
item) Path
path FailureReason
err
    Path -> Item -> FormatM ()
formatterItemDone Path
path Item
item
  Done [(Path, Item)]
_ -> FormatM ()
formatterDone
  where
    addFailure :: FailureRecord -> FormatM ()
addFailure FailureRecord
r = (FormatterState -> FormatterState) -> FormatM ()
modify forall a b. (a -> b) -> a -> b
$ \ FormatterState
s -> FormatterState
s { stateFailMessages :: [FailureRecord]
stateFailMessages = FailureRecord
r forall a. a -> [a] -> [a]
: FormatterState -> [FailureRecord]
stateFailMessages FormatterState
s }

-- | Get the number of failed examples encountered so far.
getFailCount :: FormatM Int
getFailCount :: FormatM Int
getFailCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormatM [FailureRecord]
getFailMessages

-- | Return `True` if the user requested colorized diffs, `False` otherwise.
useDiff :: FormatM Bool
useDiff :: FormatM Bool
useDiff = forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Bool
formatConfigUseDiff

-- | Do nothing on `--expert`, otherwise run the given action.
--
-- @since 2.11.2
unlessExpert :: FormatM () -> FormatM ()
unlessExpert :: FormatM () -> FormatM ()
unlessExpert FormatM ()
action = forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Bool
formatConfigExpertMode forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
  Bool
False -> FormatM ()
action
  Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- |
-- Return the value of `Test.Hspec.Core.Runner.configDiffContext`.
--
-- @since 2.10.6
diffContext :: FormatM (Maybe Int)
diffContext :: FormatM (Maybe Int)
diffContext = forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Maybe Int
formatConfigDiffContext

-- | An action for printing diffs.
--
-- The action takes @expected@ and @actual@ as arguments.
--
-- When this is a `Just`-value then it should be used instead of any built-in
-- diff implementation.  A `Just`-value also implies that `useDiff` returns
-- `True`.
--
-- @since 2.10.6
externalDiffAction :: FormatM (Maybe (String -> String -> IO ()))
externalDiffAction :: FormatM (Maybe (String -> String -> IO ()))
externalDiffAction = forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Maybe (String -> String -> IO ())
formatConfigExternalDiff

-- | Return `True` if the user requested pretty diffs, `False` otherwise.
prettyPrint :: FormatM Bool
prettyPrint :: FormatM Bool
prettyPrint = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a b. a -> b -> a
const Bool
True) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Maybe (String -> String -> (String, String))
formatConfigPrettyPrintFunction
{-# DEPRECATED prettyPrint "use `prettyPrintFunction` instead" #-}

-- | Return a function for pretty-printing if the user requested pretty diffs,
-- `Nothing` otherwise.
--
-- @since 2.10.0
prettyPrintFunction :: FormatM (Maybe (String -> String -> (String, String)))
prettyPrintFunction :: FormatM (Maybe (String -> String -> (String, String)))
prettyPrintFunction = forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Maybe (String -> String -> (String, String))
formatConfigPrettyPrintFunction

-- | Return `True` if the user requested unicode output, `False` otherwise.
--
-- @since 2.9.0
outputUnicode :: FormatM Bool
outputUnicode :: FormatM Bool
outputUnicode = forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Bool
formatConfigOutputUnicode

-- | The same as `write`, but adds a newline character.
writeLine :: String -> FormatM ()
writeLine :: String -> FormatM ()
writeLine String
s = String -> FormatM ()
write String
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> FormatM ()
write String
"\n"

-- | Return `True` if the user requested time reporting for individual spec
-- items, `False` otherwise.
printTimes :: FormatM Bool
printTimes :: FormatM Bool
printTimes = forall a. (FormatterState -> a) -> FormatM a
gets (FormatConfig -> Bool
formatConfigPrintTimes forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormatterState -> FormatConfig
stateConfig)

-- | Get the total number of examples encountered so far.
getTotalCount :: FormatM Int
getTotalCount :: FormatM Int
getTotalCount = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [FormatM Int
getSuccessCount, FormatM Int
getFailCount, FormatM Int
getPendingCount]

-- | A lifted version of `Control.Monad.Trans.State.gets`
gets :: (FormatterState -> a) -> FormatM a
gets :: forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> a
f = forall a. ReaderT (IORef FormatterState) IO a -> FormatM a
FormatM forall a b. (a -> b) -> a -> b
$ do
  FormatterState -> a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) r. Monad m => ReaderT r m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IORef a -> IO a
readIORef)

-- | A lifted version of `Control.Monad.Trans.State.modify`
modify :: (FormatterState -> FormatterState) -> FormatM ()
modify :: (FormatterState -> FormatterState) -> FormatM ()
modify FormatterState -> FormatterState
f = forall a. ReaderT (IORef FormatterState) IO a -> FormatM a
FormatM forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *) r. Monad m => ReaderT r m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. IORef a -> (a -> a) -> IO ()
`modifyIORef'` FormatterState -> FormatterState
f)

data FormatterState = FormatterState {
  FormatterState -> Int
stateSuccessCount    :: !Int
, FormatterState -> Int
statePendingCount    :: !Int
, FormatterState -> [FailureRecord]
stateFailMessages    :: [FailureRecord]
, FormatterState -> Maybe Integer
stateCpuStartTime    :: Maybe Integer
, FormatterState -> Seconds
stateStartTime       :: Seconds
, FormatterState -> FormatConfig
stateConfig          :: FormatConfig
, FormatterState -> Maybe SGR
stateColor           :: Maybe SGR
}

-- | @since 2.11.5
getConfig :: FormatM FormatConfig
getConfig :: FormatM FormatConfig
getConfig = forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> FormatConfig
stateConfig

-- | @since 2.11.5
getConfigValue :: (FormatConfig -> a) -> FormatM a
getConfigValue :: forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> a
f = forall a. (FormatterState -> a) -> FormatM a
gets (FormatConfig -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormatterState -> FormatConfig
stateConfig)

-- | The random seed that is used for QuickCheck.
usedSeed :: FormatM Integer
usedSeed :: FormatM Integer
usedSeed = forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Integer
formatConfigUsedSeed

-- NOTE: We use an IORef here, so that the state persists when UserInterrupt is
-- thrown.
newtype FormatM a = FormatM (ReaderT (IORef FormatterState) IO a)
  deriving (forall a b. a -> FormatM b -> FormatM a
forall a b. (a -> b) -> FormatM a -> FormatM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> FormatM b -> FormatM a
$c<$ :: forall a b. a -> FormatM b -> FormatM a
fmap :: forall a b. (a -> b) -> FormatM a -> FormatM b
$cfmap :: forall a b. (a -> b) -> FormatM a -> FormatM b
Functor, Functor FormatM
forall a. a -> FormatM a
forall a b. FormatM a -> FormatM b -> FormatM a
forall a b. FormatM a -> FormatM b -> FormatM b
forall a b. FormatM (a -> b) -> FormatM a -> FormatM b
forall a b c. (a -> b -> c) -> FormatM a -> FormatM b -> FormatM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. FormatM a -> FormatM b -> FormatM a
$c<* :: forall a b. FormatM a -> FormatM b -> FormatM a
*> :: forall a b. FormatM a -> FormatM b -> FormatM b
$c*> :: forall a b. FormatM a -> FormatM b -> FormatM b
liftA2 :: forall a b c. (a -> b -> c) -> FormatM a -> FormatM b -> FormatM c
$cliftA2 :: forall a b c. (a -> b -> c) -> FormatM a -> FormatM b -> FormatM c
<*> :: forall a b. FormatM (a -> b) -> FormatM a -> FormatM b
$c<*> :: forall a b. FormatM (a -> b) -> FormatM a -> FormatM b
pure :: forall a. a -> FormatM a
$cpure :: forall a. a -> FormatM a
Applicative, Applicative FormatM
forall a. a -> FormatM a
forall a b. FormatM a -> FormatM b -> FormatM b
forall a b. FormatM a -> (a -> FormatM b) -> FormatM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> FormatM a
$creturn :: forall a. a -> FormatM a
>> :: forall a b. FormatM a -> FormatM b -> FormatM b
$c>> :: forall a b. FormatM a -> FormatM b -> FormatM b
>>= :: forall a b. FormatM a -> (a -> FormatM b) -> FormatM b
$c>>= :: forall a b. FormatM a -> (a -> FormatM b) -> FormatM b
Monad, Monad FormatM
forall a. IO a -> FormatM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> FormatM a
$cliftIO :: forall a. IO a -> FormatM a
MonadIO)

runFormatM :: FormatConfig -> FormatM a -> IO a
runFormatM :: forall a. FormatConfig -> FormatM a -> IO a
runFormatM FormatConfig
config (FormatM ReaderT (IORef FormatterState) IO a
action) = forall a. IO a -> IO a
withLineBuffering forall a b. (a -> b) -> a -> b
$ do
  Seconds
time <- IO Seconds
getMonotonicTime
  Maybe Integer
cpuTime <- if FormatConfig -> Bool
formatConfigPrintCpuTime FormatConfig
config then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Integer
CPUTime.getCPUTime else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

  let
    progress :: Bool
progress = FormatConfig -> Bool
formatConfigReportProgress FormatConfig
config Bool -> Bool -> Bool
&& Bool -> Bool
not (FormatConfig -> Bool
formatConfigHtmlOutput FormatConfig
config)
    state :: FormatterState
state = FormatterState {
      stateSuccessCount :: Int
stateSuccessCount = Int
0
    , statePendingCount :: Int
statePendingCount = Int
0
    , stateFailMessages :: [FailureRecord]
stateFailMessages = []
    , stateCpuStartTime :: Maybe Integer
stateCpuStartTime = Maybe Integer
cpuTime
    , stateStartTime :: Seconds
stateStartTime = Seconds
time
    , stateConfig :: FormatConfig
stateConfig = FormatConfig
config { formatConfigReportProgress :: Bool
formatConfigReportProgress = Bool
progress }
    , stateColor :: Maybe SGR
stateColor = forall a. Maybe a
Nothing
    }
  forall a. a -> IO (IORef a)
newIORef FormatterState
state forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (IORef FormatterState) IO a
action

withLineBuffering :: IO a -> IO a
withLineBuffering :: forall a. IO a -> IO a
withLineBuffering IO a
action = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Handle -> IO BufferMode
IO.hGetBuffering Handle
stdout) (Handle -> BufferMode -> IO ()
IO.hSetBuffering Handle
stdout) forall a b. (a -> b) -> a -> b
$ \ BufferMode
_ -> do
  Handle -> BufferMode -> IO ()
IO.hSetBuffering Handle
stdout BufferMode
IO.LineBuffering forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
action

-- | Increase the counter for successful examples
increaseSuccessCount :: FormatM ()
increaseSuccessCount :: FormatM ()
increaseSuccessCount = (FormatterState -> FormatterState) -> FormatM ()
modify forall a b. (a -> b) -> a -> b
$ \FormatterState
s -> FormatterState
s {stateSuccessCount :: Int
stateSuccessCount = forall a. Enum a => a -> a
succ forall a b. (a -> b) -> a -> b
$ FormatterState -> Int
stateSuccessCount FormatterState
s}

-- | Increase the counter for pending examples
increasePendingCount :: FormatM ()
increasePendingCount :: FormatM ()
increasePendingCount = (FormatterState -> FormatterState) -> FormatM ()
modify forall a b. (a -> b) -> a -> b
$ \FormatterState
s -> FormatterState
s {statePendingCount :: Int
statePendingCount = forall a. Enum a => a -> a
succ forall a b. (a -> b) -> a -> b
$ FormatterState -> Int
statePendingCount FormatterState
s}

-- | Get the number of successful examples encountered so far.
getSuccessCount :: FormatM Int
getSuccessCount :: FormatM Int
getSuccessCount = forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> Int
stateSuccessCount

-- | Get the number of pending examples encountered so far.
getPendingCount :: FormatM Int
getPendingCount :: FormatM Int
getPendingCount = forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> Int
statePendingCount

-- | Get the list of accumulated failure messages.
getFailMessages :: FormatM [FailureRecord]
getFailMessages :: FormatM [FailureRecord]
getFailMessages = forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> [FailureRecord]
stateFailMessages

-- | Get the number of spec items that will have been encountered when this run
-- completes (if it is not terminated early).
--
-- @since 2.9.0
getExpectedTotalCount :: FormatM Int
getExpectedTotalCount :: FormatM Int
getExpectedTotalCount = forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Int
formatConfigExpectedTotalCount

writeTransient :: String -> FormatM ()
writeTransient :: String -> FormatM ()
writeTransient String
new = do
  Bool
reportProgress <- forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Bool
formatConfigReportProgress
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
reportProgress forall a b. (a -> b) -> a -> b
$ do
    String -> FormatM ()
write String
new
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
IO.hFlush Handle
stdout
    String -> FormatM ()
write forall a b. (a -> b) -> a -> b
$ String
"\r" forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
new) Char
' ' forall a. [a] -> [a] -> [a]
++ String
"\r"

-- | Append some output to the report.
write :: String -> FormatM ()
write :: String -> FormatM ()
write = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> FormatM ()
writeChunk forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitLines

splitLines :: String -> [String]
splitLines :: String -> [String]
splitLines = forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\ Char
a Char
b -> Char -> Bool
isNewline Char
a forall a. Eq a => a -> a -> Bool
== Char -> Bool
isNewline Char
b)
  where
    isNewline :: Char -> Bool
isNewline = (forall a. Eq a => a -> a -> Bool
== Char
'\n')

writeChunk :: String -> FormatM ()
writeChunk :: String -> FormatM ()
writeChunk String
str = do
  let
    plainOutput :: IO ()
plainOutput = Handle -> String -> IO ()
IO.hPutStr Handle
stdout String
str
    colorOutput :: SGR -> IO ()
colorOutput SGR
color = forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (Handle -> [SGR] -> IO ()
hSetSGR Handle
stdout [SGR
color]) (Handle -> [SGR] -> IO ()
hSetSGR Handle
stdout [SGR
Reset]) IO ()
plainOutput
  Maybe SGR
mColor <- forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> Maybe SGR
stateColor
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case Maybe SGR
mColor of
    Just (SetColor ConsoleLayer
Foreground ColorIntensity
_ Color
_) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
str -> IO ()
plainOutput
    Just SGR
color -> SGR -> IO ()
colorOutput SGR
color
    Maybe SGR
Nothing -> IO ()
plainOutput

-- | Set output color to red, run given action, and finally restore the default
-- color.
withFailColor :: FormatM a -> FormatM a
withFailColor :: forall a. FormatM a -> FormatM a
withFailColor = forall a. SGR -> String -> FormatM a -> FormatM a
withColor (ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Red) String
"hspec-failure"

-- | Set output color to green, run given action, and finally restore the
-- default color.
withSuccessColor :: FormatM a -> FormatM a
withSuccessColor :: forall a. FormatM a -> FormatM a
withSuccessColor = forall a. SGR -> String -> FormatM a -> FormatM a
withColor (ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Green) String
"hspec-success"

-- | Set output color to yellow, run given action, and finally restore the
-- default color.
withPendingColor :: FormatM a -> FormatM a
withPendingColor :: forall a. FormatM a -> FormatM a
withPendingColor = forall a. SGR -> String -> FormatM a -> FormatM a
withColor (ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Yellow) String
"hspec-pending"

-- | Set output color to cyan, run given action, and finally restore the
-- default color.
withInfoColor :: FormatM a -> FormatM a
withInfoColor :: forall a. FormatM a -> FormatM a
withInfoColor = forall a. SGR -> String -> FormatM a -> FormatM a
withColor (ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Cyan) String
"hspec-info"

-- | Set a color, run an action, and finally reset colors.
withColor :: SGR -> String -> FormatM a -> FormatM a
withColor :: forall a. SGR -> String -> FormatM a -> FormatM a
withColor SGR
color String
cls FormatM a
action = do
  Bool
produceHTML <- forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Bool
formatConfigHtmlOutput
  (if Bool
produceHTML then forall a. String -> FormatM a -> FormatM a
htmlSpan String
cls else forall a. SGR -> FormatM a -> FormatM a
withColor_ SGR
color) FormatM a
action

htmlSpan :: String -> FormatM a -> FormatM a
htmlSpan :: forall a. String -> FormatM a -> FormatM a
htmlSpan String
cls FormatM a
action = String -> FormatM ()
write (String
"<span class=\"" forall a. [a] -> [a] -> [a]
++ String
cls forall a. [a] -> [a] -> [a]
++ String
"\">") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> FormatM a
action forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> FormatM ()
write String
"</span>"

withColor_ :: SGR -> FormatM a -> FormatM a
withColor_ :: forall a. SGR -> FormatM a -> FormatM a
withColor_ SGR
color FormatM a
action = do
  Maybe SGR
oldColor <- forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> Maybe SGR
stateColor
  Maybe SGR -> FormatM ()
setColor (forall a. a -> Maybe a
Just SGR
color) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> FormatM a
action forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Maybe SGR -> FormatM ()
setColor Maybe SGR
oldColor

setColor :: Maybe SGR -> FormatM ()
setColor :: Maybe SGR -> FormatM ()
setColor Maybe SGR
color = do
  Bool
useColor <- forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Bool
formatConfigUseColor
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
useColor forall a b. (a -> b) -> a -> b
$ do
    (FormatterState -> FormatterState) -> FormatM ()
modify (\ FormatterState
state -> FormatterState
state { stateColor :: Maybe SGR
stateColor = Maybe SGR
color })

-- | Output given chunk in red.
extraChunk :: String -> FormatM ()
extraChunk :: String -> FormatM ()
extraChunk String
s = do
  Bool
diff <- forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Bool
formatConfigUseDiff
  case Bool
diff of
    Bool
True -> String -> FormatM ()
extra String
s
    Bool
False -> String -> FormatM ()
write String
s
  where
    extra :: String -> FormatM ()
    extra :: String -> FormatM ()
extra = Color -> String -> String -> FormatM ()
diffColorize Color
Red String
"hspec-failure"

-- | Output given chunk in green.
missingChunk :: String -> FormatM ()
missingChunk :: String -> FormatM ()
missingChunk String
s = do
  Bool
diff <- forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Bool
formatConfigUseDiff
  case Bool
diff of
    Bool
True -> String -> FormatM ()
missing String
s
    Bool
False -> String -> FormatM ()
write String
s
  where
    missing :: String-> FormatM ()
    missing :: String -> FormatM ()
missing = Color -> String -> String -> FormatM ()
diffColorize Color
Green String
"hspec-success"

diffColorize :: Color -> String -> String-> FormatM ()
diffColorize :: Color -> String -> String -> FormatM ()
diffColorize Color
color String
cls String
s = forall a. SGR -> String -> FormatM a -> FormatM a
withColor (ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
layer ColorIntensity
Dull Color
color) String
cls forall a b. (a -> b) -> a -> b
$ do
  String -> FormatM ()
write String
s
  where
    layer :: ConsoleLayer
layer
      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s = ConsoleLayer
Background
      | Bool
otherwise = ConsoleLayer
Foreground

-- | Get the used CPU time since the test run has been started.
getCPUTime :: FormatM (Maybe Seconds)
getCPUTime :: FormatM (Maybe Seconds)
getCPUTime = do
  Integer
t1  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Integer
CPUTime.getCPUTime
  Maybe Integer
mt0 <- forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> Maybe Integer
stateCpuStartTime
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a}. Integral a => a -> Seconds
toSeconds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Integer
t1 forall a. Num a => a -> a -> a
-) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
mt0)
  where
    toSeconds :: a -> Seconds
toSeconds a
x = Double -> Seconds
Seconds (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x forall a. Fractional a => a -> a -> a
/ (Double
10.0 forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
12 :: Integer)))

-- | Get the passed real time since the test run has been started.
getRealTime :: FormatM Seconds
getRealTime :: FormatM Seconds
getRealTime = do
  Seconds
t1 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Seconds
getMonotonicTime
  Seconds
t0 <- forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> Seconds
stateStartTime
  forall (m :: * -> *) a. Monad m => a -> m a
return (Seconds
t1 forall a. Num a => a -> a -> a
- Seconds
t0)