module System.Wlog.CanLog
( CanLog (..)
, WithLogger
, PureLogger (..)
, LogEvent (..)
, dispatchEvents
, runPureLog
, launchPureLog
, NamedPureLogger (..)
, runNamedPureLog
, launchNamedPureLog
, logDebug
, logError
, logInfo
, logNotice
, logWarning
, logMessage
) where
import Control.Monad.Except (ExceptT)
import Control.Monad.Morph (MFunctor (..))
import qualified Control.Monad.RWS as RWSLazy
import qualified Control.Monad.RWS.Strict as RWSStrict
import qualified Control.Monad.State.Lazy as StateLazy
import qualified Control.Monad.State.Strict as StateStrict
import Control.Monad.Trans (MonadTrans (lift))
import qualified Data.DList as DL (DList, snoc)
import Data.SafeCopy (base, deriveSafeCopySimple)
import Universum
import System.Wlog.Logger (logM)
import System.Wlog.LoggerName (LoggerName (..))
import System.Wlog.LoggerNameBox (HasLoggerName (..), LoggerNameBox (..),
usingLoggerName)
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 (loggerName -> 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)
data LogEvent = LogEvent
{ leLoggerName :: !LoggerName
, leSeverity :: !Severity
, leMessage :: !Text
} deriving (Show)
deriveSafeCopySimple 0 'base ''LogEvent
newtype PureLogger m a = PureLogger
{ runPureLogger :: StateStrict.StateT (DL.DList LogEvent) m a
} deriving (Functor, Applicative, Monad, MonadTrans, MonadState (DL.DList LogEvent),
MonadThrow, HasLoggerName)
instance Monad m => CanLog (PureLogger m) where
dispatchMessage leLoggerName leSeverity leMessage = StateStrict.modify' (flip DL.snoc LogEvent{..})
instance MFunctor PureLogger where
hoist f = PureLogger . hoist f . runPureLogger
runPureLog :: Monad m => PureLogger m a -> m (a, [LogEvent])
runPureLog = fmap (second toList) . flip runStateT mempty . runPureLogger
dispatchEvents :: CanLog m => [LogEvent] -> m ()
dispatchEvents = mapM_ dispatchLogEvent
where
dispatchLogEvent (LogEvent name sev t) = dispatchMessage name sev t
launchPureLog
:: (CanLog n, Monad m)
=> (forall f. Functor f => m (f a) -> n (f b))
-> PureLogger m a
-> n b
launchPureLog hoist' action = do
(logs, res) <- hoist' $ swap <$> runPureLog action
res <$ dispatchEvents logs
newtype NamedPureLogger m a = NamedPureLogger
{ runNamedPureLogger :: PureLogger (LoggerNameBox m) a
} deriving (Functor, Applicative, Monad, MonadState (DL.DList LogEvent),
MonadThrow, HasLoggerName)
instance MonadTrans NamedPureLogger where
lift = NamedPureLogger . lift . lift
instance Monad m => CanLog (NamedPureLogger m) where
dispatchMessage name sev msg =
NamedPureLogger $ dispatchMessage name sev msg
instance MFunctor NamedPureLogger where
hoist f = NamedPureLogger . hoist (hoist f) . runNamedPureLogger
runNamedPureLog
:: (Monad m, HasLoggerName m)
=> NamedPureLogger m a -> m (a, [LogEvent])
runNamedPureLog (NamedPureLogger action) =
getLoggerName >>= (`usingLoggerName` runPureLog action)
launchNamedPureLog
:: (WithLogger n, Monad m)
=> (forall f. Functor f => m (f a) -> n (f b))
-> NamedPureLogger m a
-> n b
launchNamedPureLog hoist' (NamedPureLogger action) = do
name <- getLoggerName
(logs, res) <- hoist' $ swap <$> usingLoggerName name (runPureLog action)
res <$ dispatchEvents logs
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