{-# 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
, 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 = (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
$ \ 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 (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 (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 :: [FailureRecord]
stateFailMessages = FailureRecord
r FailureRecord -> [FailureRecord] -> [FailureRecord]
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 = [FailureRecord] -> 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
getConfig FormatConfig -> Bool
formatConfigUseDiff

-- | 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
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 = (FormatConfig -> Maybe (String -> String -> (String, String)))
-> FormatM (Maybe (String -> String -> (String, String)))
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 = (FormatConfig -> Bool) -> FormatM Bool
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 FormatM () -> FormatM () -> FormatM ()
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 (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)
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 :: (FormatterState -> a) -> FormatM a
gets FormatterState -> a
f = StateT (IORef FormatterState) IO a -> FormatM a
forall a. StateT (IORef FormatterState) IO a -> FormatM a
FormatM (StateT (IORef FormatterState) IO a -> FormatM a)
-> StateT (IORef FormatterState) IO a -> FormatM a
forall a b. (a -> b) -> a -> b
$ do
  FormatterState -> a
f (FormatterState -> a)
-> StateT (IORef FormatterState) IO FormatterState
-> StateT (IORef FormatterState) IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StateT (IORef FormatterState) IO (IORef FormatterState)
forall (m :: * -> *) s. Monad m => StateT s m s
get StateT (IORef FormatterState) IO (IORef FormatterState)
-> (IORef FormatterState
    -> StateT (IORef FormatterState) IO FormatterState)
-> StateT (IORef FormatterState) IO FormatterState
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO FormatterState
-> StateT (IORef FormatterState) IO FormatterState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FormatterState
 -> StateT (IORef FormatterState) IO FormatterState)
-> (IORef FormatterState -> IO FormatterState)
-> IORef FormatterState
-> StateT (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 = StateT (IORef FormatterState) IO () -> FormatM ()
forall a. StateT (IORef FormatterState) IO a -> FormatM a
FormatM (StateT (IORef FormatterState) IO () -> FormatM ())
-> StateT (IORef FormatterState) IO () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ do
  StateT (IORef FormatterState) IO (IORef FormatterState)
forall (m :: * -> *) s. Monad m => StateT s m s
get StateT (IORef FormatterState) IO (IORef FormatterState)
-> (IORef FormatterState -> StateT (IORef FormatterState) IO ())
-> StateT (IORef FormatterState) IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> StateT (IORef FormatterState) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (IORef FormatterState) IO ())
-> (IORef FormatterState -> IO ())
-> IORef FormatterState
-> StateT (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
}

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

getHandle :: FormatM Handle
getHandle :: FormatM Handle
getHandle = Handle -> FormatM Handle
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 = (FormatConfig -> Integer) -> FormatM Integer
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 (a -> FormatM b -> FormatM a
(a -> b) -> FormatM a -> FormatM b
(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
<$ :: a -> FormatM b -> FormatM a
$c<$ :: forall a b. a -> FormatM b -> FormatM a
fmap :: (a -> b) -> FormatM a -> FormatM b
$cfmap :: forall a b. (a -> b) -> FormatM a -> FormatM b
Functor, Functor FormatM
a -> FormatM a
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
FormatM a -> FormatM b -> FormatM b
FormatM a -> FormatM b -> FormatM a
FormatM (a -> b) -> FormatM a -> FormatM b
(a -> b -> c) -> FormatM a -> FormatM b -> FormatM c
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
<* :: FormatM a -> FormatM b -> FormatM a
$c<* :: forall a b. FormatM a -> FormatM b -> FormatM a
*> :: FormatM a -> FormatM b -> FormatM b
$c*> :: forall a b. FormatM a -> FormatM b -> FormatM b
liftA2 :: (a -> b -> c) -> FormatM a -> FormatM b -> FormatM c
$cliftA2 :: forall a b c. (a -> b -> c) -> FormatM a -> FormatM b -> FormatM c
<*> :: FormatM (a -> b) -> FormatM a -> FormatM b
$c<*> :: forall a b. FormatM (a -> b) -> FormatM a -> FormatM b
pure :: a -> FormatM a
$cpure :: forall a. a -> FormatM a
$cp1Applicative :: Functor FormatM
Applicative, Applicative FormatM
a -> FormatM a
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
FormatM a -> (a -> FormatM b) -> FormatM b
FormatM a -> FormatM b -> FormatM b
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 :: a -> FormatM a
$creturn :: forall a. a -> FormatM a
>> :: FormatM a -> FormatM b -> FormatM b
$c>> :: forall a b. FormatM a -> FormatM b -> FormatM b
>>= :: FormatM a -> (a -> FormatM b) -> FormatM b
$c>>= :: forall a b. FormatM a -> (a -> FormatM b) -> FormatM b
$cp1Monad :: Applicative FormatM
Monad, Monad FormatM
Monad FormatM -> (forall a. IO a -> FormatM a) -> MonadIO FormatM
IO a -> FormatM a
forall a. IO a -> FormatM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> FormatM a
$cliftIO :: forall a. IO a -> FormatM a
$cp1MonadIO :: Monad FormatM
MonadIO)

runFormatM :: FormatConfig -> FormatM a -> IO a
runFormatM :: FormatConfig -> FormatM a -> IO a
runFormatM FormatConfig
config (FormatM StateT (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 (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 :: Int
-> Int
-> [FailureRecord]
-> Maybe Integer
-> Seconds
-> FormatConfig
-> Maybe SGR
-> FormatterState
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 = 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StateT (IORef FormatterState) IO a -> IORef FormatterState -> IO a
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 :: 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 (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 :: Int
stateSuccessCount = Int -> Int
forall a. Enum a => a -> a
succ (Int -> Int) -> Int -> Int
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 ((FormatterState -> FormatterState) -> FormatM ())
-> (FormatterState -> FormatterState) -> FormatM ()
forall a b. (a -> b) -> a -> b
$ \FormatterState
s -> FormatterState
s {statePendingCount :: Int
statePendingCount = Int -> Int
forall a. Enum a => a -> a
succ (Int -> Int) -> Int -> Int
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 = (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 (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).
getExpectedTotalCount :: FormatM Int
getExpectedTotalCount :: FormatM Int
getExpectedTotalCount = (FormatConfig -> Int) -> FormatM Int
forall a. (FormatConfig -> a) -> FormatM a
getConfig 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
getConfig 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
    Handle
h <- FormatM Handle
getHandle
    String -> FormatM ()
write (String -> FormatM ()) -> String -> FormatM ()
forall a b. (a -> b) -> a -> b
$ String
new
    IO () -> FormatM ()
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
h
    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 (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
  Handle
h <- FormatM Handle
getHandle
  Maybe SGR
mColor <- (FormatterState -> Maybe SGR) -> FormatM (Maybe SGR)
forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> Maybe SGR
stateColor
  IO () -> FormatM ()
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 SGR
color | Bool -> Bool
not ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
str) -> IO () -> IO () -> IO () -> IO ()
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])
      (Handle -> String -> IO ()
IO.hPutStr Handle
h String
str)
    Maybe SGR
_ -> Handle -> String -> IO ()
IO.hPutStr Handle
h String
str

-- | Set output color to red, run given action, and finally restore the default
-- color.
withFailColor :: FormatM a -> FormatM a
withFailColor :: 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 :: 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 :: 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 :: 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 :: 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
getConfig 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 :: 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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> FormatM a
action FormatM a -> FormatM () -> 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_ :: 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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> FormatM a
action FormatM a -> FormatM () -> 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
getConfig 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 :: Maybe SGR
stateColor = Maybe SGR
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
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 <- (FormatConfig -> Bool) -> FormatM Bool
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 = 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 (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 (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 -> Integer -> Integer)
-> Maybe Integer -> Maybe (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Maybe Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
t1 Maybe (Integer -> Integer) -> Maybe Integer -> Maybe Integer
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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return (Seconds
t1 Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
- Seconds
t0)