{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
module System.Wlog.CanLog
( CanLog (..)
, WithLogger
, WithLoggerIO
, logDebug
, logError
, logInfo
, logNotice
, logWarning
, logMessage
, liftLogIO
) where
import Universum
import System.Wlog.HasLoggerName (HasLoggerName (..))
import System.Wlog.IOLogger (logM)
import System.Wlog.LoggerName (LoggerName (..))
import System.Wlog.LoggerNameBox (LoggerNameBox (..), usingLoggerName)
import System.Wlog.Severity (Severity (..))
import qualified Control.Monad.RWS as RWSLazy
import qualified Control.Monad.RWS.Strict as RWSStrict
import qualified Control.Monad.State.Lazy as StateLazy
type WithLogger m = (CanLog m, HasLoggerName m)
type WithLoggerIO m = (MonadIO m, WithLogger 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 = logM
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
liftLogIO :: WithLoggerIO m => (IO a -> IO b) -> LoggerNameBox IO a -> m b
liftLogIO ioFunc action = do
logName <- askLoggerName
liftIO $ ioFunc $ usingLoggerName logName action