@@ -47,16 +47,16 @@ import Control.Monad.IO.Class
4747import Control.Monad.Reader
4848import Control.Monad.State
4949import Control.Monad.Trans.Control
50−import Control.Monad.Trans.Either (EitherT)
51−import Control.Monad.Trans.Except (ExceptT)
52−import Control.Monad.Trans.Identity (IdentityT)
53−import Control.Monad.Trans.List (ListT)
54−import Control.Monad.Trans.Maybe (MaybeT)
55−import Control.Monad.Trans.Resource (ResourceT)
56−import Control.Monad.Trans.RWS (RWST)
57−import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST)
58−import qualified Control.Monad.Trans.State.Strict as Strict (StateT)
59−import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT)
50+import Control.Monad.Trans.Either (EitherT, mapEitherT)
51+import Control.Monad.Trans.Except (ExceptT, mapExceptT)
52+import Control.Monad.Trans.Identity (IdentityT, mapIdentityT)
53+import Control.Monad.Trans.List (ListT, mapListT)
54+import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)
55+import Control.Monad.Trans.Resource (ResourceT, transResourceT)
56+import Control.Monad.Trans.RWS (RWST, mapRWST)
57+import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST)
58+import qualified Control.Monad.Trans.State.Strict as Strict (StateT, mapStateT)
59+import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT, mapWriterT)
6060import Control.Monad.Writer hiding ((<>))
6161import Data.Aeson
6262import qualified Data.Foldable as FT
@@ -121,76 +121,113 @@ liftPayload = LogContexts . Seq.singleton . AnyLogContext
121121
122122
123123-------------------------------------------------------------------------------
124−-- | A monadic context that has an inherant way to get logging
125−-- context and namespace. Examples include a web application monad or
126−-- database monad.
124+-- | A monadic context that has an inherant way to get logging context
125+-- and namespace. Examples include a web application monad or database
126+-- monad. The @local@ variants are just like @local@ from Reader and
127+-- indeed you can easily implement them with @local@ if you happen to
128+-- be using a Reader in your monad. These give us 'katipAddNamespace'
129+-- and 'katipAddContext' that works with *any* 'KatipContext', as
130+-- opposed to making users have to implement these functions on their
131+-- own in each app.
127132class Katip m => KatipContext m where
128133 getKatipContext :: m LogContexts
129− getKatipNamespace :: m Namespace
134+ -- | Temporarily modify the current context for the duration of the
135+ -- supplied monad. Used in 'katipAddContext'
136+ localKatipContext :: (LogContexts -> LogContexts) -> m a -> m a
137+ getKatipNamespace :: m Namespace
138+ -- | Temporarily modify the current namespace for the duration of the
139+ -- supplied monad. Used in 'katipAddContext'
140+ localKatipNamespace :: (Namespace -> Namespace) -> m a -> m a
130141
131142instance (KatipContext m, Katip (IdentityT m)) => KatipContext (IdentityT m) where
132143 getKatipContext = lift getKatipContext
144+ localKatipContext = mapIdentityT . localKatipContext
133145 getKatipNamespace = lift getKatipNamespace
146+ localKatipNamespace = mapIdentityT . localKatipNamespace
134147
135148
136149instance (KatipContext m, Katip (MaybeT m)) => KatipContext (MaybeT m) where
137150 getKatipContext = lift getKatipContext
151+ localKatipContext = mapMaybeT . localKatipContext
138152 getKatipNamespace = lift getKatipNamespace
153+ localKatipNamespace = mapMaybeT . localKatipNamespace
139154
140155
141156instance (KatipContext m, Katip (EitherT e m)) => KatipContext (EitherT e m) where
142157 getKatipContext = lift getKatipContext
158+ localKatipContext = mapEitherT . localKatipContext
143159 getKatipNamespace = lift getKatipNamespace
160+ localKatipNamespace = mapEitherT . localKatipNamespace
144161
145162
146163instance (KatipContext m, Katip (ListT m)) => KatipContext (ListT m) where
147164 getKatipContext = lift getKatipContext
165+ localKatipContext = mapListT . localKatipContext
148166 getKatipNamespace = lift getKatipNamespace
167+ localKatipNamespace = mapListT . localKatipNamespace
149168
150169
151170instance (KatipContext m, Katip (ReaderT r m)) => KatipContext (ReaderT r m) where
152171 getKatipContext = lift getKatipContext
172+ localKatipContext = mapReaderT . localKatipContext
153173 getKatipNamespace = lift getKatipNamespace
174+ localKatipNamespace = mapReaderT . localKatipNamespace
154175
155176
156177instance (KatipContext m, Katip (ResourceT m)) => KatipContext (ResourceT m) where
157178 getKatipContext = lift getKatipContext
179+ localKatipContext = transResourceT . localKatipContext
158180 getKatipNamespace = lift getKatipNamespace
181+ localKatipNamespace = transResourceT . localKatipNamespace
159182
160183
161184instance (KatipContext m, Katip (Strict.StateT s m)) => KatipContext (Strict.StateT s m) where
162185 getKatipContext = lift getKatipContext
186+ localKatipContext = Strict.mapStateT . localKatipContext
163187 getKatipNamespace = lift getKatipNamespace
188+ localKatipNamespace = Strict.mapStateT . localKatipNamespace
164189
165190
166191instance (KatipContext m, Katip (StateT s m)) => KatipContext (StateT s m) where
167192 getKatipContext = lift getKatipContext
193+ localKatipContext = mapStateT . localKatipContext
168194 getKatipNamespace = lift getKatipNamespace
195+ localKatipNamespace = mapStateT . localKatipNamespace
169196
170197
171198instance (KatipContext m, Katip (ExceptT e m)) => KatipContext (ExceptT e m) where
172199 getKatipContext = lift getKatipContext
200+ localKatipContext = mapExceptT . localKatipContext
173201 getKatipNamespace = lift getKatipNamespace
202+ localKatipNamespace = mapExceptT . localKatipNamespace
174203
175204
176205instance (Monoid w, KatipContext m, Katip (Strict.WriterT w m)) => KatipContext (Strict.WriterT w m) where
177206 getKatipContext = lift getKatipContext
207+ localKatipContext = Strict.mapWriterT . localKatipContext
178208 getKatipNamespace = lift getKatipNamespace
209+ localKatipNamespace = Strict.mapWriterT . localKatipNamespace
179210
180211
181212instance (Monoid w, KatipContext m, Katip (WriterT w m)) => KatipContext (WriterT w m) where
182213 getKatipContext = lift getKatipContext
214+ localKatipContext = mapWriterT . localKatipContext
183215 getKatipNamespace = lift getKatipNamespace
216+ localKatipNamespace = mapWriterT . localKatipNamespace
184217
185218
186219instance (Monoid w, KatipContext m, Katip (Strict.RWST r w s m)) => KatipContext (Strict.RWST r w s m) where
187220 getKatipContext = lift getKatipContext
221+ localKatipContext = Strict.mapRWST . localKatipContext
188222 getKatipNamespace = lift getKatipNamespace
223+ localKatipNamespace = Strict.mapRWST . localKatipNamespace
189224
190225
191226instance (Monoid w, KatipContext m, Katip (RWST r w s m)) => KatipContext (RWST r w s m) where
192227 getKatipContext = lift getKatipContext
228+ localKatipContext = mapRWST . localKatipContext
193229 getKatipNamespace = lift getKatipNamespace
230+ localKatipNamespace = mapRWST . localKatipNamespace
194231
195232
196233deriving instance (Monad m, KatipContext m) => KatipContext (KatipT m)
@@ -343,7 +380,9 @@ instance (MonadIO m) => Katip (KatipContextT m) where
343380
344381instance (MonadIO m) => KatipContext (KatipContextT m) where
345382 getKatipContext = KatipContextT $ ReaderT $ \lts -> return (ltsContext lts)
383+ localKatipContext f (KatipContextT m) = KatipContextT $ local (\s -> s { ltsContext = f (ltsContext s)}) m
346384 getKatipNamespace = KatipContextT $ ReaderT $ \lts -> return (ltsNamespace lts)
385+ localKatipNamespace f (KatipContextT m) = KatipContextT $ local (\s -> s { ltsNamespace = f (ltsNamespace s)}) m
347386
348387
349388-------------------------------------------------------------------------------
@@ -358,12 +397,11 @@ runKatipContextT le ctx ns = flip runReaderT lts . unKatipContextT
358397-- monadic action, then restore the previous state
359398-- afterwards.
360399katipAddNamespace
361− :: (Monad m)
400+ :: (KatipContext m)
362401 => Namespace
363− -> KatipContextT m a
364− -> KatipContextT m a
365−katipAddNamespace ns (KatipContextT f) =
366− KatipContextT (local (\r -> r { ltsNamespace = (ltsNamespace r) <> ns}) f)
402+ -> m a
403+ -> m a
404+katipAddNamespace ns = localKatipNamespace (<> ns)
367405
368406
369407-------------------------------------------------------------------------------
@@ -379,13 +417,12 @@ katipAddNamespace ns (KatipContextT f) =
379417-- stored in a sequence and will leak memory.
380418katipAddContext
381419 :: ( LogItem i
382− , Monad m
420+ , KatipContext m
383421 )
384422 => i
385− -> KatipContextT m a
386− -> KatipContextT m a
387−katipAddContext i (KatipContextT f) =
388− KatipContextT (local (\r -> r { ltsContext = (ltsContext r) <> liftPayload i}) f)
423+ -> m a
424+ -> m a
425+katipAddContext i = localKatipContext (<> (liftPayload i))
389426
390427
391428-------------------------------------------------------------------------------