module System.Wlog.CanLog
( CanLog (..)
, WithLogger
, PureLogger (..)
, LogEvent (..)
, dispatchEvents
, runPureLog
, logDebug
, logError
, logInfo
, logNotice
, logWarning
, logMessage
) where
import Control.Monad.Except (ExceptT, MonadError)
import Control.Monad.Reader (MonadReader, ReaderT)
import qualified Control.Monad.RWS as RWSLazy
import qualified Control.Monad.RWS.Strict as RWSStrict
import Control.Monad.State (MonadState, StateT)
import Control.Monad.Trans (MonadTrans (lift))
import Control.Monad.Writer (MonadWriter (tell), WriterT (runWriterT))
import Data.Bifunctor (second)
import Data.DList (DList, toList)
import Data.SafeCopy (base, deriveSafeCopySimple)
import Data.Text (Text)
import qualified Data.Text as T
import System.Log.Logger (logM)
import System.Wlog.LoggerName (LoggerName (..))
import System.Wlog.LoggerNameBox (HasLoggerName (..), LoggerNameBox (..))
import System.Wlog.Severity (Severity (..), convertSeverity)
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
-> t n ()
dispatchMessage name sev t = lift $ dispatchMessage name sev t
instance CanLog IO where
dispatchMessage
(loggerName -> name)
(convertSeverity -> prior)
(T.unpack -> t)
= logM name prior t
instance CanLog m => CanLog (LoggerNameBox m)
instance CanLog m => CanLog (ReaderT r m)
instance CanLog m => CanLog (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)
data LogEvent = LogEvent
{ leLoggerName :: !LoggerName
, leSeverity :: !Severity
, leMessage :: !Text
} deriving (Show)
deriveSafeCopySimple 0 'base ''LogEvent
newtype PureLogger m a = PureLogger
{ runPureLogger :: WriterT (DList LogEvent) m a
} deriving (Functor, Applicative, Monad, MonadTrans, MonadWriter (DList LogEvent),
MonadState s, MonadReader r, MonadError e, HasLoggerName)
instance Monad m => CanLog (PureLogger m) where
dispatchMessage leLoggerName leSeverity leMessage = tell [LogEvent{..}]
runPureLog :: Monad m => PureLogger m a -> m (a, [LogEvent])
runPureLog = fmap (second toList) . runWriterT . runPureLogger
dispatchEvents :: WithLogger m => [LogEvent] -> m ()
dispatchEvents = mapM_ dispatchLogEvent
where
dispatchLogEvent (LogEvent name sev t) = dispatchMessage name sev t
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 <- getLoggerName
dispatchMessage name severity t