module Control.Monad.Logger.Prefix
(
LogPrefixT()
, prefixLogs
, module Export
) where
import Control.Applicative
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Logger as Export
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Control
import Control.Monad.Trans.Resource
import Control.Monad.Writer
import Data.Text (Text)
import Prelude
prefixLogs :: Text -> LogPrefixT m a -> m a
prefixLogs prefix =
flip runReaderT (toLogStr $! mconcat ["[", prefix, "] "]) . runLogPrefixT
infixr 5 `prefixLogs`
newtype LogPrefixT m a = LogPrefixT { runLogPrefixT :: ReaderT LogStr m a }
deriving
(Functor, Applicative, Monad, MonadTrans, MonadIO, MonadThrow, MonadCatch, MonadMask)
instance MonadLogger m => MonadLogger (LogPrefixT m) where
monadLoggerLog loc src lvl msg = LogPrefixT $ ReaderT $ \prefix ->
monadLoggerLog loc src lvl (toLogStr prefix <> toLogStr msg)
instance MonadBase b m => MonadBase b (LogPrefixT m) where
liftBase = lift . liftBase
instance MonadBaseControl b m => MonadBaseControl b (LogPrefixT m) where
type StM (LogPrefixT m) a = StM m a
liftBaseWith f = LogPrefixT $ ReaderT $ \reader' ->
liftBaseWith $ \runInBase ->
f $ runInBase . (\(LogPrefixT r) -> runReaderT r reader')
restoreM = LogPrefixT . ReaderT . const . restoreM
instance MonadReader r m => MonadReader r (LogPrefixT m) where
ask = lift ask
local = mapLogPrefixT . local
instance MonadState s m => MonadState s (LogPrefixT m) where
get = lift get
put = lift . put
instance MonadError e m => MonadError e (LogPrefixT m) where
throwError = lift . throwError
catchError err k = LogPrefixT
$ ReaderT
$ \prfx -> runReaderT (runLogPrefixT err) prfx
`catchError`
\e -> runReaderT (runLogPrefixT (k e)) prfx
instance MonadWriter w m => MonadWriter w (LogPrefixT m) where
tell = lift . tell
listen = mapLogPrefixT listen
pass = mapLogPrefixT pass
instance MonadResource m => MonadResource (LogPrefixT m) where
liftResourceT = lift . liftResourceT
mapLogPrefixT :: (m a -> n b) -> LogPrefixT m a -> LogPrefixT n b
mapLogPrefixT f rfn =
LogPrefixT . ReaderT $ f . runReaderT (runLogPrefixT rfn)