{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module System.Wlog.HasLoggerName
(
HasLoggerName (..)
, setLoggerName
, withSublogger
) where
import Universum
import Control.Monad.Morph (MFunctor (..))
import Control.Monad.Trans.Cont (ContT, mapContT)
import Control.Monad.Writer (WriterT (..))
import System.Wlog.LoggerName (LoggerName)
import qualified Control.Monad.RWS as RWSLazy
import qualified Control.Monad.RWS.Strict as RWSStrict
import qualified Control.Monad.State as StateLazy (StateT)
class HasLoggerName m where
askLoggerName :: m LoggerName
modifyLoggerName :: (LoggerName -> LoggerName) -> m a -> m a
default askLoggerName :: (MonadTrans t, t n ~ m, Monad n, HasLoggerName n) => m LoggerName
askLoggerName = lift askLoggerName
default modifyLoggerName :: (MFunctor t, t n ~ m, Monad n, HasLoggerName n)
=> (LoggerName -> LoggerName)
-> m a
-> m a
modifyLoggerName f = hoist (modifyLoggerName f)
instance (Monad m, HasLoggerName m) => HasLoggerName (ReaderT a m) where
instance (Monad m, HasLoggerName m) => HasLoggerName (StateT a m) where
instance (Monad m, HasLoggerName m) => HasLoggerName (StateLazy.StateT a m) where
instance (Monoid w, Monad m, HasLoggerName m) => HasLoggerName (WriterT w m) where
instance (Monad m, HasLoggerName m) => HasLoggerName (ExceptT e m) where
instance (Monad m, HasLoggerName m) => HasLoggerName (ContT r m) where
askLoggerName = lift askLoggerName
modifyLoggerName = mapContT . modifyLoggerName
instance (Monad m, HasLoggerName m, Monoid w) => HasLoggerName (RWSLazy.RWST r w s m) where
instance (Monad m, HasLoggerName m, Monoid w) => HasLoggerName (RWSStrict.RWST r w s m) where
instance HasLoggerName Identity where
askLoggerName = Identity "Identity"
modifyLoggerName = flip const
setLoggerName :: HasLoggerName m => LoggerName -> m a -> m a
setLoggerName = modifyLoggerName . const
withSublogger :: HasLoggerName m => LoggerName -> m a -> m a
withSublogger name = modifyLoggerName (<> name)