module Test.Hspec.Formatters.Internal (
Formatter (..)
, FormatM
, getSuccessCount
, getPendingCount
, getFailCount
, getTotalCount
, FailureRecord (..)
, getFailMessages
, getCPUTime
, getRealTime
, write
, writeLine
, newParagraph
, withSuccessColor
, withPendingColor
, withFailColor
, runFormatM
, liftIO
, increaseSuccessCount
, increasePendingCount
, increaseFailCount
, addFailMessage
) where
import qualified System.IO as IO
import System.IO (Handle)
import Control.Monad (when, unless)
import Control.Applicative
import Control.Exception (SomeException, bracket_)
import System.Console.ANSI
import Control.Monad.Trans.State hiding (gets, modify)
import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.IO.Class as IOClass
import qualified System.CPUTime as CPUTime
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
import Test.Hspec.Util (Path)
gets :: (FormatterState -> a) -> FormatM a
gets f = FormatM (State.gets f)
modify :: (FormatterState -> FormatterState) -> FormatM ()
modify f = FormatM (State.modify f)
liftIO :: IO a -> FormatM a
liftIO action = FormatM (IOClass.liftIO action)
data FormatterState = FormatterState {
stateHandle :: Handle
, stateUseColor :: Bool
, produceHTML :: Bool
, lastIsEmptyLine :: Bool
, successCount :: Int
, pendingCount :: Int
, failCount :: Int
, failMessages :: [FailureRecord]
, cpuStartTime :: Integer
, startTime :: POSIXTime
}
totalCount :: FormatterState -> Int
totalCount s = successCount s + pendingCount s + failCount s
newtype FormatM a = FormatM (StateT FormatterState IO a)
deriving (Functor, Applicative, Monad)
runFormatM :: Bool -> Bool -> Handle -> FormatM a -> IO a
runFormatM useColor produceHTML_ handle (FormatM action) = do
time <- getPOSIXTime
cpuTime <- CPUTime.getCPUTime
evalStateT action (FormatterState handle useColor produceHTML_ False 0 0 0 [] cpuTime time)
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
getTotalCount :: FormatM Int
getTotalCount = gets totalCount
addFailMessage :: Path -> (Either SomeException String) -> FormatM ()
addFailMessage p m = modify $ \s -> s {failMessages = FailureRecord p m : failMessages s}
getFailMessages :: FormatM [FailureRecord]
getFailMessages = reverse `fmap` gets failMessages
data FailureRecord = FailureRecord {
failureRecordPath :: Path
, failureRecordMessage :: Either SomeException String
}
data Formatter = Formatter {
headerFormatter :: FormatM ()
, exampleGroupStarted :: Int -> [String] -> String -> FormatM ()
, exampleGroupDone :: FormatM ()
, exampleSucceeded :: Path -> FormatM ()
, exampleFailed :: Path -> Either SomeException String -> FormatM ()
, examplePending :: Path -> Maybe String -> FormatM ()
, failedFormatter :: FormatM ()
, footerFormatter :: FormatM ()
}
newParagraph :: FormatM ()
newParagraph = do
f <- gets lastIsEmptyLine
unless f $ do
writeLine ""
setLastIsEmptyLine True
setLastIsEmptyLine :: Bool -> FormatM ()
setLastIsEmptyLine f = modify $ \s -> s {lastIsEmptyLine = f}
write :: String -> FormatM ()
write s = do
h <- gets stateHandle
liftIO $ IO.hPutStr h s
setLastIsEmptyLine False
writeLine :: String -> FormatM ()
writeLine s = write s >> write "\n"
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"
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) = FormatM . StateT $ \st -> do
let useColor = stateUseColor st
h = stateHandle st
bracket_
(when useColor $ hSetSGR h [color])
(when useColor $ hSetSGR h [Reset])
(runStateT action st)
getCPUTime :: FormatM Double
getCPUTime = do
t1 <- liftIO CPUTime.getCPUTime
t0 <- gets cpuStartTime
return (fromIntegral (t1 t0) / (10.0^(12::Integer)))
getRealTime :: FormatM Double
getRealTime = do
t1 <- liftIO getPOSIXTime
t0 <- gets startTime
return (realToFrac $ t1 t0)