{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
module Test.Hspec.Core.Formatters.Internal (
  FormatM
, runFormatM
, interpret
, increaseSuccessCount
, increasePendingCount
, addFailMessage
, formatterToFormat
#ifdef TEST
, overwriteWith
#endif
) where

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

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

import qualified Test.Hspec.Core.Formatters.Monad as M
import           Test.Hspec.Core.Formatters.Monad (Environment(..), interpretWith, FailureRecord(..))
import           Test.Hspec.Core.Format
import           Test.Hspec.Core.Clock

formatterToFormat :: M.Formatter -> FormatConfig -> IO Format
formatterToFormat :: Formatter -> FormatConfig -> IO Format
formatterToFormat M.Formatter{FormatM ()
Path -> FormatM ()
Path -> Progress -> FormatM ()
Path -> Item -> 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 ()
formatterDone :: FormatM ()
formatterItemDone :: Path -> Item -> FormatM ()
formatterItemStarted :: Path -> FormatM ()
formatterProgress :: Path -> Progress -> FormatM ()
formatterGroupDone :: Path -> FormatM ()
formatterGroupStarted :: Path -> FormatM ()
formatterStarted :: 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 () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret FormatM ()
formatterStarted
  GroupStarted Path
path -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Path -> FormatM ()
formatterGroupStarted Path
path
  GroupDone Path
path -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Path -> FormatM ()
formatterGroupDone Path
path
  Progress Path
path Progress
progress -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Path -> Progress -> FormatM ()
formatterProgress Path
path Progress
progress
  ItemStarted Path
path -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Path -> FormatM ()
formatterItemStarted Path
path
  ItemDone Path
path Item
item -> do
    FormatM ()
clearTransientOutput
    case Item -> Result
itemResult Item
item of
      Success {} -> FormatM ()
increaseSuccessCount
      Pending {} -> FormatM ()
increasePendingCount
      Failure Maybe Location
loc FailureReason
err -> Maybe Location -> Path -> FailureReason -> FormatM ()
addFailMessage (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
    FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Path -> Item -> FormatM ()
formatterItemDone Path
path Item
item
  Done [(Path, Item)]
_ -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret FormatM ()
formatterDone

interpret :: M.FormatM a -> FormatM a
interpret :: FormatM a -> FormatM a
interpret = Environment FormatM -> FormatM a -> FormatM a
forall (m :: * -> *) a.
Monad m =>
Environment m -> FormatM a -> m a
interpretWith Environment :: forall (m :: * -> *).
m Int
-> m Int
-> m [FailureRecord]
-> m Int
-> m Integer
-> m Bool
-> m (Maybe Seconds)
-> m Seconds
-> (String -> m ())
-> (String -> m ())
-> (forall a. m a -> m a)
-> (forall a. m a -> m a)
-> (forall a. m a -> m a)
-> (forall a. m a -> m a)
-> m Bool
-> (String -> m ())
-> (String -> m ())
-> (forall a. IO a -> m a)
-> Environment m
Environment {
  environmentGetSuccessCount :: FormatM Int
environmentGetSuccessCount = FormatM Int
getSuccessCount
, environmentGetPendingCount :: FormatM Int
environmentGetPendingCount = FormatM Int
getPendingCount
, environmentGetFailMessages :: FormatM [FailureRecord]
environmentGetFailMessages = FormatM [FailureRecord]
getFailMessages
, environmentGetFinalCount :: FormatM Int
environmentGetFinalCount = FormatM Int
getItemCount
, environmentUsedSeed :: FormatM Integer
environmentUsedSeed = FormatM Integer
usedSeed
, environmentPrintTimes :: FormatM Bool
environmentPrintTimes = (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)
, environmentGetCPUTime :: FormatM (Maybe Seconds)
environmentGetCPUTime = FormatM (Maybe Seconds)
getCPUTime
, environmentGetRealTime :: FormatM Seconds
environmentGetRealTime = FormatM Seconds
getRealTime
, environmentWrite :: String -> FormatM ()
environmentWrite = String -> FormatM ()
write
, environmentWriteTransient :: String -> FormatM ()
environmentWriteTransient = String -> FormatM ()
writeTransient
, environmentWithFailColor :: forall a. FormatM a -> FormatM a
environmentWithFailColor = forall a. FormatM a -> FormatM a
withFailColor
, environmentWithSuccessColor :: forall a. FormatM a -> FormatM a
environmentWithSuccessColor = forall a. FormatM a -> FormatM a
withSuccessColor
, environmentWithPendingColor :: forall a. FormatM a -> FormatM a
environmentWithPendingColor = forall a. FormatM a -> FormatM a
withPendingColor
, environmentWithInfoColor :: forall a. FormatM a -> FormatM a
environmentWithInfoColor = forall a. FormatM a -> FormatM a
withInfoColor
, environmentUseDiff :: FormatM Bool
environmentUseDiff = (FormatterState -> Bool) -> FormatM Bool
forall a. (FormatterState -> a) -> FormatM a
gets (FormatConfig -> Bool
formatConfigUseDiff (FormatConfig -> Bool)
-> (FormatterState -> FormatConfig) -> FormatterState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormatterState -> FormatConfig
stateConfig)
, environmentExtraChunk :: String -> FormatM ()
environmentExtraChunk = String -> FormatM ()
extraChunk
, environmentMissingChunk :: String -> FormatM ()
environmentMissingChunk = String -> FormatM ()
missingChunk
, environmentLiftIO :: forall a. IO a -> FormatM a
environmentLiftIO = forall a. IO a -> FormatM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
}

-- | 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 -> String
stateTransientOutput :: String
, FormatterState -> FormatConfig
stateConfig :: FormatConfig
}

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) = 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
  IORef FormatterState
st <- FormatterState -> IO (IORef FormatterState)
forall a. a -> IO (IORef a)
newIORef (Int
-> Int
-> [FailureRecord]
-> Maybe Integer
-> Seconds
-> String
-> FormatConfig
-> FormatterState
FormatterState Int
0 Int
0 [] Maybe Integer
cpuTime Seconds
time String
"" FormatConfig
config)
  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 IORef FormatterState
st

-- | 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

-- | Append to the list of accumulated failure messages.
addFailMessage :: Maybe Location -> Path -> FailureReason -> FormatM ()
addFailMessage :: Maybe Location -> Path -> FailureReason -> FormatM ()
addFailMessage Maybe Location
loc Path
p FailureReason
m = (FormatterState -> FormatterState) -> FormatM ()
modify ((FormatterState -> FormatterState) -> FormatM ())
-> (FormatterState -> FormatterState) -> FormatM ()
forall a b. (a -> b) -> a -> b
$ \FormatterState
s -> FormatterState
s {stateFailMessages :: [FailureRecord]
stateFailMessages = Maybe Location -> Path -> FailureReason -> FailureRecord
FailureRecord Maybe Location
loc Path
p FailureReason
m FailureRecord -> [FailureRecord] -> [FailureRecord]
forall a. a -> [a] -> [a]
: FormatterState -> [FailureRecord]
stateFailMessages FormatterState
s}

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

overwriteWith :: String -> String -> String
overwriteWith :: String -> String -> String
overwriteWith String
old String
new
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = String
new
  | Bool
otherwise = Char
'\r' Char -> String -> String
forall a. a -> [a] -> [a]
: String
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
new) Char
' '
  where
    n :: Int
n = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
old

writeTransient :: String -> FormatM ()
writeTransient :: String -> FormatM ()
writeTransient String
new = 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
    String
old <- (FormatterState -> String) -> FormatM String
forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> String
stateTransientOutput
    String -> FormatM ()
write (String -> FormatM ()) -> String -> FormatM ()
forall a b. (a -> b) -> a -> b
$ String
old String -> String -> String
`overwriteWith` String
new
    (FormatterState -> FormatterState) -> FormatM ()
modify ((FormatterState -> FormatterState) -> FormatM ())
-> (FormatterState -> FormatterState) -> FormatM ()
forall a b. (a -> b) -> a -> b
$ \ FormatterState
state -> FormatterState
state {stateTransientOutput :: String
stateTransientOutput = String
new}
    Handle
h <- FormatM Handle
getHandle
    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

clearTransientOutput :: FormatM ()
clearTransientOutput :: FormatM ()
clearTransientOutput = do
  Int
n <- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> FormatM String -> FormatM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FormatterState -> String) -> FormatM String
forall a. (FormatterState -> a) -> FormatM a
gets FormatterState -> String
stateTransientOutput
  Bool -> FormatM () -> FormatM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ do
    String -> FormatM ()
write (String
"\r" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\r")
    (FormatterState -> FormatterState) -> FormatM ()
modify ((FormatterState -> FormatterState) -> FormatM ())
-> (FormatterState -> FormatterState) -> FormatM ()
forall a b. (a -> b) -> a -> b
$ \ FormatterState
state -> FormatterState
state {stateTransientOutput :: String
stateTransientOutput = String
""}

-- | Append some output to the report.
write :: String -> FormatM ()
write :: String -> FormatM ()
write String
s = do
  Handle
h <- FormatM Handle
getHandle
  IO () -> FormatM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FormatM ()) -> IO () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
IO.hPutStr Handle
h String
s

-- | 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 StateT (IORef FormatterState) IO a
action) = do
  Bool
useColor <- (FormatConfig -> Bool) -> FormatM Bool
forall a. (FormatConfig -> a) -> FormatM a
getConfig FormatConfig -> Bool
formatConfigUseColor
  Handle
h <- FormatM Handle
getHandle

  StateT (IORef FormatterState) IO a -> FormatM a
forall a. StateT (IORef FormatterState) IO a -> FormatM a
FormatM (StateT (IORef FormatterState) IO a -> FormatM a)
-> ((IORef FormatterState -> IO (a, IORef FormatterState))
    -> StateT (IORef FormatterState) IO a)
-> (IORef FormatterState -> IO (a, IORef FormatterState))
-> FormatM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IORef FormatterState -> IO (a, IORef FormatterState))
-> StateT (IORef FormatterState) IO a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((IORef FormatterState -> IO (a, IORef FormatterState))
 -> FormatM a)
-> (IORef FormatterState -> IO (a, IORef FormatterState))
-> FormatM a
forall a b. (a -> b) -> a -> b
$ \IORef FormatterState
st -> do
    IO ()
-> IO ()
-> IO (a, IORef FormatterState)
-> IO (a, IORef FormatterState)
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_

      -- set color
      (Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
useColor (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> [SGR] -> IO ()
hSetSGR Handle
h [SGR
color])

      -- reset colors
      (Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
useColor (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> [SGR] -> IO ()
hSetSGR Handle
h [SGR
Reset])

      -- run action
      (StateT (IORef FormatterState) IO a
-> IORef FormatterState -> IO (a, IORef FormatterState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT (IORef FormatterState) IO a
action IORef FormatterState
st)

-- | Output given chunk in red.
extraChunk :: String -> FormatM ()
extraChunk :: String -> FormatM ()
extraChunk String
s = do
  Bool
useDiff <- (FormatConfig -> Bool) -> FormatM Bool
forall a. (FormatConfig -> a) -> FormatM a
getConfig FormatConfig -> Bool
formatConfigUseDiff
  case Bool
useDiff 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
useDiff <- (FormatConfig -> Bool) -> FormatM Bool
forall a. (FormatConfig -> a) -> FormatM a
getConfig FormatConfig -> Bool
formatConfigUseDiff
  case Bool
useDiff 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)