{-# 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 hiding (clearLine)
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 ()
formatterStarted :: Formatter -> FormatM ()
formatterGroupStarted :: Formatter -> Path -> FormatM ()
formatterGroupDone :: Formatter -> Path -> FormatM ()
formatterProgress :: Formatter -> Path -> Progress -> FormatM ()
formatterItemStarted :: Formatter -> Path -> FormatM ()
formatterItemDone :: Formatter -> Path -> Item -> FormatM ()
formatterDone :: Formatter -> FormatM ()
formatterStarted :: FormatM ()
formatterGroupStarted :: Path -> FormatM ()
formatterGroupDone :: Path -> FormatM ()
formatterProgress :: Path -> Progress -> FormatM ()
formatterItemStarted :: Path -> FormatM ()
formatterItemDone :: Path -> Item -> FormatM ()
formatterDone :: FormatM ()
..} FormatConfig
config = (FormatM () -> IO ()) -> (Event -> FormatM ()) -> IO Format
forall (m :: * -> *).
MonadIO m =>
(m () -> IO ()) -> (Event -> m ()) -> IO Format
monadic (FormatConfig -> FormatM () -> IO ()
forall a. FormatConfig -> FormatM a -> IO a
runFormatM FormatConfig
config) ((Event -> FormatM ()) -> IO Format)
-> (Event -> FormatM ()) -> IO Format
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 (FailureRecord -> FormatM ()) -> FailureRecord -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Maybe Location -> Path -> FailureReason -> FailureRecord
FailureRecord (Maybe Location
loc Maybe Location -> Maybe Location -> Maybe Location
forall a. Maybe a -> Maybe a -> Maybe a
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 ((FormatterState -> FormatterState) -> FormatM ())
-> (FormatterState -> FormatterState) -> FormatM ()
forall a b. (a -> b) -> a -> b
$ \ FormatterState
s -> FormatterState
s { stateFailMessages = r : stateFailMessages s }

-- | Get the number of failed examples encountered so far.
getFailCount :: FormatM Int
getFailCount :: FormatM Int
getFailCount = [FailureRecord] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([FailureRecord] -> Int) -> FormatM [FailureRecord] -> FormatM Int
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 = (FormatConfig -> Bool) -> FormatM Bool
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 = (FormatConfig -> Bool) -> FormatM Bool
forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Bool
formatConfigExpertMode FormatM Bool -> (Bool -> FormatM ()) -> FormatM ()
forall a b. FormatM a -> (a -> FormatM b) -> FormatM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
  Bool
False -> FormatM ()
action
  Bool
True -> () -> FormatM ()
forall a. a -> FormatM a
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 = (FormatConfig -> Maybe Int) -> FormatM (Maybe Int)
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 = (FormatConfig -> Maybe (String -> String -> IO ()))
-> FormatM (Maybe (String -> String -> IO ()))
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 = Bool
-> ((String -> String -> (String, String)) -> Bool)
-> Maybe (String -> String -> (String, String))
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> (String -> String -> (String, String)) -> Bool
forall a b. a -> b -> a
const Bool
True) (Maybe (String -> String -> (String, String)) -> Bool)
-> FormatM (Maybe (String -> String -> (String, String)))
-> FormatM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FormatConfig -> Maybe (String -> String -> (String, String)))
-> FormatM (Maybe (String -> String -> (String, String)))
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 = (FormatConfig -> Maybe (String -> String -> (String, String)))
-> FormatM (Maybe (String -> String -> (String, String)))
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 = (FormatConfig -> Bool) -> FormatM Bool
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 FormatM () -> FormatM () -> FormatM ()
forall a b. FormatM a -> FormatM b -> FormatM b
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 = (FormatterState -> Bool) -> FormatM Bool
forall a. (FormatterState -> a) -> FormatM a
gets (FormatConfig -> Bool
formatConfigPrintTimes (FormatConfig -> Bool)
-> (FormatterState -> FormatConfig) -> FormatterState -> Bool
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 = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> FormatM [Int] -> FormatM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FormatM Int] -> FormatM [Int]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [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 = ReaderT (IORef FormatterState) IO a -> FormatM a
forall a. ReaderT (IORef FormatterState) IO a -> FormatM a
FormatM (ReaderT (IORef FormatterState) IO a -> FormatM a)
-> ReaderT (IORef FormatterState) IO a -> FormatM a
forall a b. (a -> b) -> a -> b
$ do
  FormatterState -> a
f (FormatterState -> a)
-> ReaderT (IORef FormatterState) IO FormatterState
-> ReaderT (IORef FormatterState) IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReaderT (IORef FormatterState) IO (IORef FormatterState)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT (IORef FormatterState) IO (IORef FormatterState)
-> (IORef FormatterState
    -> ReaderT (IORef FormatterState) IO FormatterState)
-> ReaderT (IORef FormatterState) IO FormatterState
forall a b.
ReaderT (IORef FormatterState) IO a
-> (a -> ReaderT (IORef FormatterState) IO b)
-> ReaderT (IORef FormatterState) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO FormatterState
-> ReaderT (IORef FormatterState) IO FormatterState
forall a. IO a -> ReaderT (IORef FormatterState) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FormatterState
 -> ReaderT (IORef FormatterState) IO FormatterState)
-> (IORef FormatterState -> IO FormatterState)
-> IORef FormatterState
-> ReaderT (IORef FormatterState) IO FormatterState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef FormatterState -> IO FormatterState
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 = ReaderT (IORef FormatterState) IO () -> FormatM ()
forall a. ReaderT (IORef FormatterState) IO a -> FormatM a
FormatM (ReaderT (IORef FormatterState) IO () -> FormatM ())
-> ReaderT (IORef FormatterState) IO () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ do
  ReaderT (IORef FormatterState) IO (IORef FormatterState)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT (IORef FormatterState) IO (IORef FormatterState)
-> (IORef FormatterState -> ReaderT (IORef FormatterState) IO ())
-> ReaderT (IORef FormatterState) IO ()
forall a b.
ReaderT (IORef FormatterState) IO a
-> (a -> ReaderT (IORef FormatterState) IO b)
-> ReaderT (IORef FormatterState) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> ReaderT (IORef FormatterState) IO ()
forall a. IO a -> ReaderT (IORef FormatterState) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (IORef FormatterState) IO ())
-> (IORef FormatterState -> IO ())
-> IORef FormatterState
-> ReaderT (IORef FormatterState) IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IORef FormatterState -> (FormatterState -> FormatterState) -> IO ()
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 = (FormatterState -> FormatConfig) -> FormatM FormatConfig
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 = (FormatterState -> a) -> FormatM a
forall a. (FormatterState -> a) -> FormatM a
gets (FormatConfig -> a
f (FormatConfig -> a)
-> (FormatterState -> FormatConfig) -> FormatterState -> a
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 = (FormatConfig -> Integer) -> FormatM Integer
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 -> b) -> FormatM a -> FormatM b)
-> (forall a b. a -> FormatM b -> FormatM a) -> Functor FormatM
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
$cfmap :: forall a b. (a -> b) -> FormatM a -> FormatM b
fmap :: forall a b. (a -> b) -> FormatM a -> FormatM b
$c<$ :: forall a b. a -> FormatM b -> FormatM a
<$ :: forall a b. a -> FormatM b -> FormatM a
Functor, Functor FormatM
Functor FormatM =>
(forall a. a -> FormatM a)
-> (forall a b. FormatM (a -> b) -> FormatM a -> FormatM b)
-> (forall a b c.
    (a -> b -> c) -> FormatM a -> FormatM b -> FormatM c)
-> (forall a b. FormatM a -> FormatM b -> FormatM b)
-> (forall a b. FormatM a -> FormatM b -> FormatM a)
-> Applicative 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
$cpure :: forall a. a -> FormatM a
pure :: forall a. a -> FormatM a
$c<*> :: forall a b. FormatM (a -> b) -> FormatM a -> FormatM b
<*> :: forall a b. FormatM (a -> b) -> FormatM a -> FormatM b
$cliftA2 :: forall a b c. (a -> b -> c) -> FormatM a -> FormatM b -> FormatM c
liftA2 :: forall a b c. (a -> b -> c) -> FormatM a -> FormatM b -> FormatM c
$c*> :: forall a b. FormatM a -> FormatM b -> FormatM b
*> :: forall a b. FormatM a -> FormatM b -> FormatM b
$c<* :: forall a b. FormatM a -> FormatM b -> FormatM a
<* :: forall a b. FormatM a -> FormatM b -> FormatM a
Applicative, Applicative FormatM
Applicative FormatM =>
(forall a b. FormatM a -> (a -> FormatM b) -> FormatM b)
-> (forall a b. FormatM a -> FormatM b -> FormatM b)
-> (forall a. a -> FormatM a)
-> Monad 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
$c>>= :: forall a b. FormatM a -> (a -> FormatM b) -> FormatM b
>>= :: forall a b. FormatM a -> (a -> FormatM b) -> FormatM b
$c>> :: forall a b. FormatM a -> FormatM b -> FormatM b
>> :: forall a b. FormatM a -> FormatM b -> FormatM b
$creturn :: forall a. a -> FormatM a
return :: forall a. a -> FormatM a
Monad, Monad FormatM
Monad FormatM => (forall a. IO a -> FormatM a) -> MonadIO FormatM
forall a. IO a -> FormatM a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> FormatM a
liftIO :: 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) = IO a -> IO a
forall a. IO a -> IO a
withLineBuffering (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  time <- IO Seconds
getMonotonicTime
  cpuTime <- if formatConfigPrintCpuTime config then Just <$> CPUTime.getCPUTime else pure Nothing

  let
    progress = FormatConfig -> Bool
formatConfigReportProgress FormatConfig
config Bool -> Bool -> Bool
&& Bool -> Bool
not (FormatConfig -> Bool
formatConfigHtmlOutput FormatConfig
config)
    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 = progress }
    , stateColor :: Maybe SGR
stateColor = Maybe SGR
forall a. Maybe a
Nothing
    }
  newIORef state >>= runReaderT action

withLineBuffering :: IO a -> IO a
withLineBuffering :: forall a. IO a -> IO a
withLineBuffering IO a
action = IO BufferMode
-> (BufferMode -> IO ()) -> (BufferMode -> IO a) -> IO a
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) ((BufferMode -> IO a) -> IO a) -> (BufferMode -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ BufferMode
_ -> do
  Handle -> BufferMode -> IO ()
IO.hSetBuffering Handle
stdout BufferMode
IO.LineBuffering IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
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 ((FormatterState -> FormatterState) -> FormatM ())
-> (FormatterState -> FormatterState) -> FormatM ()
forall a b. (a -> b) -> a -> b
$ \FormatterState
s -> FormatterState
s {stateSuccessCount = succ $ stateSuccessCount s}

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

-- | Get the number of successful examples encountered so far.
getSuccessCount :: FormatM Int
getSuccessCount :: FormatM Int
getSuccessCount = (FormatterState -> Int) -> FormatM Int
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 = (FormatterState -> Int) -> FormatM Int
forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> Int
statePendingCount

-- | Get the list of accumulated failure messages.
getFailMessages :: FormatM [FailureRecord]
getFailMessages :: FormatM [FailureRecord]
getFailMessages = [FailureRecord] -> [FailureRecord]
forall a. [a] -> [a]
reverse ([FailureRecord] -> [FailureRecord])
-> FormatM [FailureRecord] -> FormatM [FailureRecord]
forall a b. (a -> b) -> FormatM a -> FormatM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (FormatterState -> [FailureRecord]) -> FormatM [FailureRecord]
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 = (FormatConfig -> Int) -> FormatM Int
forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Int
formatConfigExpectedTotalCount

writeTransient :: String -> FormatM ()
writeTransient :: String -> FormatM ()
writeTransient String
new = do
  reportProgress <- (FormatConfig -> Bool) -> FormatM Bool
forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Bool
formatConfigReportProgress
  when reportProgress . liftIO $ do
    bracket_ disableLineWrapping enableLineWrapping $ writePlain new
    IO.hFlush stdout
    clearLine
  where
    disableLineWrapping :: IO ()
    disableLineWrapping :: IO ()
disableLineWrapping = String -> IO ()
writePlain String
"\ESC[?7l"

    enableLineWrapping :: IO ()
    enableLineWrapping :: IO ()
enableLineWrapping = String -> IO ()
writePlain String
"\ESC[?7h"

    clearLine :: IO ()
    clearLine :: IO ()
clearLine = String -> IO ()
writePlain String
"\r\ESC[K"

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

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

writeChunk :: String -> FormatM ()
writeChunk :: String -> FormatM ()
writeChunk String
str = do
  let
    plainOutput :: IO ()
plainOutput = String -> IO ()
writePlain String
str
    colorOutput :: SGR -> IO ()
colorOutput SGR
color = IO () -> IO () -> IO () -> IO ()
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
  mColor <- (FormatterState -> Maybe SGR) -> FormatM (Maybe SGR)
forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> Maybe SGR
stateColor
  liftIO $ case mColor of
    Just (SetColor ConsoleLayer
Foreground ColorIntensity
_ Color
_) | (Char -> Bool) -> String -> Bool
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

writePlain :: String -> IO ()
writePlain :: String -> IO ()
writePlain = Handle -> String -> IO ()
IO.hPutStr Handle
stdout

-- | 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 = SGR -> String -> FormatM a -> FormatM a
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 = SGR -> String -> FormatM a -> FormatM a
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 = SGR -> String -> FormatM a -> FormatM a
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 = SGR -> String -> FormatM a -> FormatM a
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
  produceHTML <- (FormatConfig -> Bool) -> FormatM Bool
forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Bool
formatConfigHtmlOutput
  (if produceHTML then htmlSpan cls else withColor_ color) 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=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cls String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\">") FormatM () -> FormatM a -> FormatM a
forall a b. FormatM a -> FormatM b -> FormatM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> FormatM a
action FormatM a -> FormatM () -> FormatM a
forall a b. FormatM a -> FormatM b -> FormatM a
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
  oldColor <- (FormatterState -> Maybe SGR) -> FormatM (Maybe SGR)
forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> Maybe SGR
stateColor
  setColor (Just color) *> action <* setColor oldColor

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

-- | Output given chunk in red.
extraChunk :: String -> FormatM ()
extraChunk :: String -> FormatM ()
extraChunk String
s = do
  diff <- (FormatConfig -> Bool) -> FormatM Bool
forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Bool
formatConfigUseDiff
  case 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
  diff <- (FormatConfig -> Bool) -> FormatM Bool
forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Bool
formatConfigUseDiff
  case 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 = SGR -> String -> FormatM () -> FormatM ()
forall a. SGR -> String -> FormatM a -> FormatM a
withColor (ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
layer ColorIntensity
Dull Color
color) String
cls (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ case String
s of
  String
"" -> String -> FormatM ()
write String
eraseInLine
  String
_ -> String -> FormatM ()
write String
s
  where
    eraseInLine :: String
    eraseInLine :: String
eraseInLine = String
"\ESC[K"

    layer :: ConsoleLayer
    layer :: ConsoleLayer
layer
      | (Char -> Bool) -> String -> Bool
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
  t1  <- IO Integer -> FormatM Integer
forall a. IO a -> FormatM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Integer
CPUTime.getCPUTime
  mt0 <- gets stateCpuStartTime
  return $ toSeconds <$> ((t1 -) <$> mt0)
  where
    toSeconds :: a -> Seconds
toSeconds a
x = Double -> Seconds
Seconds (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
10.0 Double -> Integer -> Double
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
  t1 <- IO Seconds -> FormatM Seconds
forall a. IO a -> FormatM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Seconds
getMonotonicTime
  t0 <- gets stateStartTime
  return (t1 - t0)