{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

#if MIN_VERSION_base(4, 9, 0)
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif

-- | Provides support for treating payloads and namespaces as
-- composable contexts. The common pattern would be to provide a
-- 'KatipContext' instance for your base monad.
module Katip.Monadic
  ( -- * Monadic variants of logging functions from "Katip.Core"
    logFM,
    logTM,
    logLocM,
    logItemM,
    logExceptionM,

    -- * Machinery for merging typed log payloads/contexts
    KatipContext (..),
    AnyLogContext,
    LogContexts,
    liftPayload,

    -- * KatipContextT - Utility transformer that provides Katip and KatipContext instances
    KatipContextT (..),
    runKatipContextT,
    katipAddNamespace,
    katipAddContext,
    KatipContextTState (..),
    NoLoggingT (..),
    askLoggerIO,
  )
where

-------------------------------------------------------------------------------
import Control.Applicative
import Control.Exception.Safe
import Control.Monad                               as CM
import Control.Monad.Base
import Control.Monad.Error.Class
#if MIN_VERSION_base(4, 9, 0)
import qualified Control.Monad.Fail                as MF
#endif
import Control.Monad.Fix                           as MFix
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Control
#if !MIN_VERSION_either(4, 5, 0)
import           Control.Monad.Trans.Either        (EitherT, mapEitherT)
#endif
import Control.Monad.Trans.Except (ExceptT, mapExceptT)
import Control.Monad.Trans.Identity (IdentityT, mapIdentityT)
import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)
import Control.Monad.Trans.RWS (RWST, mapRWST)
import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST)
import Control.Monad.Trans.Resource
  ( MonadResource,
    ResourceT,
    transResourceT,
  )
import qualified Control.Monad.Trans.State.Strict as Strict (StateT, mapStateT)
import qualified Control.Monad.Trans.Writer.Strict as Strict
  ( WriterT,
    mapWriterT,
  )
import qualified Control.Monad.Writer as Lazy (WriterT, mapWriterT)
import Control.Monad.Writer.Class as WC
import Data.Aeson
#if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Aeson.Key as K
#endif
import qualified Data.Foldable as FT
#if !MIN_VERSION_aeson(2, 0, 0)
import qualified Data.HashMap.Strict as HM
#endif
import Data.Semigroup as Semi
import Data.Sequence as Seq
import Data.Text (Text)
#if MIN_VERSION_base(4, 8, 0)
#if !MIN_VERSION_base(4, 9, 0)
import           GHC.SrcLoc
#endif
import GHC.Stack
#endif

-------------------------------------------------------------------------------
import Katip.Core
import Language.Haskell.TH

-------------------------------------------------------------------------------

-- | A wrapper around a log context that erases type information so
-- that contexts from multiple layers can be combined intelligently.
data AnyLogContext where
  AnyLogContext :: (LogItem a) => a -> AnyLogContext

-------------------------------------------------------------------------------

-- | Heterogeneous list of log contexts that provides a smart
-- 'LogContext' instance for combining multiple payload policies. This
-- is critical for log contexts deep down in a stack to be able to
-- inject their own context without worrying about other context that
-- has already been set. Also note that contexts are treated as a
-- sequence and '<>' will be appended to the right hand side of the
-- sequence. If there are conflicting keys in the contexts, the /right
-- side will take precedence/, which is counter to how monoid works
-- for 'Map' and 'HashMap', so bear that in mind. The reasoning is
-- that if the user is /sequentially/ adding contexts to the right
-- side of the sequence, on conflict the intent is to overwrite with
-- the newer value (i.e. the rightmost value).
--
-- Additional note: you should not mappend LogContexts in any sort of
-- infinite loop, as it retains all data, so that would be a memory
-- leak.
newtype LogContexts = LogContexts (Seq AnyLogContext) deriving (Semigroup LogContexts
LogContexts
Semigroup LogContexts =>
LogContexts
-> (LogContexts -> LogContexts -> LogContexts)
-> ([LogContexts] -> LogContexts)
-> Monoid LogContexts
[LogContexts] -> LogContexts
LogContexts -> LogContexts -> LogContexts
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: LogContexts
mempty :: LogContexts
$cmappend :: LogContexts -> LogContexts -> LogContexts
mappend :: LogContexts -> LogContexts -> LogContexts
$cmconcat :: [LogContexts] -> LogContexts
mconcat :: [LogContexts] -> LogContexts
Monoid, NonEmpty LogContexts -> LogContexts
LogContexts -> LogContexts -> LogContexts
(LogContexts -> LogContexts -> LogContexts)
-> (NonEmpty LogContexts -> LogContexts)
-> (forall b. Integral b => b -> LogContexts -> LogContexts)
-> Semigroup LogContexts
forall b. Integral b => b -> LogContexts -> LogContexts
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: LogContexts -> LogContexts -> LogContexts
<> :: LogContexts -> LogContexts -> LogContexts
$csconcat :: NonEmpty LogContexts -> LogContexts
sconcat :: NonEmpty LogContexts -> LogContexts
$cstimes :: forall b. Integral b => b -> LogContexts -> LogContexts
stimes :: forall b. Integral b => b -> LogContexts -> LogContexts
Semigroup)

instance ToJSON LogContexts where
  toJSON :: LogContexts -> Value
toJSON (LogContexts Seq AnyLogContext
cs) =
    -- flip mappend to get right-biased merge
    Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ (Object -> Object -> Object) -> Object -> Seq Object -> Object
forall a b. (a -> b -> b) -> b -> Seq a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
FT.foldr ((Object -> Object -> Object) -> Object -> Object -> Object
forall a b c. (a -> b -> c) -> b -> a -> c
flip Object -> Object -> Object
forall a. Monoid a => a -> a -> a
mappend) Object
forall a. Monoid a => a
mempty (Seq Object -> Object) -> Seq Object -> Object
forall a b. (a -> b) -> a -> b
$ (AnyLogContext -> Object) -> Seq AnyLogContext -> Seq Object
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(AnyLogContext a
v) -> a -> Object
forall a. ToObject a => a -> Object
toObject a
v) Seq AnyLogContext
cs

instance ToObject LogContexts

instance LogItem LogContexts where
  payloadKeys :: Verbosity -> LogContexts -> PayloadSelection
payloadKeys Verbosity
verb (LogContexts Seq AnyLogContext
vs) = (PayloadSelection -> PayloadSelection -> PayloadSelection)
-> PayloadSelection -> Seq PayloadSelection -> PayloadSelection
forall a b. (a -> b -> b) -> b -> Seq a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
FT.foldr ((PayloadSelection -> PayloadSelection -> PayloadSelection)
-> PayloadSelection -> PayloadSelection -> PayloadSelection
forall a b c. (a -> b -> c) -> b -> a -> c
flip PayloadSelection -> PayloadSelection -> PayloadSelection
forall a. Monoid a => a -> a -> a
mappend) PayloadSelection
forall a. Monoid a => a
mempty (Seq PayloadSelection -> PayloadSelection)
-> Seq PayloadSelection -> PayloadSelection
forall a b. (a -> b) -> a -> b
$ (AnyLogContext -> PayloadSelection)
-> Seq AnyLogContext -> Seq PayloadSelection
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnyLogContext -> PayloadSelection
payloadKeys' Seq AnyLogContext
vs
    where
      -- To ensure AllKeys doesn't leak keys from other values when
      -- combined, we resolve AllKeys to its equivalent SomeKeys
      -- representation first.
      payloadKeys' :: AnyLogContext -> PayloadSelection
payloadKeys' (AnyLogContext a
v) = case Verbosity -> a -> PayloadSelection
forall a. LogItem a => Verbosity -> a -> PayloadSelection
payloadKeys Verbosity
verb a
v of
        PayloadSelection
AllKeys -> [Text] -> PayloadSelection
SomeKeys ([Text] -> PayloadSelection) -> [Text] -> PayloadSelection
forall a b. (a -> b) -> a -> b
$ Object -> [Text]
forall v. KeyMap v -> [Text]
toKeys (Object -> [Text]) -> Object -> [Text]
forall a b. (a -> b) -> a -> b
$ a -> Object
forall a. ToObject a => a -> Object
toObject a
v
        PayloadSelection
x -> PayloadSelection
x

#if MIN_VERSION_aeson(2, 0, 0)
toKeys :: KM.KeyMap v -> [Text]
toKeys :: forall v. KeyMap v -> [Text]
toKeys = (Key -> Text) -> [Key] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Key -> Text
K.toText ([Key] -> [Text]) -> (KeyMap v -> [Key]) -> KeyMap v -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyMap v -> [Key]
forall v. KeyMap v -> [Key]
KM.keys
#else
toKeys :: HM.HashMap k v -> [k]
toKeys = HM.keys
#endif

-------------------------------------------------------------------------------

-- | Lift a log context into the generic wrapper so that it can
-- combine with the existing log context.
liftPayload :: (LogItem a) => a -> LogContexts
liftPayload :: forall a. LogItem a => a -> LogContexts
liftPayload = Seq AnyLogContext -> LogContexts
LogContexts (Seq AnyLogContext -> LogContexts)
-> (a -> Seq AnyLogContext) -> a -> LogContexts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyLogContext -> Seq AnyLogContext
forall a. a -> Seq a
Seq.singleton (AnyLogContext -> Seq AnyLogContext)
-> (a -> AnyLogContext) -> a -> Seq AnyLogContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AnyLogContext
forall a. LogItem a => a -> AnyLogContext
AnyLogContext

-------------------------------------------------------------------------------

-- | A monadic context that has an inherant way to get logging context
-- and namespace. Examples include a web application monad or database
-- monad. The @local@ variants are just like @local@ from Reader and
-- indeed you can easily implement them with @local@ if you happen to
-- be using a Reader in your monad. These give us 'katipAddNamespace'
-- and 'katipAddContext' that works with *any* 'KatipContext', as
-- opposed to making users have to implement these functions on their
-- own in each app.
class Katip m => KatipContext m where
  getKatipContext :: m LogContexts

  -- | Temporarily modify the current context for the duration of the
  -- supplied monad. Used in 'katipAddContext'
  localKatipContext :: (LogContexts -> LogContexts) -> m a -> m a

  getKatipNamespace :: m Namespace

  -- | Temporarily modify the current namespace for the duration of the
  -- supplied monad. Used in 'katipAddNamespace'
  localKatipNamespace :: (Namespace -> Namespace) -> m a -> m a

instance (KatipContext m, Katip (IdentityT m)) => KatipContext (IdentityT m) where
  getKatipContext :: IdentityT m LogContexts
getKatipContext = m LogContexts -> IdentityT m LogContexts
forall (m :: * -> *) a. Monad m => m a -> IdentityT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogContexts
forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  localKatipContext :: forall a.
(LogContexts -> LogContexts) -> IdentityT m a -> IdentityT m a
localKatipContext = (m a -> m a) -> IdentityT m a -> IdentityT m a
forall {k1} {k2} (m :: k1 -> *) (a :: k1) (n :: k2 -> *) (b :: k2).
(m a -> n b) -> IdentityT m a -> IdentityT n b
mapIdentityT ((m a -> m a) -> IdentityT m a -> IdentityT m a)
-> ((LogContexts -> LogContexts) -> m a -> m a)
-> (LogContexts -> LogContexts)
-> IdentityT m a
-> IdentityT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogContexts -> LogContexts) -> m a -> m a
forall a. (LogContexts -> LogContexts) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(LogContexts -> LogContexts) -> m a -> m a
localKatipContext
  getKatipNamespace :: IdentityT m Namespace
getKatipNamespace = m Namespace -> IdentityT m Namespace
forall (m :: * -> *) a. Monad m => m a -> IdentityT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Namespace
forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  localKatipNamespace :: forall a.
(Namespace -> Namespace) -> IdentityT m a -> IdentityT m a
localKatipNamespace = (m a -> m a) -> IdentityT m a -> IdentityT m a
forall {k1} {k2} (m :: k1 -> *) (a :: k1) (n :: k2 -> *) (b :: k2).
(m a -> n b) -> IdentityT m a -> IdentityT n b
mapIdentityT ((m a -> m a) -> IdentityT m a -> IdentityT m a)
-> ((Namespace -> Namespace) -> m a -> m a)
-> (Namespace -> Namespace)
-> IdentityT m a
-> IdentityT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Namespace -> Namespace) -> m a -> m a
forall a. (Namespace -> Namespace) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(Namespace -> Namespace) -> m a -> m a
localKatipNamespace

instance (KatipContext m, Katip (MaybeT m)) => KatipContext (MaybeT m) where
  getKatipContext :: MaybeT m LogContexts
getKatipContext = m LogContexts -> MaybeT m LogContexts
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogContexts
forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  localKatipContext :: forall a. (LogContexts -> LogContexts) -> MaybeT m a -> MaybeT m a
localKatipContext = (m (Maybe a) -> m (Maybe a)) -> MaybeT m a -> MaybeT m a
forall (m :: * -> *) a (n :: * -> *) b.
(m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
mapMaybeT ((m (Maybe a) -> m (Maybe a)) -> MaybeT m a -> MaybeT m a)
-> ((LogContexts -> LogContexts) -> m (Maybe a) -> m (Maybe a))
-> (LogContexts -> LogContexts)
-> MaybeT m a
-> MaybeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogContexts -> LogContexts) -> m (Maybe a) -> m (Maybe a)
forall a. (LogContexts -> LogContexts) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(LogContexts -> LogContexts) -> m a -> m a
localKatipContext
  getKatipNamespace :: MaybeT m Namespace
getKatipNamespace = m Namespace -> MaybeT m Namespace
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Namespace
forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  localKatipNamespace :: forall a. (Namespace -> Namespace) -> MaybeT m a -> MaybeT m a
localKatipNamespace = (m (Maybe a) -> m (Maybe a)) -> MaybeT m a -> MaybeT m a
forall (m :: * -> *) a (n :: * -> *) b.
(m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
mapMaybeT ((m (Maybe a) -> m (Maybe a)) -> MaybeT m a -> MaybeT m a)
-> ((Namespace -> Namespace) -> m (Maybe a) -> m (Maybe a))
-> (Namespace -> Namespace)
-> MaybeT m a
-> MaybeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Namespace -> Namespace) -> m (Maybe a) -> m (Maybe a)
forall a. (Namespace -> Namespace) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(Namespace -> Namespace) -> m a -> m a
localKatipNamespace

#if !MIN_VERSION_either(4, 5, 0)
instance (KatipContext m, Katip (EitherT e m)) => KatipContext (EitherT e m) where
  getKatipContext = lift getKatipContext
  localKatipContext = mapEitherT . localKatipContext
  getKatipNamespace = lift getKatipNamespace
  localKatipNamespace = mapEitherT . localKatipNamespace
#endif

instance (KatipContext m, Katip (ReaderT r m)) => KatipContext (ReaderT r m) where
  getKatipContext :: ReaderT r m LogContexts
getKatipContext = m LogContexts -> ReaderT r m LogContexts
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogContexts
forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  localKatipContext :: forall a.
(LogContexts -> LogContexts) -> ReaderT r m a -> ReaderT r m a
localKatipContext = (m a -> m a) -> ReaderT r m a -> ReaderT r m a
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT ((m a -> m a) -> ReaderT r m a -> ReaderT r m a)
-> ((LogContexts -> LogContexts) -> m a -> m a)
-> (LogContexts -> LogContexts)
-> ReaderT r m a
-> ReaderT r m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogContexts -> LogContexts) -> m a -> m a
forall a. (LogContexts -> LogContexts) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(LogContexts -> LogContexts) -> m a -> m a
localKatipContext
  getKatipNamespace :: ReaderT r m Namespace
getKatipNamespace = m Namespace -> ReaderT r m Namespace
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Namespace
forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  localKatipNamespace :: forall a.
(Namespace -> Namespace) -> ReaderT r m a -> ReaderT r m a
localKatipNamespace = (m a -> m a) -> ReaderT r m a -> ReaderT r m a
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT ((m a -> m a) -> ReaderT r m a -> ReaderT r m a)
-> ((Namespace -> Namespace) -> m a -> m a)
-> (Namespace -> Namespace)
-> ReaderT r m a
-> ReaderT r m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Namespace -> Namespace) -> m a -> m a
forall a. (Namespace -> Namespace) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(Namespace -> Namespace) -> m a -> m a
localKatipNamespace

instance (KatipContext m, Katip (ResourceT m)) => KatipContext (ResourceT m) where
  getKatipContext :: ResourceT m LogContexts
getKatipContext = m LogContexts -> ResourceT m LogContexts
forall (m :: * -> *) a. Monad m => m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogContexts
forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  localKatipContext :: forall a.
(LogContexts -> LogContexts) -> ResourceT m a -> ResourceT m a
localKatipContext = (m a -> m a) -> ResourceT m a -> ResourceT m a
forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> ResourceT m a -> ResourceT n b
transResourceT ((m a -> m a) -> ResourceT m a -> ResourceT m a)
-> ((LogContexts -> LogContexts) -> m a -> m a)
-> (LogContexts -> LogContexts)
-> ResourceT m a
-> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogContexts -> LogContexts) -> m a -> m a
forall a. (LogContexts -> LogContexts) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(LogContexts -> LogContexts) -> m a -> m a
localKatipContext
  getKatipNamespace :: ResourceT m Namespace
getKatipNamespace = m Namespace -> ResourceT m Namespace
forall (m :: * -> *) a. Monad m => m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Namespace
forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  localKatipNamespace :: forall a.
(Namespace -> Namespace) -> ResourceT m a -> ResourceT m a
localKatipNamespace = (m a -> m a) -> ResourceT m a -> ResourceT m a
forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> ResourceT m a -> ResourceT n b
transResourceT ((m a -> m a) -> ResourceT m a -> ResourceT m a)
-> ((Namespace -> Namespace) -> m a -> m a)
-> (Namespace -> Namespace)
-> ResourceT m a
-> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Namespace -> Namespace) -> m a -> m a
forall a. (Namespace -> Namespace) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(Namespace -> Namespace) -> m a -> m a
localKatipNamespace

instance (KatipContext m, Katip (Strict.StateT s m)) => KatipContext (Strict.StateT s m) where
  getKatipContext :: StateT s m LogContexts
getKatipContext = m LogContexts -> StateT s m LogContexts
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogContexts
forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  localKatipContext :: forall a.
(LogContexts -> LogContexts) -> StateT s m a -> StateT s m a
localKatipContext = (m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
Strict.mapStateT ((m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a)
-> ((LogContexts -> LogContexts) -> m (a, s) -> m (a, s))
-> (LogContexts -> LogContexts)
-> StateT s m a
-> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogContexts -> LogContexts) -> m (a, s) -> m (a, s)
forall a. (LogContexts -> LogContexts) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(LogContexts -> LogContexts) -> m a -> m a
localKatipContext
  getKatipNamespace :: StateT s m Namespace
getKatipNamespace = m Namespace -> StateT s m Namespace
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Namespace
forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  localKatipNamespace :: forall a. (Namespace -> Namespace) -> StateT s m a -> StateT s m a
localKatipNamespace = (m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
Strict.mapStateT ((m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a)
-> ((Namespace -> Namespace) -> m (a, s) -> m (a, s))
-> (Namespace -> Namespace)
-> StateT s m a
-> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Namespace -> Namespace) -> m (a, s) -> m (a, s)
forall a. (Namespace -> Namespace) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(Namespace -> Namespace) -> m a -> m a
localKatipNamespace

instance (KatipContext m, Katip (StateT s m)) => KatipContext (StateT s m) where
  getKatipContext :: StateT s m LogContexts
getKatipContext = m LogContexts -> StateT s m LogContexts
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogContexts
forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  localKatipContext :: forall a.
(LogContexts -> LogContexts) -> StateT s m a -> StateT s m a
localKatipContext = (m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT ((m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a)
-> ((LogContexts -> LogContexts) -> m (a, s) -> m (a, s))
-> (LogContexts -> LogContexts)
-> StateT s m a
-> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogContexts -> LogContexts) -> m (a, s) -> m (a, s)
forall a. (LogContexts -> LogContexts) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(LogContexts -> LogContexts) -> m a -> m a
localKatipContext
  getKatipNamespace :: StateT s m Namespace
getKatipNamespace = m Namespace -> StateT s m Namespace
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Namespace
forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  localKatipNamespace :: forall a. (Namespace -> Namespace) -> StateT s m a -> StateT s m a
localKatipNamespace = (m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT ((m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a)
-> ((Namespace -> Namespace) -> m (a, s) -> m (a, s))
-> (Namespace -> Namespace)
-> StateT s m a
-> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Namespace -> Namespace) -> m (a, s) -> m (a, s)
forall a. (Namespace -> Namespace) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(Namespace -> Namespace) -> m a -> m a
localKatipNamespace

instance (KatipContext m, Katip (ExceptT e m)) => KatipContext (ExceptT e m) where
  getKatipContext :: ExceptT e m LogContexts
getKatipContext = m LogContexts -> ExceptT e m LogContexts
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogContexts
forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  localKatipContext :: forall a.
(LogContexts -> LogContexts) -> ExceptT e m a -> ExceptT e m a
localKatipContext = (m (Either e a) -> m (Either e a))
-> ExceptT e m a -> ExceptT e m a
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT ((m (Either e a) -> m (Either e a))
 -> ExceptT e m a -> ExceptT e m a)
-> ((LogContexts -> LogContexts)
    -> m (Either e a) -> m (Either e a))
-> (LogContexts -> LogContexts)
-> ExceptT e m a
-> ExceptT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogContexts -> LogContexts) -> m (Either e a) -> m (Either e a)
forall a. (LogContexts -> LogContexts) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(LogContexts -> LogContexts) -> m a -> m a
localKatipContext
  getKatipNamespace :: ExceptT e m Namespace
getKatipNamespace = m Namespace -> ExceptT e m Namespace
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Namespace
forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  localKatipNamespace :: forall a.
(Namespace -> Namespace) -> ExceptT e m a -> ExceptT e m a
localKatipNamespace = (m (Either e a) -> m (Either e a))
-> ExceptT e m a -> ExceptT e m a
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT ((m (Either e a) -> m (Either e a))
 -> ExceptT e m a -> ExceptT e m a)
-> ((Namespace -> Namespace) -> m (Either e a) -> m (Either e a))
-> (Namespace -> Namespace)
-> ExceptT e m a
-> ExceptT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Namespace -> Namespace) -> m (Either e a) -> m (Either e a)
forall a. (Namespace -> Namespace) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(Namespace -> Namespace) -> m a -> m a
localKatipNamespace

instance (Monoid w, KatipContext m, Katip (Strict.WriterT w m)) => KatipContext (Strict.WriterT w m) where
  getKatipContext :: WriterT w m LogContexts
getKatipContext = m LogContexts -> WriterT w m LogContexts
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogContexts
forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  localKatipContext :: forall a.
(LogContexts -> LogContexts) -> WriterT w m a -> WriterT w m a
localKatipContext = (m (a, w) -> m (a, w)) -> WriterT w m a -> WriterT w m a
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
Strict.mapWriterT ((m (a, w) -> m (a, w)) -> WriterT w m a -> WriterT w m a)
-> ((LogContexts -> LogContexts) -> m (a, w) -> m (a, w))
-> (LogContexts -> LogContexts)
-> WriterT w m a
-> WriterT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogContexts -> LogContexts) -> m (a, w) -> m (a, w)
forall a. (LogContexts -> LogContexts) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(LogContexts -> LogContexts) -> m a -> m a
localKatipContext
  getKatipNamespace :: WriterT w m Namespace
getKatipNamespace = m Namespace -> WriterT w m Namespace
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Namespace
forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  localKatipNamespace :: forall a.
(Namespace -> Namespace) -> WriterT w m a -> WriterT w m a
localKatipNamespace = (m (a, w) -> m (a, w)) -> WriterT w m a -> WriterT w m a
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
Strict.mapWriterT ((m (a, w) -> m (a, w)) -> WriterT w m a -> WriterT w m a)
-> ((Namespace -> Namespace) -> m (a, w) -> m (a, w))
-> (Namespace -> Namespace)
-> WriterT w m a
-> WriterT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Namespace -> Namespace) -> m (a, w) -> m (a, w)
forall a. (Namespace -> Namespace) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(Namespace -> Namespace) -> m a -> m a
localKatipNamespace

instance (Monoid w, KatipContext m, Katip (Lazy.WriterT w m)) => KatipContext (Lazy.WriterT w m) where
  getKatipContext :: WriterT w m LogContexts
getKatipContext = m LogContexts -> WriterT w m LogContexts
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogContexts
forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  localKatipContext :: forall a.
(LogContexts -> LogContexts) -> WriterT w m a -> WriterT w m a
localKatipContext = (m (a, w) -> m (a, w)) -> WriterT w m a -> WriterT w m a
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
Lazy.mapWriterT ((m (a, w) -> m (a, w)) -> WriterT w m a -> WriterT w m a)
-> ((LogContexts -> LogContexts) -> m (a, w) -> m (a, w))
-> (LogContexts -> LogContexts)
-> WriterT w m a
-> WriterT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogContexts -> LogContexts) -> m (a, w) -> m (a, w)
forall a. (LogContexts -> LogContexts) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(LogContexts -> LogContexts) -> m a -> m a
localKatipContext
  getKatipNamespace :: WriterT w m Namespace
getKatipNamespace = m Namespace -> WriterT w m Namespace
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Namespace
forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  localKatipNamespace :: forall a.
(Namespace -> Namespace) -> WriterT w m a -> WriterT w m a
localKatipNamespace = (m (a, w) -> m (a, w)) -> WriterT w m a -> WriterT w m a
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
Lazy.mapWriterT ((m (a, w) -> m (a, w)) -> WriterT w m a -> WriterT w m a)
-> ((Namespace -> Namespace) -> m (a, w) -> m (a, w))
-> (Namespace -> Namespace)
-> WriterT w m a
-> WriterT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Namespace -> Namespace) -> m (a, w) -> m (a, w)
forall a. (Namespace -> Namespace) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(Namespace -> Namespace) -> m a -> m a
localKatipNamespace

instance (Monoid w, KatipContext m, Katip (Strict.RWST r w s m)) => KatipContext (Strict.RWST r w s m) where
  getKatipContext :: RWST r w s m LogContexts
getKatipContext = m LogContexts -> RWST r w s m LogContexts
forall (m :: * -> *) a. Monad m => m a -> RWST r w s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogContexts
forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  localKatipContext :: forall a.
(LogContexts -> LogContexts) -> RWST r w s m a -> RWST r w s m a
localKatipContext = (m (a, s, w) -> m (a, s, w)) -> RWST r w s m a -> RWST r w s m a
forall (m :: * -> *) a s w (n :: * -> *) b w' r.
(m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
Strict.mapRWST ((m (a, s, w) -> m (a, s, w)) -> RWST r w s m a -> RWST r w s m a)
-> ((LogContexts -> LogContexts) -> m (a, s, w) -> m (a, s, w))
-> (LogContexts -> LogContexts)
-> RWST r w s m a
-> RWST r w s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogContexts -> LogContexts) -> m (a, s, w) -> m (a, s, w)
forall a. (LogContexts -> LogContexts) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(LogContexts -> LogContexts) -> m a -> m a
localKatipContext
  getKatipNamespace :: RWST r w s m Namespace
getKatipNamespace = m Namespace -> RWST r w s m Namespace
forall (m :: * -> *) a. Monad m => m a -> RWST r w s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Namespace
forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  localKatipNamespace :: forall a.
(Namespace -> Namespace) -> RWST r w s m a -> RWST r w s m a
localKatipNamespace = (m (a, s, w) -> m (a, s, w)) -> RWST r w s m a -> RWST r w s m a
forall (m :: * -> *) a s w (n :: * -> *) b w' r.
(m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
Strict.mapRWST ((m (a, s, w) -> m (a, s, w)) -> RWST r w s m a -> RWST r w s m a)
-> ((Namespace -> Namespace) -> m (a, s, w) -> m (a, s, w))
-> (Namespace -> Namespace)
-> RWST r w s m a
-> RWST r w s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Namespace -> Namespace) -> m (a, s, w) -> m (a, s, w)
forall a. (Namespace -> Namespace) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(Namespace -> Namespace) -> m a -> m a
localKatipNamespace

instance (Monoid w, KatipContext m, Katip (RWST r w s m)) => KatipContext (RWST r w s m) where
  getKatipContext :: RWST r w s m LogContexts
getKatipContext = m LogContexts -> RWST r w s m LogContexts
forall (m :: * -> *) a. Monad m => m a -> RWST r w s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogContexts
forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  localKatipContext :: forall a.
(LogContexts -> LogContexts) -> RWST r w s m a -> RWST r w s m a
localKatipContext = (m (a, s, w) -> m (a, s, w)) -> RWST r w s m a -> RWST r w s m a
forall (m :: * -> *) a s w (n :: * -> *) b w' r.
(m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
mapRWST ((m (a, s, w) -> m (a, s, w)) -> RWST r w s m a -> RWST r w s m a)
-> ((LogContexts -> LogContexts) -> m (a, s, w) -> m (a, s, w))
-> (LogContexts -> LogContexts)
-> RWST r w s m a
-> RWST r w s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogContexts -> LogContexts) -> m (a, s, w) -> m (a, s, w)
forall a. (LogContexts -> LogContexts) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(LogContexts -> LogContexts) -> m a -> m a
localKatipContext
  getKatipNamespace :: RWST r w s m Namespace
getKatipNamespace = m Namespace -> RWST r w s m Namespace
forall (m :: * -> *) a. Monad m => m a -> RWST r w s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Namespace
forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  localKatipNamespace :: forall a.
(Namespace -> Namespace) -> RWST r w s m a -> RWST r w s m a
localKatipNamespace = (m (a, s, w) -> m (a, s, w)) -> RWST r w s m a -> RWST r w s m a
forall (m :: * -> *) a s w (n :: * -> *) b w' r.
(m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
mapRWST ((m (a, s, w) -> m (a, s, w)) -> RWST r w s m a -> RWST r w s m a)
-> ((Namespace -> Namespace) -> m (a, s, w) -> m (a, s, w))
-> (Namespace -> Namespace)
-> RWST r w s m a
-> RWST r w s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Namespace -> Namespace) -> m (a, s, w) -> m (a, s, w)
forall a. (Namespace -> Namespace) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(Namespace -> Namespace) -> m a -> m a
localKatipNamespace

deriving instance (Monad m, KatipContext m) => KatipContext (KatipT m)

-------------------------------------------------------------------------------

-- | Log with everything, including a source code location. This is
-- very low level and you typically can use 'logTM' in its
-- place. Automatically supplies payload and namespace.
logItemM ::
  (Applicative m, KatipContext m, HasCallStack) =>
  Maybe Loc ->
  Severity ->
  LogStr ->
  m ()
logItemM :: forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Maybe Loc -> Severity -> LogStr -> m ()
logItemM Maybe Loc
loc Severity
sev LogStr
msg = do
  LogContexts
ctx <- m LogContexts
forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  Namespace
ns <- m Namespace
forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  LogContexts -> Namespace -> Maybe Loc -> Severity -> LogStr -> m ()
forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
a -> Namespace -> Maybe Loc -> Severity -> LogStr -> m ()
logItem LogContexts
ctx Namespace
ns Maybe Loc
loc Severity
sev LogStr
msg

-------------------------------------------------------------------------------

-- | Log with full context, but without any code
-- location. Automatically supplies payload and namespace.
logFM ::
  (Applicative m, KatipContext m) =>
  -- | Severity of the message
  Severity ->
  -- | The log message
  LogStr ->
  m ()
logFM :: forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
sev LogStr
msg = do
  LogContexts
ctx <- m LogContexts
forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  Namespace
ns <- m Namespace
forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  LogContexts -> Namespace -> Severity -> LogStr -> m ()
forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
a -> Namespace -> Severity -> LogStr -> m ()
logF LogContexts
ctx Namespace
ns Severity
sev LogStr
msg

-------------------------------------------------------------------------------

-- | 'Loc'-tagged logging when using template-haskell. Automatically
-- supplies payload and namespace.
--
-- @$(logTM) InfoS "Hello world"@
logTM :: ExpQ
logTM :: ExpQ
logTM = [|logItemM (Just $(ExpQ
getLocTH))|]

-------------------------------------------------------------------------------

-- | 'Loc'-tagged logging when using 'GHC.Stack.getCallStack' implicit-callstacks>.
--   Automatically supplies payload and namespace.
--
-- Same consideration as `logLoc` applies.
--
-- By default, location will be logged from the module that invokes 'logLocM'.
-- If you want to use 'logLocM' in a helper, wrap the entire helper in
-- 'withFrozenCallStack' to retain the callsite of the helper in the logs.
--
-- This function does not require template-haskell. Using GHC <= 7.8 will result
-- in the emission of a log line without any location information.
-- Users using GHC <= 7.8 may want to use the template-haskell function
-- `logTM` for maximum compatibility.
--
-- @logLocM InfoS "Hello world"@
logLocM ::
  (Applicative m, KatipContext m, HasCallStack) =>
  Severity ->
  LogStr ->
  m ()
logLocM :: forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Severity -> LogStr -> m ()
logLocM = Maybe Loc -> Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m, HasCallStack) =>
Maybe Loc -> Severity -> LogStr -> m ()
logItemM Maybe Loc
HasCallStack => Maybe Loc
getLoc

-------------------------------------------------------------------------------

-- | Perform an action while logging any exceptions that may occur.
-- Inspired by 'onException`.
--
-- >>>> error "foo" `logExceptionM` ErrorS
logExceptionM ::
  (KatipContext m, MonadCatch m, Applicative m) =>
  -- | Main action to run
  m a ->
  -- | Severity
  Severity ->
  m a
logExceptionM :: forall (m :: * -> *) a.
(KatipContext m, MonadCatch m, Applicative m) =>
m a -> Severity -> m a
logExceptionM m a
action Severity
sev = m a
action m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
e -> SomeException -> m ()
f SomeException
e m () -> m a -> m a
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> m a
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwM SomeException
e
  where
    f :: SomeException -> m ()
f SomeException
e = Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
sev (SomeException -> LogStr
forall {a}. Show a => a -> LogStr
msg SomeException
e)
    msg :: a -> LogStr
msg a
e = Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
"An exception has occurred: " :: Text) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
Semi.<> a -> LogStr
forall {a}. Show a => a -> LogStr
showLS a
e

-------------------------------------------------------------------------------

-- | Provides a simple transformer that defines a 'KatipContext'
-- instance for a fixed namespace and context. Just like 'KatipT', you
-- should use this if you prefer an explicit transformer stack and
-- don't want to (or cannot) define 'KatipContext' for your monad
-- . This is the slightly more powerful version of KatipT in that it
-- provides KatipContext instead of just Katip. For instance:
--
-- @
--   threadWithLogging = do
--     le <- getLogEnv
--     ctx <- getKatipContext
--     ns <- getKatipNamespace
--     forkIO $ runKatipContextT le ctx ns $ do
--       $(logTM) InfoS "Look, I can log in IO and retain context!"
--       doOtherStuff
-- @
newtype KatipContextT m a = KatipContextT
  { forall (m :: * -> *) a.
KatipContextT m a -> ReaderT KatipContextTState m a
unKatipContextT :: ReaderT KatipContextTState m a
  }
  deriving
    ( (forall a b. (a -> b) -> KatipContextT m a -> KatipContextT m b)
-> (forall a b. a -> KatipContextT m b -> KatipContextT m a)
-> Functor (KatipContextT m)
forall a b. a -> KatipContextT m b -> KatipContextT m a
forall a b. (a -> b) -> KatipContextT m a -> KatipContextT m b
forall (m :: * -> *) a b.
Functor m =>
a -> KatipContextT m b -> KatipContextT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> KatipContextT m a -> KatipContextT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> KatipContextT m a -> KatipContextT m b
fmap :: forall a b. (a -> b) -> KatipContextT m a -> KatipContextT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> KatipContextT m b -> KatipContextT m a
<$ :: forall a b. a -> KatipContextT m b -> KatipContextT m a
Functor,
      Functor (KatipContextT m)
Functor (KatipContextT m) =>
(forall a. a -> KatipContextT m a)
-> (forall a b.
    KatipContextT m (a -> b) -> KatipContextT m a -> KatipContextT m b)
-> (forall a b c.
    (a -> b -> c)
    -> KatipContextT m a -> KatipContextT m b -> KatipContextT m c)
-> (forall a b.
    KatipContextT m a -> KatipContextT m b -> KatipContextT m b)
-> (forall a b.
    KatipContextT m a -> KatipContextT m b -> KatipContextT m a)
-> Applicative (KatipContextT m)
forall a. a -> KatipContextT m a
forall a b.
KatipContextT m a -> KatipContextT m b -> KatipContextT m a
forall a b.
KatipContextT m a -> KatipContextT m b -> KatipContextT m b
forall a b.
KatipContextT m (a -> b) -> KatipContextT m a -> KatipContextT m b
forall a b c.
(a -> b -> c)
-> KatipContextT m a -> KatipContextT m b -> KatipContextT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (KatipContextT m)
forall (m :: * -> *) a. Applicative m => a -> KatipContextT m a
forall (m :: * -> *) a b.
Applicative m =>
KatipContextT m a -> KatipContextT m b -> KatipContextT m a
forall (m :: * -> *) a b.
Applicative m =>
KatipContextT m a -> KatipContextT m b -> KatipContextT m b
forall (m :: * -> *) a b.
Applicative m =>
KatipContextT m (a -> b) -> KatipContextT m a -> KatipContextT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> KatipContextT m a -> KatipContextT m b -> KatipContextT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> KatipContextT m a
pure :: forall a. a -> KatipContextT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
KatipContextT m (a -> b) -> KatipContextT m a -> KatipContextT m b
<*> :: forall a b.
KatipContextT m (a -> b) -> KatipContextT m a -> KatipContextT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> KatipContextT m a -> KatipContextT m b -> KatipContextT m c
liftA2 :: forall a b c.
(a -> b -> c)
-> KatipContextT m a -> KatipContextT m b -> KatipContextT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
KatipContextT m a -> KatipContextT m b -> KatipContextT m b
*> :: forall a b.
KatipContextT m a -> KatipContextT m b -> KatipContextT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
KatipContextT m a -> KatipContextT m b -> KatipContextT m a
<* :: forall a b.
KatipContextT m a -> KatipContextT m b -> KatipContextT m a
Applicative,
      Applicative (KatipContextT m)
Applicative (KatipContextT m) =>
(forall a b.
 KatipContextT m a -> (a -> KatipContextT m b) -> KatipContextT m b)
-> (forall a b.
    KatipContextT m a -> KatipContextT m b -> KatipContextT m b)
-> (forall a. a -> KatipContextT m a)
-> Monad (KatipContextT m)
forall a. a -> KatipContextT m a
forall a b.
KatipContextT m a -> KatipContextT m b -> KatipContextT m b
forall a b.
KatipContextT m a -> (a -> KatipContextT m b) -> KatipContextT m b
forall (m :: * -> *). Monad m => Applicative (KatipContextT m)
forall (m :: * -> *) a. Monad m => a -> KatipContextT m a
forall (m :: * -> *) a b.
Monad m =>
KatipContextT m a -> KatipContextT m b -> KatipContextT m b
forall (m :: * -> *) a b.
Monad m =>
KatipContextT m a -> (a -> KatipContextT m b) -> KatipContextT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
KatipContextT m a -> (a -> KatipContextT m b) -> KatipContextT m b
>>= :: forall a b.
KatipContextT m a -> (a -> KatipContextT m b) -> KatipContextT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
KatipContextT m a -> KatipContextT m b -> KatipContextT m b
>> :: forall a b.
KatipContextT m a -> KatipContextT m b -> KatipContextT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> KatipContextT m a
return :: forall a. a -> KatipContextT m a
Monad,
      Monad (KatipContextT m)
Monad (KatipContextT m) =>
(forall a. IO a -> KatipContextT m a) -> MonadIO (KatipContextT m)
forall a. IO a -> KatipContextT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (KatipContextT m)
forall (m :: * -> *) a. MonadIO m => IO a -> KatipContextT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> KatipContextT m a
liftIO :: forall a. IO a -> KatipContextT m a
MonadIO,
      Monad (KatipContextT m)
Monad (KatipContextT m) =>
(forall e a. (HasCallStack, Exception e) => e -> KatipContextT m a)
-> MonadThrow (KatipContextT m)
forall e a. (HasCallStack, Exception e) => e -> KatipContextT m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (KatipContextT m)
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> KatipContextT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> KatipContextT m a
throwM :: forall e a. (HasCallStack, Exception e) => e -> KatipContextT m a
MonadThrow,
      MonadThrow (KatipContextT m)
MonadThrow (KatipContextT m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 KatipContextT m a -> (e -> KatipContextT m a) -> KatipContextT m a)
-> MonadCatch (KatipContextT m)
forall e a.
(HasCallStack, Exception e) =>
KatipContextT m a -> (e -> KatipContextT m a) -> KatipContextT m a
forall (m :: * -> *). MonadCatch m => MonadThrow (KatipContextT m)
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
KatipContextT m a -> (e -> KatipContextT m a) -> KatipContextT m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
KatipContextT m a -> (e -> KatipContextT m a) -> KatipContextT m a
catch :: forall e a.
(HasCallStack, Exception e) =>
KatipContextT m a -> (e -> KatipContextT m a) -> KatipContextT m a
MonadCatch,
      MonadCatch (KatipContextT m)
MonadCatch (KatipContextT m) =>
(forall b.
 HasCallStack =>
 ((forall a. KatipContextT m a -> KatipContextT m a)
  -> KatipContextT m b)
 -> KatipContextT m b)
-> (forall b.
    HasCallStack =>
    ((forall a. KatipContextT m a -> KatipContextT m a)
     -> KatipContextT m b)
    -> KatipContextT m b)
-> (forall a b c.
    HasCallStack =>
    KatipContextT m a
    -> (a -> ExitCase b -> KatipContextT m c)
    -> (a -> KatipContextT m b)
    -> KatipContextT m (b, c))
-> MonadMask (KatipContextT m)
forall b.
HasCallStack =>
((forall a. KatipContextT m a -> KatipContextT m a)
 -> KatipContextT m b)
-> KatipContextT m b
forall a b c.
HasCallStack =>
KatipContextT m a
-> (a -> ExitCase b -> KatipContextT m c)
-> (a -> KatipContextT m b)
-> KatipContextT m (b, c)
forall (m :: * -> *). MonadMask m => MonadCatch (KatipContextT m)
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. KatipContextT m a -> KatipContextT m a)
 -> KatipContextT m b)
-> KatipContextT m b
forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
KatipContextT m a
-> (a -> ExitCase b -> KatipContextT m c)
-> (a -> KatipContextT m b)
-> KatipContextT m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. KatipContextT m a -> KatipContextT m a)
 -> KatipContextT m b)
-> KatipContextT m b
mask :: forall b.
HasCallStack =>
((forall a. KatipContextT m a -> KatipContextT m a)
 -> KatipContextT m b)
-> KatipContextT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. KatipContextT m a -> KatipContextT m a)
 -> KatipContextT m b)
-> KatipContextT m b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. KatipContextT m a -> KatipContextT m a)
 -> KatipContextT m b)
-> KatipContextT m b
$cgeneralBracket :: forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
KatipContextT m a
-> (a -> ExitCase b -> KatipContextT m c)
-> (a -> KatipContextT m b)
-> KatipContextT m (b, c)
generalBracket :: forall a b c.
HasCallStack =>
KatipContextT m a
-> (a -> ExitCase b -> KatipContextT m c)
-> (a -> KatipContextT m b)
-> KatipContextT m (b, c)
MonadMask,
      MonadBase b,
      MonadState s,
      WC.MonadWriter w,
      MonadError e,
      Monad (KatipContextT m)
Alternative (KatipContextT m)
(Alternative (KatipContextT m), Monad (KatipContextT m)) =>
(forall a. KatipContextT m a)
-> (forall a.
    KatipContextT m a -> KatipContextT m a -> KatipContextT m a)
-> MonadPlus (KatipContextT m)
forall a. KatipContextT m a
forall a.
KatipContextT m a -> KatipContextT m a -> KatipContextT m a
forall (m :: * -> *).
(Alternative m, Monad m) =>
(forall a. m a) -> (forall a. m a -> m a -> m a) -> MonadPlus m
forall (m :: * -> *). MonadPlus m => Monad (KatipContextT m)
forall (m :: * -> *). MonadPlus m => Alternative (KatipContextT m)
forall (m :: * -> *) a. MonadPlus m => KatipContextT m a
forall (m :: * -> *) a.
MonadPlus m =>
KatipContextT m a -> KatipContextT m a -> KatipContextT m a
$cmzero :: forall (m :: * -> *) a. MonadPlus m => KatipContextT m a
mzero :: forall a. KatipContextT m a
$cmplus :: forall (m :: * -> *) a.
MonadPlus m =>
KatipContextT m a -> KatipContextT m a -> KatipContextT m a
mplus :: forall a.
KatipContextT m a -> KatipContextT m a -> KatipContextT m a
CM.MonadPlus,
      MonadIO (KatipContextT m)
MonadIO (KatipContextT m) =>
(forall a. ResourceT IO a -> KatipContextT m a)
-> MonadResource (KatipContextT m)
forall a. ResourceT IO a -> KatipContextT m a
forall (m :: * -> *).
MonadIO m =>
(forall a. ResourceT IO a -> m a) -> MonadResource m
forall (m :: * -> *). MonadResource m => MonadIO (KatipContextT m)
forall (m :: * -> *) a.
MonadResource m =>
ResourceT IO a -> KatipContextT m a
$cliftResourceT :: forall (m :: * -> *) a.
MonadResource m =>
ResourceT IO a -> KatipContextT m a
liftResourceT :: forall a. ResourceT IO a -> KatipContextT m a
MonadResource,
      Applicative (KatipContextT m)
Applicative (KatipContextT m) =>
(forall a. KatipContextT m a)
-> (forall a.
    KatipContextT m a -> KatipContextT m a -> KatipContextT m a)
-> (forall a. KatipContextT m a -> KatipContextT m [a])
-> (forall a. KatipContextT m a -> KatipContextT m [a])
-> Alternative (KatipContextT m)
forall a. KatipContextT m a
forall a. KatipContextT m a -> KatipContextT m [a]
forall a.
KatipContextT m a -> KatipContextT m a -> KatipContextT m a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
forall (m :: * -> *).
Alternative m =>
Applicative (KatipContextT m)
forall (m :: * -> *) a. Alternative m => KatipContextT m a
forall (m :: * -> *) a.
Alternative m =>
KatipContextT m a -> KatipContextT m [a]
forall (m :: * -> *) a.
Alternative m =>
KatipContextT m a -> KatipContextT m a -> KatipContextT m a
$cempty :: forall (m :: * -> *) a. Alternative m => KatipContextT m a
empty :: forall a. KatipContextT m a
$c<|> :: forall (m :: * -> *) a.
Alternative m =>
KatipContextT m a -> KatipContextT m a -> KatipContextT m a
<|> :: forall a.
KatipContextT m a -> KatipContextT m a -> KatipContextT m a
$csome :: forall (m :: * -> *) a.
Alternative m =>
KatipContextT m a -> KatipContextT m [a]
some :: forall a. KatipContextT m a -> KatipContextT m [a]
$cmany :: forall (m :: * -> *) a.
Alternative m =>
KatipContextT m a -> KatipContextT m [a]
many :: forall a. KatipContextT m a -> KatipContextT m [a]
Alternative,
      Monad (KatipContextT m)
Monad (KatipContextT m) =>
(forall a. (a -> KatipContextT m a) -> KatipContextT m a)
-> MonadFix (KatipContextT m)
forall a. (a -> KatipContextT m a) -> KatipContextT m a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
forall (m :: * -> *). MonadFix m => Monad (KatipContextT m)
forall (m :: * -> *) a.
MonadFix m =>
(a -> KatipContextT m a) -> KatipContextT m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> KatipContextT m a) -> KatipContextT m a
mfix :: forall a. (a -> KatipContextT m a) -> KatipContextT m a
MFix.MonadFix,
      (forall (m :: * -> *). Monad m => Monad (KatipContextT m)) =>
(forall (m :: * -> *) a. Monad m => m a -> KatipContextT m a)
-> MonadTrans KatipContextT
forall (m :: * -> *). Monad m => Monad (KatipContextT m)
forall (m :: * -> *) a. Monad m => m a -> KatipContextT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> KatipContextT m a
lift :: forall (m :: * -> *) a. Monad m => m a -> KatipContextT m a
MonadTrans
    )

data KatipContextTState = KatipContextTState
  { KatipContextTState -> LogEnv
ltsLogEnv :: !LogEnv,
    KatipContextTState -> LogContexts
ltsContext :: !LogContexts,
    KatipContextTState -> Namespace
ltsNamespace :: !Namespace
  }

instance MonadTransControl KatipContextT where
  type StT KatipContextT a = StT (ReaderT KatipContextTState) a
  liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run KatipContextT -> m a) -> KatipContextT m a
liftWith = (forall b. ReaderT KatipContextTState m b -> KatipContextT m b)
-> (forall (m :: * -> *) a.
    KatipContextT m a -> ReaderT KatipContextTState m a)
-> (RunDefault KatipContextT (ReaderT KatipContextTState) -> m a)
-> KatipContextT m a
forall (m :: * -> *) (n :: (* -> *) -> * -> *)
       (t :: (* -> *) -> * -> *) a.
(Monad m, MonadTransControl n) =>
(forall b. n m b -> t m b)
-> (forall (o :: * -> *) b. t o b -> n o b)
-> (RunDefault t n -> m a)
-> t m a
defaultLiftWith ReaderT KatipContextTState m b -> KatipContextT m b
forall b. ReaderT KatipContextTState m b -> KatipContextT m b
forall (m :: * -> *) a.
ReaderT KatipContextTState m a -> KatipContextT m a
KatipContextT KatipContextT o b -> ReaderT KatipContextTState o b
forall (m :: * -> *) a.
KatipContextT m a -> ReaderT KatipContextTState m a
unKatipContextT
  restoreT :: forall (m :: * -> *) a.
Monad m =>
m (StT KatipContextT a) -> KatipContextT m a
restoreT = (ReaderT KatipContextTState m a -> KatipContextT m a)
-> m (StT (ReaderT KatipContextTState) a) -> KatipContextT m a
forall (m :: * -> *) (n :: (* -> *) -> * -> *) a
       (t :: (* -> *) -> * -> *).
(Monad m, MonadTransControl n) =>
(n m a -> t m a) -> m (StT n a) -> t m a
defaultRestoreT ReaderT KatipContextTState m a -> KatipContextT m a
forall (m :: * -> *) a.
ReaderT KatipContextTState m a -> KatipContextT m a
KatipContextT
  {-# INLINE liftWith #-}
  {-# INLINE restoreT #-}

instance (MonadBaseControl b m) => MonadBaseControl b (KatipContextT m) where
  type StM (KatipContextT m) a = ComposeSt KatipContextT m a
  liftBaseWith :: forall a.
(RunInBase (KatipContextT m) b -> b a) -> KatipContextT m a
liftBaseWith = (RunInBaseDefault KatipContextT m b -> b a) -> KatipContextT m a
(RunInBase (KatipContextT m) b -> b a) -> KatipContextT m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
(RunInBaseDefault t m b -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. StM (KatipContextT m) a -> KatipContextT m a
restoreM = ComposeSt KatipContextT m a -> KatipContextT m a
StM (KatipContextT m) a -> KatipContextT m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
ComposeSt t m a -> t m a
defaultRestoreM

-- Reader is a passthrough. We don't expose our internal reader so as not to conflict
instance (MonadReader r m) => MonadReader r (KatipContextT m) where
  ask :: KatipContextT m r
ask = m r -> KatipContextT m r
forall (m :: * -> *) a. Monad m => m a -> KatipContextT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: forall a. (r -> r) -> KatipContextT m a -> KatipContextT m a
local r -> r
f (KatipContextT (ReaderT KatipContextTState -> m a
m)) = ReaderT KatipContextTState m a -> KatipContextT m a
forall (m :: * -> *) a.
ReaderT KatipContextTState m a -> KatipContextT m a
KatipContextT (ReaderT KatipContextTState m a -> KatipContextT m a)
-> ReaderT KatipContextTState m a -> KatipContextT m a
forall a b. (a -> b) -> a -> b
$
    (KatipContextTState -> m a) -> ReaderT KatipContextTState m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((KatipContextTState -> m a) -> ReaderT KatipContextTState m a)
-> (KatipContextTState -> m a) -> ReaderT KatipContextTState m a
forall a b. (a -> b) -> a -> b
$ \KatipContextTState
r ->
      (r -> r) -> m a -> m a
forall a. (r -> r) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f (KatipContextTState -> m a
m KatipContextTState
r)

instance (MonadIO m) => Katip (KatipContextT m) where
  getLogEnv :: KatipContextT m LogEnv
getLogEnv = ReaderT KatipContextTState m LogEnv -> KatipContextT m LogEnv
forall (m :: * -> *) a.
ReaderT KatipContextTState m a -> KatipContextT m a
KatipContextT (ReaderT KatipContextTState m LogEnv -> KatipContextT m LogEnv)
-> ReaderT KatipContextTState m LogEnv -> KatipContextT m LogEnv
forall a b. (a -> b) -> a -> b
$ (KatipContextTState -> m LogEnv)
-> ReaderT KatipContextTState m LogEnv
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((KatipContextTState -> m LogEnv)
 -> ReaderT KatipContextTState m LogEnv)
-> (KatipContextTState -> m LogEnv)
-> ReaderT KatipContextTState m LogEnv
forall a b. (a -> b) -> a -> b
$ \KatipContextTState
lts -> LogEnv -> m LogEnv
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (KatipContextTState -> LogEnv
ltsLogEnv KatipContextTState
lts)
  localLogEnv :: forall a.
(LogEnv -> LogEnv) -> KatipContextT m a -> KatipContextT m a
localLogEnv LogEnv -> LogEnv
f (KatipContextT ReaderT KatipContextTState m a
m) = ReaderT KatipContextTState m a -> KatipContextT m a
forall (m :: * -> *) a.
ReaderT KatipContextTState m a -> KatipContextT m a
KatipContextT ((KatipContextTState -> KatipContextTState)
-> ReaderT KatipContextTState m a -> ReaderT KatipContextTState m a
forall a.
(KatipContextTState -> KatipContextTState)
-> ReaderT KatipContextTState m a -> ReaderT KatipContextTState m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\KatipContextTState
s -> KatipContextTState
s {ltsLogEnv = f (ltsLogEnv s)}) ReaderT KatipContextTState m a
m)

instance (MonadIO m) => KatipContext (KatipContextT m) where
  getKatipContext :: KatipContextT m LogContexts
getKatipContext = ReaderT KatipContextTState m LogContexts
-> KatipContextT m LogContexts
forall (m :: * -> *) a.
ReaderT KatipContextTState m a -> KatipContextT m a
KatipContextT (ReaderT KatipContextTState m LogContexts
 -> KatipContextT m LogContexts)
-> ReaderT KatipContextTState m LogContexts
-> KatipContextT m LogContexts
forall a b. (a -> b) -> a -> b
$ (KatipContextTState -> m LogContexts)
-> ReaderT KatipContextTState m LogContexts
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((KatipContextTState -> m LogContexts)
 -> ReaderT KatipContextTState m LogContexts)
-> (KatipContextTState -> m LogContexts)
-> ReaderT KatipContextTState m LogContexts
forall a b. (a -> b) -> a -> b
$ \KatipContextTState
lts -> LogContexts -> m LogContexts
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (KatipContextTState -> LogContexts
ltsContext KatipContextTState
lts)
  localKatipContext :: forall a.
(LogContexts -> LogContexts)
-> KatipContextT m a -> KatipContextT m a
localKatipContext LogContexts -> LogContexts
f (KatipContextT ReaderT KatipContextTState m a
m) = ReaderT KatipContextTState m a -> KatipContextT m a
forall (m :: * -> *) a.
ReaderT KatipContextTState m a -> KatipContextT m a
KatipContextT (ReaderT KatipContextTState m a -> KatipContextT m a)
-> ReaderT KatipContextTState m a -> KatipContextT m a
forall a b. (a -> b) -> a -> b
$ (KatipContextTState -> KatipContextTState)
-> ReaderT KatipContextTState m a -> ReaderT KatipContextTState m a
forall a.
(KatipContextTState -> KatipContextTState)
-> ReaderT KatipContextTState m a -> ReaderT KatipContextTState m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\KatipContextTState
s -> KatipContextTState
s {ltsContext = f (ltsContext s)}) ReaderT KatipContextTState m a
m
  getKatipNamespace :: KatipContextT m Namespace
getKatipNamespace = ReaderT KatipContextTState m Namespace -> KatipContextT m Namespace
forall (m :: * -> *) a.
ReaderT KatipContextTState m a -> KatipContextT m a
KatipContextT (ReaderT KatipContextTState m Namespace
 -> KatipContextT m Namespace)
-> ReaderT KatipContextTState m Namespace
-> KatipContextT m Namespace
forall a b. (a -> b) -> a -> b
$ (KatipContextTState -> m Namespace)
-> ReaderT KatipContextTState m Namespace
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((KatipContextTState -> m Namespace)
 -> ReaderT KatipContextTState m Namespace)
-> (KatipContextTState -> m Namespace)
-> ReaderT KatipContextTState m Namespace
forall a b. (a -> b) -> a -> b
$ \KatipContextTState
lts -> Namespace -> m Namespace
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (KatipContextTState -> Namespace
ltsNamespace KatipContextTState
lts)
  localKatipNamespace :: forall a.
(Namespace -> Namespace) -> KatipContextT m a -> KatipContextT m a
localKatipNamespace Namespace -> Namespace
f (KatipContextT ReaderT KatipContextTState m a
m) = ReaderT KatipContextTState m a -> KatipContextT m a
forall (m :: * -> *) a.
ReaderT KatipContextTState m a -> KatipContextT m a
KatipContextT (ReaderT KatipContextTState m a -> KatipContextT m a)
-> ReaderT KatipContextTState m a -> KatipContextT m a
forall a b. (a -> b) -> a -> b
$ (KatipContextTState -> KatipContextTState)
-> ReaderT KatipContextTState m a -> ReaderT KatipContextTState m a
forall a.
(KatipContextTState -> KatipContextTState)
-> ReaderT KatipContextTState m a -> ReaderT KatipContextTState m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\KatipContextTState
s -> KatipContextTState
s {ltsNamespace = f (ltsNamespace s)}) ReaderT KatipContextTState m a
m

#if MIN_VERSION_unliftio_core(0, 2, 0)
instance MonadUnliftIO m => MonadUnliftIO (KatipContextT m) where
  withRunInIO :: forall b.
((forall a. KatipContextT m a -> IO a) -> IO b)
-> KatipContextT m b
withRunInIO (forall a. KatipContextT m a -> IO a) -> IO b
inner = ReaderT KatipContextTState m b -> KatipContextT m b
forall (m :: * -> *) a.
ReaderT KatipContextTState m a -> KatipContextT m a
KatipContextT (ReaderT KatipContextTState m b -> KatipContextT m b)
-> ReaderT KatipContextTState m b -> KatipContextT m b
forall a b. (a -> b) -> a -> b
$ (KatipContextTState -> m b) -> ReaderT KatipContextTState m b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((KatipContextTState -> m b) -> ReaderT KatipContextTState m b)
-> (KatipContextTState -> m b) -> ReaderT KatipContextTState m b
forall a b. (a -> b) -> a -> b
$ \KatipContextTState
lts -> ((forall a. m a -> IO a) -> IO b) -> m b
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO b) -> m b)
-> ((forall a. m a -> IO a) -> IO b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
    (forall a. KatipContextT m a -> IO a) -> IO b
inner (m a -> IO a
forall a. m a -> IO a
run (m a -> IO a)
-> (KatipContextT m a -> m a) -> KatipContextT m a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogEnv -> LogContexts -> Namespace -> KatipContextT m a -> m a
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT (KatipContextTState -> LogEnv
ltsLogEnv KatipContextTState
lts) (KatipContextTState -> LogContexts
ltsContext KatipContextTState
lts) (KatipContextTState -> Namespace
ltsNamespace KatipContextTState
lts))
#else
instance MonadUnliftIO m => MonadUnliftIO (KatipContextT m) where
  askUnliftIO = KatipContextT $
    withUnliftIO $ \u ->
      pure (UnliftIO (unliftIO u . unKatipContextT))
#endif

#if MIN_VERSION_base(4, 9, 0)
instance MF.MonadFail m => MF.MonadFail (KatipContextT m) where
    fail :: forall a. String -> KatipContextT m a
fail String
msg = m a -> KatipContextT m a
forall (m :: * -> *) a. Monad m => m a -> KatipContextT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
MF.fail String
msg)
    {-# INLINE fail #-}
#endif

-------------------------------------------------------------------------------
runKatipContextT :: (LogItem c) => LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT :: forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
le c
ctx Namespace
ns = (ReaderT KatipContextTState m a -> KatipContextTState -> m a)
-> KatipContextTState -> ReaderT KatipContextTState m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT KatipContextTState m a -> KatipContextTState -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT KatipContextTState
lts (ReaderT KatipContextTState m a -> m a)
-> (KatipContextT m a -> ReaderT KatipContextTState m a)
-> KatipContextT m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KatipContextT m a -> ReaderT KatipContextTState m a
forall (m :: * -> *) a.
KatipContextT m a -> ReaderT KatipContextTState m a
unKatipContextT
  where
    lts :: KatipContextTState
lts = LogEnv -> LogContexts -> Namespace -> KatipContextTState
KatipContextTState LogEnv
le (c -> LogContexts
forall a. LogItem a => a -> LogContexts
liftPayload c
ctx) Namespace
ns

-------------------------------------------------------------------------------

-- | Append a namespace segment to the current namespace for the given
-- monadic action, then restore the previous state
-- afterwards. Works with anything implementing KatipContext.
katipAddNamespace ::
  (KatipContext m) =>
  Namespace ->
  m a ->
  m a
katipAddNamespace :: forall (m :: * -> *) a. KatipContext m => Namespace -> m a -> m a
katipAddNamespace Namespace
ns = (Namespace -> Namespace) -> m a -> m a
forall a. (Namespace -> Namespace) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(Namespace -> Namespace) -> m a -> m a
localKatipNamespace (Namespace -> Namespace -> Namespace
forall a. Semigroup a => a -> a -> a
<> Namespace
ns)

-------------------------------------------------------------------------------

-- | Append some context to the current context for the given monadic
-- action, then restore the previous state afterwards. Important note:
-- be careful using this in a loop. If you're using something like
-- 'forever' or 'replicateM_' that does explicit sharing to avoid a
-- memory leak, youll be fine as it will *sequence* calls to
-- 'katipAddNamespace', so each loop will get the same context
-- added. If you instead roll your own recursion and you're recursing
-- in the action you provide, you'll instead accumulate tons of
-- redundant contexts and even if they all merge on log, they are
-- stored in a sequence and will leak memory. Works with anything
-- implementing KatipContext.
katipAddContext ::
  ( LogItem i,
    KatipContext m
  ) =>
  i ->
  m a ->
  m a
katipAddContext :: forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext i
i = (LogContexts -> LogContexts) -> m a -> m a
forall a. (LogContexts -> LogContexts) -> m a -> m a
forall (m :: * -> *) a.
KatipContext m =>
(LogContexts -> LogContexts) -> m a -> m a
localKatipContext (LogContexts -> LogContexts -> LogContexts
forall a. Semigroup a => a -> a -> a
<> (i -> LogContexts
forall a. LogItem a => a -> LogContexts
liftPayload i
i))

newtype NoLoggingT m a = NoLoggingT
  { forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT :: m a
  }
  deriving
    ( (forall a b. (a -> b) -> NoLoggingT m a -> NoLoggingT m b)
-> (forall a b. a -> NoLoggingT m b -> NoLoggingT m a)
-> Functor (NoLoggingT m)
forall a b. a -> NoLoggingT m b -> NoLoggingT m a
forall a b. (a -> b) -> NoLoggingT m a -> NoLoggingT m b
forall (m :: * -> *) a b.
Functor m =>
a -> NoLoggingT m b -> NoLoggingT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> NoLoggingT m a -> NoLoggingT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> NoLoggingT m a -> NoLoggingT m b
fmap :: forall a b. (a -> b) -> NoLoggingT m a -> NoLoggingT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> NoLoggingT m b -> NoLoggingT m a
<$ :: forall a b. a -> NoLoggingT m b -> NoLoggingT m a
Functor,
      Functor (NoLoggingT m)
Functor (NoLoggingT m) =>
(forall a. a -> NoLoggingT m a)
-> (forall a b.
    NoLoggingT m (a -> b) -> NoLoggingT m a -> NoLoggingT m b)
-> (forall a b c.
    (a -> b -> c)
    -> NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m c)
-> (forall a b. NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m b)
-> (forall a b. NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m a)
-> Applicative (NoLoggingT m)
forall a. a -> NoLoggingT m a
forall a b. NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m a
forall a b. NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m b
forall a b.
NoLoggingT m (a -> b) -> NoLoggingT m a -> NoLoggingT m b
forall a b c.
(a -> b -> c) -> NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (NoLoggingT m)
forall (m :: * -> *) a. Applicative m => a -> NoLoggingT m a
forall (m :: * -> *) a b.
Applicative m =>
NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m a
forall (m :: * -> *) a b.
Applicative m =>
NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m b
forall (m :: * -> *) a b.
Applicative m =>
NoLoggingT m (a -> b) -> NoLoggingT m a -> NoLoggingT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> NoLoggingT m a
pure :: forall a. a -> NoLoggingT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
NoLoggingT m (a -> b) -> NoLoggingT m a -> NoLoggingT m b
<*> :: forall a b.
NoLoggingT m (a -> b) -> NoLoggingT m a -> NoLoggingT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m c
liftA2 :: forall a b c.
(a -> b -> c) -> NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m b
*> :: forall a b. NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m a
<* :: forall a b. NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m a
Applicative,
      Applicative (NoLoggingT m)
Applicative (NoLoggingT m) =>
(forall a b.
 NoLoggingT m a -> (a -> NoLoggingT m b) -> NoLoggingT m b)
-> (forall a b. NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m b)
-> (forall a. a -> NoLoggingT m a)
-> Monad (NoLoggingT m)
forall a. a -> NoLoggingT m a
forall a b. NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m b
forall a b.
NoLoggingT m a -> (a -> NoLoggingT m b) -> NoLoggingT m b
forall (m :: * -> *). Monad m => Applicative (NoLoggingT m)
forall (m :: * -> *) a. Monad m => a -> NoLoggingT m a
forall (m :: * -> *) a b.
Monad m =>
NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m b
forall (m :: * -> *) a b.
Monad m =>
NoLoggingT m a -> (a -> NoLoggingT m b) -> NoLoggingT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
NoLoggingT m a -> (a -> NoLoggingT m b) -> NoLoggingT m b
>>= :: forall a b.
NoLoggingT m a -> (a -> NoLoggingT m b) -> NoLoggingT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m b
>> :: forall a b. NoLoggingT m a -> NoLoggingT m b -> NoLoggingT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> NoLoggingT m a
return :: forall a. a -> NoLoggingT m a
Monad,
      Monad (NoLoggingT m)
Monad (NoLoggingT m) =>
(forall a. IO a -> NoLoggingT m a) -> MonadIO (NoLoggingT m)
forall a. IO a -> NoLoggingT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (NoLoggingT m)
forall (m :: * -> *) a. MonadIO m => IO a -> NoLoggingT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> NoLoggingT m a
liftIO :: forall a. IO a -> NoLoggingT m a
MonadIO,
      Monad (NoLoggingT m)
Monad (NoLoggingT m) =>
(forall e a. (HasCallStack, Exception e) => e -> NoLoggingT m a)
-> MonadThrow (NoLoggingT m)
forall e a. (HasCallStack, Exception e) => e -> NoLoggingT m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (NoLoggingT m)
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> NoLoggingT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> NoLoggingT m a
throwM :: forall e a. (HasCallStack, Exception e) => e -> NoLoggingT m a
MonadThrow,
      MonadThrow (NoLoggingT m)
MonadThrow (NoLoggingT m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 NoLoggingT m a -> (e -> NoLoggingT m a) -> NoLoggingT m a)
-> MonadCatch (NoLoggingT m)
forall e a.
(HasCallStack, Exception e) =>
NoLoggingT m a -> (e -> NoLoggingT m a) -> NoLoggingT m a
forall (m :: * -> *). MonadCatch m => MonadThrow (NoLoggingT m)
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
NoLoggingT m a -> (e -> NoLoggingT m a) -> NoLoggingT m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
NoLoggingT m a -> (e -> NoLoggingT m a) -> NoLoggingT m a
catch :: forall e a.
(HasCallStack, Exception e) =>
NoLoggingT m a -> (e -> NoLoggingT m a) -> NoLoggingT m a
MonadCatch,
      MonadCatch (NoLoggingT m)
MonadCatch (NoLoggingT m) =>
(forall b.
 HasCallStack =>
 ((forall a. NoLoggingT m a -> NoLoggingT m a) -> NoLoggingT m b)
 -> NoLoggingT m b)
-> (forall b.
    HasCallStack =>
    ((forall a. NoLoggingT m a -> NoLoggingT m a) -> NoLoggingT m b)
    -> NoLoggingT m b)
-> (forall a b c.
    HasCallStack =>
    NoLoggingT m a
    -> (a -> ExitCase b -> NoLoggingT m c)
    -> (a -> NoLoggingT m b)
    -> NoLoggingT m (b, c))
-> MonadMask (NoLoggingT m)
forall b.
HasCallStack =>
((forall a. NoLoggingT m a -> NoLoggingT m a) -> NoLoggingT m b)
-> NoLoggingT m b
forall a b c.
HasCallStack =>
NoLoggingT m a
-> (a -> ExitCase b -> NoLoggingT m c)
-> (a -> NoLoggingT m b)
-> NoLoggingT m (b, c)
forall (m :: * -> *). MonadMask m => MonadCatch (NoLoggingT m)
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. NoLoggingT m a -> NoLoggingT m a) -> NoLoggingT m b)
-> NoLoggingT m b
forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
NoLoggingT m a
-> (a -> ExitCase b -> NoLoggingT m c)
-> (a -> NoLoggingT m b)
-> NoLoggingT m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. NoLoggingT m a -> NoLoggingT m a) -> NoLoggingT m b)
-> NoLoggingT m b
mask :: forall b.
HasCallStack =>
((forall a. NoLoggingT m a -> NoLoggingT m a) -> NoLoggingT m b)
-> NoLoggingT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. NoLoggingT m a -> NoLoggingT m a) -> NoLoggingT m b)
-> NoLoggingT m b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. NoLoggingT m a -> NoLoggingT m a) -> NoLoggingT m b)
-> NoLoggingT m b
$cgeneralBracket :: forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
NoLoggingT m a
-> (a -> ExitCase b -> NoLoggingT m c)
-> (a -> NoLoggingT m b)
-> NoLoggingT m (b, c)
generalBracket :: forall a b c.
HasCallStack =>
NoLoggingT m a
-> (a -> ExitCase b -> NoLoggingT m c)
-> (a -> NoLoggingT m b)
-> NoLoggingT m (b, c)
MonadMask,
      MonadBase b,
      MonadState s,
      WC.MonadWriter w,
      MonadError e,
      Monad (NoLoggingT m)
Alternative (NoLoggingT m)
(Alternative (NoLoggingT m), Monad (NoLoggingT m)) =>
(forall a. NoLoggingT m a)
-> (forall a. NoLoggingT m a -> NoLoggingT m a -> NoLoggingT m a)
-> MonadPlus (NoLoggingT m)
forall a. NoLoggingT m a
forall a. NoLoggingT m a -> NoLoggingT m a -> NoLoggingT m a
forall (m :: * -> *).
(Alternative m, Monad m) =>
(forall a. m a) -> (forall a. m a -> m a -> m a) -> MonadPlus m
forall (m :: * -> *). MonadPlus m => Monad (NoLoggingT m)
forall (m :: * -> *). MonadPlus m => Alternative (NoLoggingT m)
forall (m :: * -> *) a. MonadPlus m => NoLoggingT m a
forall (m :: * -> *) a.
MonadPlus m =>
NoLoggingT m a -> NoLoggingT m a -> NoLoggingT m a
$cmzero :: forall (m :: * -> *) a. MonadPlus m => NoLoggingT m a
mzero :: forall a. NoLoggingT m a
$cmplus :: forall (m :: * -> *) a.
MonadPlus m =>
NoLoggingT m a -> NoLoggingT m a -> NoLoggingT m a
mplus :: forall a. NoLoggingT m a -> NoLoggingT m a -> NoLoggingT m a
CM.MonadPlus,
      Applicative (NoLoggingT m)
Applicative (NoLoggingT m) =>
(forall a. NoLoggingT m a)
-> (forall a. NoLoggingT m a -> NoLoggingT m a -> NoLoggingT m a)
-> (forall a. NoLoggingT m a -> NoLoggingT m [a])
-> (forall a. NoLoggingT m a -> NoLoggingT m [a])
-> Alternative (NoLoggingT m)
forall a. NoLoggingT m a
forall a. NoLoggingT m a -> NoLoggingT m [a]
forall a. NoLoggingT m a -> NoLoggingT m a -> NoLoggingT m a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
forall (m :: * -> *). Alternative m => Applicative (NoLoggingT m)
forall (m :: * -> *) a. Alternative m => NoLoggingT m a
forall (m :: * -> *) a.
Alternative m =>
NoLoggingT m a -> NoLoggingT m [a]
forall (m :: * -> *) a.
Alternative m =>
NoLoggingT m a -> NoLoggingT m a -> NoLoggingT m a
$cempty :: forall (m :: * -> *) a. Alternative m => NoLoggingT m a
empty :: forall a. NoLoggingT m a
$c<|> :: forall (m :: * -> *) a.
Alternative m =>
NoLoggingT m a -> NoLoggingT m a -> NoLoggingT m a
<|> :: forall a. NoLoggingT m a -> NoLoggingT m a -> NoLoggingT m a
$csome :: forall (m :: * -> *) a.
Alternative m =>
NoLoggingT m a -> NoLoggingT m [a]
some :: forall a. NoLoggingT m a -> NoLoggingT m [a]
$cmany :: forall (m :: * -> *) a.
Alternative m =>
NoLoggingT m a -> NoLoggingT m [a]
many :: forall a. NoLoggingT m a -> NoLoggingT m [a]
Alternative,
      Monad (NoLoggingT m)
Monad (NoLoggingT m) =>
(forall a. (a -> NoLoggingT m a) -> NoLoggingT m a)
-> MonadFix (NoLoggingT m)
forall a. (a -> NoLoggingT m a) -> NoLoggingT m a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
forall (m :: * -> *). MonadFix m => Monad (NoLoggingT m)
forall (m :: * -> *) a.
MonadFix m =>
(a -> NoLoggingT m a) -> NoLoggingT m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> NoLoggingT m a) -> NoLoggingT m a
mfix :: forall a. (a -> NoLoggingT m a) -> NoLoggingT m a
MFix.MonadFix,
      MonadReader r
    )

instance MonadTrans NoLoggingT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> NoLoggingT m a
lift = m a -> NoLoggingT m a
forall (m :: * -> *) a. m a -> NoLoggingT m a
NoLoggingT

instance MonadTransControl NoLoggingT where
  type StT NoLoggingT a = a
  liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run NoLoggingT -> m a) -> NoLoggingT m a
liftWith Run NoLoggingT -> m a
f = m a -> NoLoggingT m a
forall (m :: * -> *) a. m a -> NoLoggingT m a
NoLoggingT (m a -> NoLoggingT m a) -> m a -> NoLoggingT m a
forall a b. (a -> b) -> a -> b
$ Run NoLoggingT -> m a
f NoLoggingT n b -> n b
NoLoggingT n b -> n (StT NoLoggingT b)
Run NoLoggingT
forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT
  restoreT :: forall (m :: * -> *) a.
Monad m =>
m (StT NoLoggingT a) -> NoLoggingT m a
restoreT = m a -> NoLoggingT m a
m (StT NoLoggingT a) -> NoLoggingT m a
forall (m :: * -> *) a. m a -> NoLoggingT m a
NoLoggingT
  {-# INLINE liftWith #-}
  {-# INLINE restoreT #-}

instance MonadBaseControl b m => MonadBaseControl b (NoLoggingT m) where
  type StM (NoLoggingT m) a = StM m a
  liftBaseWith :: forall a. (RunInBase (NoLoggingT m) b -> b a) -> NoLoggingT m a
liftBaseWith RunInBase (NoLoggingT m) b -> b a
f = m a -> NoLoggingT m a
forall (m :: * -> *) a. m a -> NoLoggingT m a
NoLoggingT (m a -> NoLoggingT m a) -> m a -> NoLoggingT m a
forall a b. (a -> b) -> a -> b
$
    (RunInBase m b -> b a) -> m a
forall a. (RunInBase m b -> b a) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase m b -> b a) -> m a) -> (RunInBase m b -> b a) -> m a
forall a b. (a -> b) -> a -> b
$ \RunInBase m b
runInBase ->
      RunInBase (NoLoggingT m) b -> b a
f (RunInBase (NoLoggingT m) b -> b a)
-> RunInBase (NoLoggingT m) b -> b a
forall a b. (a -> b) -> a -> b
$ m a -> b (StM m a)
RunInBase m b
runInBase (m a -> b (StM m a))
-> (NoLoggingT m a -> m a) -> NoLoggingT m a -> b (StM m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoLoggingT m a -> m a
forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT
  restoreM :: forall a. StM (NoLoggingT m) a -> NoLoggingT m a
restoreM = m a -> NoLoggingT m a
forall (m :: * -> *) a. m a -> NoLoggingT m a
NoLoggingT (m a -> NoLoggingT m a)
-> (StM m a -> m a) -> StM m a -> NoLoggingT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StM m a -> m a
forall a. StM m a -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM



#if MIN_VERSION_unliftio_core(0, 2, 0)
instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where
  withRunInIO :: forall b.
((forall a. NoLoggingT m a -> IO a) -> IO b) -> NoLoggingT m b
withRunInIO (forall a. NoLoggingT m a -> IO a) -> IO b
inner = m b -> NoLoggingT m b
forall (m :: * -> *) a. m a -> NoLoggingT m a
NoLoggingT (m b -> NoLoggingT m b) -> m b -> NoLoggingT m b
forall a b. (a -> b) -> a -> b
$ ((forall a. m a -> IO a) -> IO b) -> m b
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO b) -> m b)
-> ((forall a. m a -> IO a) -> IO b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
    (forall a. NoLoggingT m a -> IO a) -> IO b
inner (m a -> IO a
forall a. m a -> IO a
run (m a -> IO a) -> (NoLoggingT m a -> m a) -> NoLoggingT m a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoLoggingT m a -> m a
forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT)
#else
instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where
  askUnliftIO = NoLoggingT $
    withUnliftIO $ \u ->
      pure (UnliftIO (unliftIO u . runNoLoggingT))
#endif

instance MonadIO m => Katip (NoLoggingT m) where
  getLogEnv :: NoLoggingT m LogEnv
getLogEnv = IO LogEnv -> NoLoggingT m LogEnv
forall a. IO a -> NoLoggingT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Namespace -> Environment -> IO LogEnv
initLogEnv Namespace
"NoLoggingT" Environment
"no-logging")
  localLogEnv :: forall a. (LogEnv -> LogEnv) -> NoLoggingT m a -> NoLoggingT m a
localLogEnv = (NoLoggingT m a -> NoLoggingT m a)
-> (LogEnv -> LogEnv) -> NoLoggingT m a -> NoLoggingT m a
forall a b. a -> b -> a
const NoLoggingT m a -> NoLoggingT m a
forall a. a -> a
id

instance MonadIO m => KatipContext (NoLoggingT m) where
  getKatipContext :: NoLoggingT m LogContexts
getKatipContext = LogContexts -> NoLoggingT m LogContexts
forall a. a -> NoLoggingT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogContexts
forall a. Monoid a => a
mempty
  localKatipContext :: forall a.
(LogContexts -> LogContexts) -> NoLoggingT m a -> NoLoggingT m a
localKatipContext = (NoLoggingT m a -> NoLoggingT m a)
-> (LogContexts -> LogContexts) -> NoLoggingT m a -> NoLoggingT m a
forall a b. a -> b -> a
const NoLoggingT m a -> NoLoggingT m a
forall a. a -> a
id
  getKatipNamespace :: NoLoggingT m Namespace
getKatipNamespace = Namespace -> NoLoggingT m Namespace
forall a. a -> NoLoggingT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Namespace
forall a. Monoid a => a
mempty
  localKatipNamespace :: forall a.
(Namespace -> Namespace) -> NoLoggingT m a -> NoLoggingT m a
localKatipNamespace = (NoLoggingT m a -> NoLoggingT m a)
-> (Namespace -> Namespace) -> NoLoggingT m a -> NoLoggingT m a
forall a b. a -> b -> a
const NoLoggingT m a -> NoLoggingT m a
forall a. a -> a
id

-- | Convenience function for when you have to integrate with a third
-- party API that takes a generic logging function as an argument.
askLoggerIO :: (Applicative m, KatipContext m) => m (Severity -> LogStr -> IO ())
askLoggerIO :: forall (m :: * -> *).
(Applicative m, KatipContext m) =>
m (Severity -> LogStr -> IO ())
askLoggerIO = do
  LogContexts
ctx <- m LogContexts
forall (m :: * -> *). KatipContext m => m LogContexts
getKatipContext
  Namespace
ns <- m Namespace
forall (m :: * -> *). KatipContext m => m Namespace
getKatipNamespace
  LogEnv
logEnv <- m LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
  (Severity -> LogStr -> IO ()) -> m (Severity -> LogStr -> IO ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\Severity
sev LogStr
msg -> LogEnv -> KatipT IO () -> IO ()
forall (m :: * -> *) a. LogEnv -> KatipT m a -> m a
runKatipT LogEnv
logEnv (KatipT IO () -> IO ()) -> KatipT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LogContexts -> Namespace -> Severity -> LogStr -> KatipT IO ()
forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
a -> Namespace -> Severity -> LogStr -> m ()
logF LogContexts
ctx Namespace
ns Severity
sev LogStr
msg)