{-# 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 ()
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
  Seconds
time <- IO Seconds
getMonotonicTime
  Maybe Integer
cpuTime <- if FormatConfig -> Bool
formatConfigPrintCpuTime FormatConfig
config then Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> IO Integer -> IO (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Integer
CPUTime.getCPUTime else Maybe Integer -> IO (Maybe Integer)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Integer
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 = progress }
    , stateColor :: Maybe SGR
stateColor = Maybe SGR
forall a. Maybe a
Nothing
    }
  FormatterState -> IO (IORef FormatterState)
forall a. a -> IO (IORef a)
newIORef FormatterState
state IO (IORef FormatterState) -> (IORef FormatterState -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT (IORef FormatterState) IO a -> IORef FormatterState -> IO a
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 = 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
  Bool
reportProgress <- (FormatConfig -> Bool) -> FormatM Bool
forall a. (FormatConfig -> a) -> FormatM a
getConfigValue FormatConfig -> Bool
formatConfigReportProgress
  Bool -> FormatM () -> FormatM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
reportProgress (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ do
    String -> FormatM ()
write String
new
    IO () -> FormatM ()
forall a. IO a -> FormatM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FormatM ()) -> IO () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
IO.hFlush Handle
stdout
    String -> FormatM ()
write (String -> FormatM ()) -> String -> FormatM ()
forall a b. (a -> b) -> a -> b
$ String
"\r" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
new) Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\r"

-- | 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 = Handle -> String -> IO ()
IO.hPutStr Handle
stdout 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
  Maybe SGR
mColor <- (FormatterState -> Maybe SGR) -> FormatM (Maybe SGR)
forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> Maybe SGR
stateColor
  IO () -> FormatM ()
forall a. IO a -> FormatM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FormatM ()) -> IO () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ case Maybe SGR
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

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

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

-- | Output given chunk in red.
extraChunk :: String -> FormatM ()
extraChunk :: String -> FormatM ()
extraChunk String
s = do
  Bool
diff <- (FormatConfig -> Bool) -> FormatM Bool
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 <- (FormatConfig -> Bool) -> FormatM Bool
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 = 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
$ do
  String -> FormatM ()
write String
s
  where
    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
  Integer
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
  Maybe Integer
mt0 <- (FormatterState -> Maybe Integer) -> FormatM (Maybe Integer)
forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> Maybe Integer
stateCpuStartTime
  Maybe Seconds -> FormatM (Maybe Seconds)
forall a. a -> FormatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Seconds -> FormatM (Maybe Seconds))
-> Maybe Seconds -> FormatM (Maybe Seconds)
forall a b. (a -> b) -> a -> b
$ Integer -> Seconds
forall {a}. Integral a => a -> Seconds
toSeconds (Integer -> Seconds) -> Maybe Integer -> Maybe Seconds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Integer
t1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-) (Integer -> Integer) -> Maybe Integer -> Maybe Integer
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 (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
  Seconds
t1 <- IO Seconds -> FormatM Seconds
forall a. IO a -> FormatM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Seconds
getMonotonicTime
  Seconds
t0 <- (FormatterState -> Seconds) -> FormatM Seconds
forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> Seconds
stateStartTime
  Seconds -> FormatM Seconds
forall a. a -> FormatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Seconds
t1 Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
- Seconds
t0)