module Test.Hspec.Core.Formatters.Monad (
Formatter (..)
, FailureReason (..)
, FormatM
, getSuccessCount
, getPendingCount
, getFailCount
, getTotalCount
, FailureRecord (..)
, getFailMessages
, usedSeed
, getCPUTime
, getRealTime
, write
, writeLine
, withInfoColor
, withSuccessColor
, withPendingColor
, withFailColor
, extraChunk
, missingChunk
, Environment(..)
, interpretWith
) where
import Prelude ()
import Test.Hspec.Core.Compat
import System.IO (Handle)
import Control.Exception
import Control.Monad.IO.Class
import Test.Hspec.Core.Formatters.Free
import Test.Hspec.Core.Example (FailureReason(..))
import Test.Hspec.Core.Util (Path)
import Test.Hspec.Core.Spec (Progress, Location)
data Formatter = Formatter {
headerFormatter :: FormatM ()
, exampleGroupStarted :: [String] -> String -> FormatM ()
, exampleGroupDone :: FormatM ()
, exampleProgress :: Handle -> Path -> Progress -> IO ()
, exampleSucceeded :: Path -> FormatM ()
, exampleFailed :: Path -> Either SomeException FailureReason -> FormatM ()
, examplePending :: Path -> Maybe String -> FormatM ()
, failedFormatter :: FormatM ()
, footerFormatter :: FormatM ()
}
data FailureRecord = FailureRecord {
failureRecordLocation :: Maybe Location
, failureRecordPath :: Path
, failureRecordMessage :: Either SomeException FailureReason
}
data FormatF next =
GetSuccessCount (Int -> next)
| GetPendingCount (Int -> next)
| GetFailCount (Int -> next)
| GetFailMessages ([FailureRecord] -> next)
| UsedSeed (Integer -> next)
| GetCPUTime (Maybe Double -> next)
| GetRealTime (Double -> next)
| Write String next
| forall a. WithFailColor (FormatM a) (a -> next)
| forall a. WithSuccessColor (FormatM a) (a -> next)
| forall a. WithPendingColor (FormatM a) (a -> next)
| forall a. WithInfoColor (FormatM a) (a -> next)
| ExtraChunk String next
| MissingChunk String next
| forall a. LiftIO (IO a) (a -> next)
instance Functor FormatF where
fmap f x = case x of
GetSuccessCount next -> GetSuccessCount (fmap f next)
GetPendingCount next -> GetPendingCount (fmap f next)
GetFailCount next -> GetFailCount (fmap f next)
GetFailMessages next -> GetFailMessages (fmap f next)
UsedSeed next -> UsedSeed (fmap f next)
GetCPUTime next -> GetCPUTime (fmap f next)
GetRealTime next -> GetRealTime (fmap f next)
Write s next -> Write s (f next)
WithFailColor action next -> WithFailColor action (fmap f next)
WithSuccessColor action next -> WithSuccessColor action (fmap f next)
WithPendingColor action next -> WithPendingColor action (fmap f next)
WithInfoColor action next -> WithInfoColor action (fmap f next)
ExtraChunk s next -> ExtraChunk s (f next)
MissingChunk s next -> MissingChunk s (f next)
LiftIO action next -> LiftIO action (fmap f next)
type FormatM = Free FormatF
instance MonadIO FormatM where
liftIO s = liftF (LiftIO s id)
data Environment m = Environment {
environmentGetSuccessCount :: m Int
, environmentGetPendingCount :: m Int
, environmentGetFailCount :: m Int
, environmentGetFailMessages :: m [FailureRecord]
, environmentUsedSeed :: m Integer
, environmentGetCPUTime :: m (Maybe Double)
, environmentGetRealTime :: m Double
, environmentWrite :: String -> m ()
, environmentWithFailColor :: forall a. m a -> m a
, environmentWithSuccessColor :: forall a. m a -> m a
, environmentWithPendingColor :: forall a. m a -> m a
, environmentWithInfoColor :: forall a. m a -> m a
, environmentExtraChunk :: String -> m ()
, environmentMissingChunk :: String -> m ()
, environmentLiftIO :: forall a. IO a -> m a
}
interpretWith :: forall m a. Monad m => Environment m -> FormatM a -> m a
interpretWith Environment{..} = go
where
go :: forall b. FormatM b -> m b
go m = case m of
Pure value -> return value
Free action -> case action of
GetSuccessCount next -> environmentGetSuccessCount >>= go . next
GetPendingCount next -> environmentGetPendingCount >>= go . next
GetFailCount next -> environmentGetFailCount >>= go . next
GetFailMessages next -> environmentGetFailMessages >>= go . next
UsedSeed next -> environmentUsedSeed >>= go . next
GetCPUTime next -> environmentGetCPUTime >>= go . next
GetRealTime next -> environmentGetRealTime >>= go . next
Write s next -> environmentWrite s >> go next
WithFailColor inner next -> environmentWithFailColor (go inner) >>= go . next
WithSuccessColor inner next -> environmentWithSuccessColor (go inner) >>= go . next
WithPendingColor inner next -> environmentWithPendingColor (go inner) >>= go . next
WithInfoColor inner next -> environmentWithInfoColor (go inner) >>= go . next
ExtraChunk s next -> environmentExtraChunk s >> go next
MissingChunk s next -> environmentMissingChunk s >> go next
LiftIO inner next -> environmentLiftIO inner >>= go . next
getSuccessCount :: FormatM Int
getSuccessCount = liftF (GetSuccessCount id)
getPendingCount :: FormatM Int
getPendingCount = liftF (GetPendingCount id)
getFailCount :: FormatM Int
getFailCount = liftF (GetFailCount id)
getTotalCount :: FormatM Int
getTotalCount = sum <$> sequence [getSuccessCount, getFailCount, getPendingCount]
getFailMessages :: FormatM [FailureRecord]
getFailMessages = liftF (GetFailMessages id)
usedSeed :: FormatM Integer
usedSeed = liftF (UsedSeed id)
getCPUTime :: FormatM (Maybe Double)
getCPUTime = liftF (GetCPUTime id)
getRealTime :: FormatM Double
getRealTime = liftF (GetRealTime id)
write :: String -> FormatM ()
write s = liftF (Write s ())
writeLine :: String -> FormatM ()
writeLine s = write s >> write "\n"
withFailColor :: FormatM a -> FormatM a
withFailColor s = liftF (WithFailColor s id)
withSuccessColor :: FormatM a -> FormatM a
withSuccessColor s = liftF (WithSuccessColor s id)
withPendingColor :: FormatM a -> FormatM a
withPendingColor s = liftF (WithPendingColor s id)
withInfoColor :: FormatM a -> FormatM a
withInfoColor s = liftF (WithInfoColor s id)
extraChunk :: String -> FormatM ()
extraChunk s = liftF (ExtraChunk s ())
missingChunk :: String -> FormatM ()
missingChunk s = liftF (MissingChunk s ())