module Test.Hspec.Core.Formatters.Internal (
FormatM
, runFormatM
, interpret
, increaseSuccessCount
, increasePendingCount
, increaseFailCount
, addFailMessage
, finally_
) where
import Prelude ()
import Test.Hspec.Core.Compat
import qualified System.IO as IO
import System.IO (Handle)
import Control.Monad
import Control.Exception (SomeException, AsyncException(..), bracket_, try, throwIO)
import System.Console.ANSI
import Control.Monad.Trans.State hiding (gets, modify)
import Control.Monad.IO.Class
import qualified System.CPUTime as CPUTime
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
import Test.Hspec.Core.Util (Path)
import Test.Hspec.Core.Spec (Location)
import Test.Hspec.Core.Example (FailureReason(..))
import qualified Test.Hspec.Core.Formatters.Monad as M
import Test.Hspec.Core.Formatters.Monad (Environment(..), interpretWith, FailureRecord(..))
interpret :: M.FormatM a -> FormatM a
interpret = interpretWith Environment {
environmentGetSuccessCount = getSuccessCount
, environmentGetPendingCount = getPendingCount
, environmentGetFailCount = getFailCount
, environmentGetFailMessages = getFailMessages
, environmentUsedSeed = usedSeed
, environmentGetCPUTime = getCPUTime
, environmentGetRealTime = getRealTime
, environmentWrite = write
, environmentWithFailColor = withFailColor
, environmentWithSuccessColor = withSuccessColor
, environmentWithPendingColor = withPendingColor
, environmentWithInfoColor = withInfoColor
, environmentExtraChunk = extraChunk
, environmentMissingChunk = missingChunk
, environmentLiftIO = liftIO
}
gets :: (FormatterState -> a) -> FormatM a
gets f = FormatM $ do
f <$> (get >>= liftIO . readIORef)
modify :: (FormatterState -> FormatterState) -> FormatM ()
modify f = FormatM $ do
get >>= liftIO . (`modifyIORef'` f)
data FormatterState = FormatterState {
stateHandle :: Handle
, stateUseColor :: Bool
, stateUseDiff :: Bool
, produceHTML :: Bool
, successCount :: Int
, pendingCount :: Int
, failCount :: Int
, failMessages :: [FailureRecord]
, stateUsedSeed :: Integer
, cpuStartTime :: Maybe Integer
, startTime :: POSIXTime
}
usedSeed :: FormatM Integer
usedSeed = gets stateUsedSeed
newtype FormatM a = FormatM (StateT (IORef FormatterState) IO a)
deriving (Functor, Applicative, Monad, MonadIO)
runFormatM :: Bool -> Bool -> Bool -> Bool -> Integer -> Handle -> FormatM a -> IO a
runFormatM useColor useDiff produceHTML_ printCpuTime seed handle (FormatM action) = do
time <- getPOSIXTime
cpuTime <- if printCpuTime then Just <$> CPUTime.getCPUTime else pure Nothing
st <- newIORef (FormatterState handle useColor useDiff produceHTML_ 0 0 0 [] seed cpuTime time)
evalStateT action st
increaseSuccessCount :: FormatM ()
increaseSuccessCount = modify $ \s -> s {successCount = succ $ successCount s}
increasePendingCount :: FormatM ()
increasePendingCount = modify $ \s -> s {pendingCount = succ $ pendingCount s}
increaseFailCount :: FormatM ()
increaseFailCount = modify $ \s -> s {failCount = succ $ failCount s}
getSuccessCount :: FormatM Int
getSuccessCount = gets successCount
getPendingCount :: FormatM Int
getPendingCount = gets pendingCount
getFailCount :: FormatM Int
getFailCount = gets failCount
addFailMessage :: Maybe Location -> Path -> Either SomeException FailureReason -> FormatM ()
addFailMessage loc p m = modify $ \s -> s {failMessages = FailureRecord loc p m : failMessages s}
getFailMessages :: FormatM [FailureRecord]
getFailMessages = reverse `fmap` gets failMessages
write :: String -> FormatM ()
write s = do
h <- gets stateHandle
liftIO $ IO.hPutStr h s
withFailColor :: FormatM a -> FormatM a
withFailColor = withColor (SetColor Foreground Dull Red) "hspec-failure"
withSuccessColor :: FormatM a -> FormatM a
withSuccessColor = withColor (SetColor Foreground Dull Green) "hspec-success"
withPendingColor :: FormatM a -> FormatM a
withPendingColor = withColor (SetColor Foreground Dull Yellow) "hspec-pending"
withInfoColor :: FormatM a -> FormatM a
withInfoColor = withColor (SetColor Foreground Dull Cyan) "hspec-info"
withColor :: SGR -> String -> FormatM a -> FormatM a
withColor color cls action = do
r <- gets produceHTML
(if r then htmlSpan cls else withColor_ color) action
htmlSpan :: String -> FormatM a -> FormatM a
htmlSpan cls action = write ("<span class=\"" ++ cls ++ "\">") *> action <* write "</span>"
withColor_ :: SGR -> FormatM a -> FormatM a
withColor_ color (FormatM action) = do
useColor <- gets stateUseColor
h <- gets stateHandle
FormatM . StateT $ \st -> do
bracket_
(when useColor $ hSetSGR h [color])
(when useColor $ hSetSGR h [Reset])
(runStateT action st)
extraChunk :: String -> FormatM ()
extraChunk s = do
useDiff <- gets stateUseDiff
case useDiff of
True -> withFailColor $ write s
False -> write s
missingChunk :: String -> FormatM ()
missingChunk s = do
useDiff <- gets stateUseDiff
case useDiff of
True -> withSuccessColor $ write s
False -> write s
finally_ :: FormatM () -> FormatM () -> FormatM ()
finally_ (FormatM actionA) (FormatM actionB) = FormatM . StateT $ \st -> do
r <- try (execStateT actionA st)
case r of
Left e -> do
when (e == UserInterrupt) $
runStateT actionB st >> return ()
throwIO e
Right st_ -> do
runStateT actionB st_
getCPUTime :: FormatM (Maybe Double)
getCPUTime = do
t1 <- liftIO CPUTime.getCPUTime
mt0 <- gets cpuStartTime
return $ toSeconds <$> (() <$> pure t1 <*> mt0)
where
toSeconds x = fromIntegral x / (10.0 ^ (12 :: Integer))
getRealTime :: FormatM Double
getRealTime = do
t1 <- liftIO getPOSIXTime
t0 <- gets startTime
return (realToFrac $ t1 t0)