module System.Wlog.CanLog
( CanLog (..)
, WithLogger
, logDebug
, logError
, logInfo
, logNotice
, logWarning
, logMessage
) where
import Universum
import Control.Monad.Except (ExceptT)
import qualified Control.Monad.RWS as RWSLazy
import qualified Control.Monad.RWS.Strict as RWSStrict
import qualified Control.Monad.State.Lazy as StateLazy
import Control.Monad.Trans (MonadTrans (lift))
import System.Wlog.HasLoggerName (HasLoggerName (..))
import System.Wlog.Logger (logM)
import System.Wlog.LoggerName (LoggerName (..))
import System.Wlog.LoggerNameBox (LoggerNameBox (..))
import System.Wlog.Severity (Severity (..))
type WithLogger m = (CanLog m, HasLoggerName m)
class Monad m => CanLog m where
dispatchMessage :: LoggerName -> Severity -> Text -> m ()
default dispatchMessage :: (MonadTrans t, t n ~ m, CanLog n)
=> LoggerName
-> Severity
-> Text
-> m ()
dispatchMessage name sev t = lift $ dispatchMessage name sev t
instance CanLog IO where
dispatchMessage name prior msg = logM name prior msg
instance CanLog m => CanLog (LoggerNameBox m)
instance CanLog m => CanLog (ReaderT r m)
instance CanLog m => CanLog (StateT s m)
instance CanLog m => CanLog (StateLazy.StateT s m)
instance CanLog m => CanLog (ExceptT s m)
instance (CanLog m, Monoid w) => CanLog (RWSLazy.RWST r w s m)
instance (CanLog m, Monoid w) => CanLog (RWSStrict.RWST r w s m)
logDebug, logInfo, logNotice, logWarning, logError
:: WithLogger m
=> Text -> m ()
logDebug = logMessage Debug
logInfo = logMessage Info
logNotice = logMessage Notice
logWarning = logMessage Warning
logError = logMessage Error
logMessage
:: WithLogger m
=> Severity
-> Text
-> m ()
logMessage severity t = do
name <- askLoggerName
dispatchMessage name severity t