@@ -34,6 +34,7 @@ module Katip.Monadic
3434 , katipAddNamespace
3535 , katipAddContext
3636 , KatipContextTState(..)
37+ , NoLoggingT
3738 ) where
3839
3940
@@ -43,6 +44,7 @@ import Control.Exception.Safe
4344import Control.Monad.Base
4445import Control.Monad.Error.Class
4546import Control.Monad.IO.Class
47+import Control.Monad.IO.Unlift
4648import Control.Monad.Reader
4749import Control.Monad.State
4850import Control.Monad.Trans.Control
@@ -389,6 +391,11 @@ instance (MonadIO m) => KatipContext (KatipContextT m) where
389391 getKatipNamespace = KatipContextT $ ReaderT $ \lts -> return (ltsNamespace lts)
390392 localKatipNamespace f (KatipContextT m) = KatipContextT $ local (\s -> s { ltsNamespace = f (ltsNamespace s)}) m
391393
394+instance MonadUnliftIO m => MonadUnliftIO (KatipContextT m) where
395+ askUnliftIO = KatipContextT $
396+ withUnliftIO $ \u ->
397+ pure (UnliftIO (unliftIO u . unKatipContextT))
398+
392399
393400-------------------------------------------------------------------------------
394401runKatipContextT :: (LogItem c) => LogEnv -> c -> Namespace -> KatipContextT m a -> m a
@@ -429,3 +436,53 @@ katipAddContext
429436 -> m a
430437 -> m a
431438katipAddContext i = localKatipContext (<> (liftPayload i))
439+
440+newtype NoLoggingT m a = NoLoggingT {
441+ runNoLoggingT :: m a
442+ } deriving ( Functor
443+ , Applicative
444+ , Monad
445+ , MonadIO
446+ , MonadThrow
447+ , MonadCatch
448+ , MonadMask
449+ , MonadBase b
450+ , MonadState s
451+ , MonadWriter w
452+ , MonadError e
453+ , MonadPlus
454+ , Alternative
455+ , MonadFix
456+ )
457+
458+instance MonadTrans NoLoggingT where
459+ lift = NoLoggingT
460+
461+instance MonadTransControl NoLoggingT where
462+ type StT NoLoggingT a = a
463+ liftWith f = NoLoggingT $ f runNoLoggingT
464+ restoreT = NoLoggingT
465+ {-# INLINE liftWith #-}
466+ {-# INLINE restoreT #-}
467+
468+instance MonadBaseControl b m => MonadBaseControl b (NoLoggingT m) where
469+ type StM (NoLoggingT m) a = StM m a
470+ liftBaseWith f = NoLoggingT $
471+ liftBaseWith $ \runInBase ->
472+ f $ runInBase . runNoLoggingT
473+ restoreM = NoLoggingT . restoreM
474+
475+instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where
476+ askUnliftIO = NoLoggingT $
477+ withUnliftIO $ \u ->
478+ pure (UnliftIO (unliftIO u . runNoLoggingT))
479+
480+instance MonadIO m => Katip (NoLoggingT m) where
481+ getLogEnv = liftIO (initLogEnv "NoLoggingT" "no-logging")
482+ localLogEnv = const id
483+
484+instance MonadIO m => KatipContext (NoLoggingT m) where
485+ getKatipContext = pure mempty
486+ localKatipContext = const id
487+ getKatipNamespace = pure mempty
488+ localKatipNamespace = const id