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

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

import qualified System.IO as IO
import           System.IO (Handle)
import           Control.Exception (AsyncException(..), bracket_, try, throwIO)
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 -> Format FormatM
formatterToFormat :: Formatter -> FormatConfig -> Format FormatM
formatterToFormat Formatter
formatter FormatConfig
config = Format :: forall (m :: * -> *).
(forall a. m a -> IO a)
-> (Path -> m ())
-> (Path -> m ())
-> (Path -> Progress -> m ())
-> (Path -> m ())
-> (Path -> Item -> m ())
-> Format m
Format {
  formatRun :: forall a. FormatM a -> IO a
formatRun = \FormatM a
action -> FormatConfig -> FormatM a -> IO a
forall a. FormatConfig -> FormatM a -> IO a
runFormatM FormatConfig
config (FormatM a -> IO a) -> FormatM a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret (Formatter -> FormatM ()
M.headerFormatter Formatter
formatter)
    a
a <- FormatM a
action FormatM a -> FormatM () -> FormatM a
forall a. FormatM a -> FormatM () -> FormatM a
`finally_` FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret (Formatter -> FormatM ()
M.failedFormatter Formatter
formatter)
    FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret (Formatter -> FormatM ()
M.footerFormatter Formatter
formatter)
    a -> FormatM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
, formatGroupStarted :: Path -> FormatM ()
formatGroupStarted = \ ([String]
nesting, String
name) -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Formatter -> [String] -> String -> FormatM ()
M.exampleGroupStarted Formatter
formatter [String]
nesting String
name
, formatGroupDone :: Path -> FormatM ()
formatGroupDone = \ Path
_ -> FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret (Formatter -> FormatM ()
M.exampleGroupDone Formatter
formatter)

, formatProgress :: Path -> Progress -> FormatM ()
formatProgress = \ Path
path Progress
progress -> do
    FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Formatter -> Path -> Progress -> FormatM ()
M.exampleProgress Formatter
formatter Path
path Progress
progress

, formatItemStarted :: Path -> FormatM ()
formatItemStarted = \ Path
path -> do
    FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Formatter -> Path -> FormatM ()
M.exampleStarted Formatter
formatter Path
path

, formatItemDone :: Path -> Item -> FormatM ()
formatItemDone = \ Path
path (Item Maybe Location
loc Seconds
_duration String
info Result
result) -> do
    FormatM ()
clearTransientOutput
    case Result
result of
      Result
Success -> do
        FormatM ()
increaseSuccessCount
        FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Formatter -> Path -> String -> FormatM ()
M.exampleSucceeded Formatter
formatter Path
path String
info
      Pending Maybe String
reason -> do
        FormatM ()
increasePendingCount
        FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Formatter -> Path -> String -> Maybe String -> FormatM ()
M.examplePending Formatter
formatter Path
path String
info Maybe String
reason
      Failure FailureReason
err -> do
        Maybe Location -> Path -> FailureReason -> FormatM ()
addFailMessage Maybe Location
loc Path
path FailureReason
err
        FormatM () -> FormatM ()
forall a. FormatM a -> FormatM a
interpret (FormatM () -> FormatM ()) -> FormatM () -> FormatM ()
forall a b. (a -> b) -> a -> b
$ Formatter -> Path -> String -> FailureReason -> FormatM ()
M.exampleFailed Formatter
formatter Path
path String
info FailureReason
err
}

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 Integer
-> 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
, environmentUsedSeed :: FormatM Integer
environmentUsedSeed = FormatM Integer
usedSeed
, 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 FormatConfig = FormatConfig {
  FormatConfig -> Handle
formatConfigHandle :: Handle
, FormatConfig -> Bool
formatConfigUseColor :: Bool
, FormatConfig -> Bool
formatConfigUseDiff :: Bool
, FormatConfig -> Bool
formatConfigHtmlOutput :: Bool
, FormatConfig -> Bool
formatConfigPrintCpuTime :: Bool
, FormatConfig -> Integer
formatConfigUsedSeed :: Integer
} deriving (FormatConfig -> FormatConfig -> Bool
(FormatConfig -> FormatConfig -> Bool)
-> (FormatConfig -> FormatConfig -> Bool) -> Eq FormatConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FormatConfig -> FormatConfig -> Bool
$c/= :: FormatConfig -> FormatConfig -> Bool
== :: FormatConfig -> FormatConfig -> Bool
$c== :: FormatConfig -> FormatConfig -> Bool
Eq, Int -> FormatConfig -> ShowS
[FormatConfig] -> ShowS
FormatConfig -> String
(Int -> FormatConfig -> ShowS)
-> (FormatConfig -> String)
-> ([FormatConfig] -> ShowS)
-> Show FormatConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FormatConfig] -> ShowS
$cshowList :: [FormatConfig] -> ShowS
show :: FormatConfig -> String
$cshow :: FormatConfig -> String
showsPrec :: Int -> FormatConfig -> ShowS
$cshowsPrec :: Int -> FormatConfig -> ShowS
Show)

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

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

overwriteWith :: String -> String -> String
overwriteWith :: String -> ShowS
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 -> ShowS
forall a. a -> [a] -> [a]
: String
new String -> ShowS
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 -> ShowS
`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 -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ' String -> ShowS
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cls String -> ShowS
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

-- |
-- @finally_ actionA actionB@ runs @actionA@ and then @actionB@.  @actionB@ is
-- run even when a `UserInterrupt` occurs during @actionA@.
finally_ :: FormatM a -> FormatM () -> FormatM a
finally_ :: FormatM a -> FormatM () -> FormatM a
finally_ (FormatM StateT (IORef FormatterState) IO a
actionA) (FormatM StateT (IORef FormatterState) IO ()
actionB) = 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
  Either AsyncException (a, IORef FormatterState)
r <- IO (a, IORef FormatterState)
-> IO (Either AsyncException (a, IORef FormatterState))
forall e a. Exception e => IO a -> IO (Either e a)
try (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
actionA IORef FormatterState
st)
  case Either AsyncException (a, IORef FormatterState)
r of
    Left AsyncException
e -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AsyncException
e AsyncException -> AsyncException -> Bool
forall a. Eq a => a -> a -> Bool
== AsyncException
UserInterrupt) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        StateT (IORef FormatterState) IO ()
-> IORef FormatterState -> IO ((), IORef FormatterState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT (IORef FormatterState) IO ()
actionB IORef FormatterState
st IO ((), IORef FormatterState) -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      AsyncException -> IO (a, IORef FormatterState)
forall e a. Exception e => e -> IO a
throwIO AsyncException
e
    Right (a
a, IORef FormatterState
st_) -> do
      StateT (IORef FormatterState) IO ()
-> IORef FormatterState -> IO ((), IORef FormatterState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT (IORef FormatterState) IO ()
actionB IORef FormatterState
st_ IO ((), IORef FormatterState)
-> (((), IORef FormatterState) -> IO (a, IORef FormatterState))
-> IO (a, IORef FormatterState)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a, IORef FormatterState) -> IO (a, IORef FormatterState)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, IORef FormatterState) -> IO (a, IORef FormatterState))
-> (((), IORef FormatterState) -> (a, IORef FormatterState))
-> ((), IORef FormatterState)
-> IO (a, IORef FormatterState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ((), IORef FormatterState) -> (a, IORef FormatterState)
forall a a b. a -> (a, b) -> (a, b)
replaceValue a
a
  where
    replaceValue :: a -> (a, b) -> (a, b)
replaceValue a
a (a
_, b
st) = (a
a, b
st)

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