{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module System.Wlog.LoggerNameBox
(
LoggerNameBox (..)
, usingLoggerName
) where
import Universum
import Control.Monad.Base (MonadBase)
import Control.Monad.Except (MonadError)
import Control.Monad.Fix (MonadFix)
import Control.Monad.Morph (MFunctor (..))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import System.Wlog.HasLoggerName (HasLoggerName (..))
import System.Wlog.LoggerName (LoggerName)
newtype LoggerNameBox m a = LoggerNameBox
{ loggerNameBoxEntry :: ReaderT LoggerName m a
} deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadBase b,
MonadThrow, MonadCatch, MonadMask, MonadError e, MonadState s,
MonadFix)
instance MonadReader r m => MonadReader r (LoggerNameBox m) where
ask = lift ask
reader = lift . reader
local f (LoggerNameBox m) = askLoggerName >>= lift . local f . runReaderT m
instance MonadBaseControl b m => MonadBaseControl b (LoggerNameBox m) where
type StM (LoggerNameBox m) a = StM (ReaderT LoggerName m) a
liftBaseWith io =
LoggerNameBox $ liftBaseWith $ \runInBase -> io $ runInBase . loggerNameBoxEntry
restoreM = LoggerNameBox . restoreM
instance MFunctor LoggerNameBox where
hoist f = LoggerNameBox . hoist f . loggerNameBoxEntry
usingLoggerName :: LoggerName -> LoggerNameBox m a -> m a
usingLoggerName name = flip runReaderT name . loggerNameBoxEntry
instance Monad m => HasLoggerName (LoggerNameBox m) where
askLoggerName = LoggerNameBox ask
modifyLoggerName how = LoggerNameBox . local how . loggerNameBoxEntry