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

, 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

#ifdef TEST
, runFormatM
, splitLines
#endif
) where

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

import qualified System.IO as IO
import           System.IO (Handle, stdout)
import           Control.Exception (bracket_, bracket)
import           System.Console.ANSI
import           Control.Monad.Trans.State hiding (state, gets, modify)
import           Control.Monad.IO.Class
import           Data.Char (isSpace)
import           Data.List (groupBy)
import qualified System.CPUTime as CPUTime

import           Test.Hspec.Core.Formatters.V1.Monad (FailureRecord(..))
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 ()
}

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
$ \ Event
event -> case Event
event of
  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
getConfig FormatConfig -> Bool
formatConfigUseDiff

-- |
-- 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
getConfig 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
getConfig 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
getConfig 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
getConfig FormatConfig -> Maybe (String -> String -> (String, String))
formatConfigPrettyPrintFunction

-- | Return `True` if the user requested unicode output, `False` otherwise.
outputUnicode :: FormatM Bool
outputUnicode :: FormatM Bool
outputUnicode = forall a. (FormatConfig -> a) -> FormatM a
getConfig 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. StateT (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 :: * -> *) s. Monad m => StateT s m s
get 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. StateT (IORef FormatterState) IO a -> FormatM a
FormatM forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *) s. Monad m => StateT s m s
get 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
}

getConfig :: (FormatConfig -> a) -> FormatM a
getConfig :: forall a. (FormatConfig -> a) -> FormatM a
getConfig 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)

getHandle :: FormatM Handle
getHandle :: FormatM Handle
getHandle = forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout

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

-- NOTE: We use an IORef here, so that the state persists when UserInterrupt is
-- thrown.
newtype FormatM a = FormatM (StateT (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 StateT (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 (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT (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).
getExpectedTotalCount :: FormatM Int
getExpectedTotalCount :: FormatM Int
getExpectedTotalCount = forall a. (FormatConfig -> a) -> FormatM a
getConfig FormatConfig -> Int
formatConfigExpectedTotalCount

writeTransient :: String -> FormatM ()
writeTransient :: String -> FormatM ()
writeTransient String
new = do
  Bool
reportProgress <- forall a. (FormatConfig -> a) -> FormatM a
getConfig FormatConfig -> Bool
formatConfigReportProgress
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
reportProgress) forall a b. (a -> b) -> a -> b
$ do
    Handle
h <- FormatM Handle
getHandle
    String -> FormatM ()
write forall a b. (a -> b) -> a -> b
$ String
new
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
IO.hFlush Handle
h
    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
  Handle
h <- FormatM Handle
getHandle
  let
    plainOutput :: IO ()
plainOutput = Handle -> String -> IO ()
IO.hPutStr Handle
h 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
h [SGR
color]) (Handle -> [SGR] -> IO ()
hSetSGR Handle
h [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
getConfig 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
getConfig 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
getConfig 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
getConfig 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
<$> ((-) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
t1 forall (f :: * -> *) a b. Applicative f => 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)