git.iko.soy/typeable/katip
on master help sign in
Bring back more limited LogT
393ee82Michael Xavier
katip/src/Katip.hs+4
compare with master
unifiedsplit
@@ -66,6 +66,10 @@ module Katip
66 -- * Included Scribes
66 -- * Included Scribes
67 , mkHandleScribe
67 , mkHandleScribe
68 , ColorStrategy (..)
68 , ColorStrategy (..)
69+
70+ -- * LogT - Utility transformer that provides Katip and KatipContext instances
71+ , LogT
72+ , runLogT
69 ) where
73 ) where
70
74
71-------------------------------------------------------------------------------
75-------------------------------------------------------------------------------
katip/src/Katip/Monadic.hs+79−6
@@ -28,28 +28,36 @@ module Katip.Monadic
28 , AnyLogContext
28 , AnyLogContext
29 , LogContexts
29 , LogContexts
30 , liftPayload
30 , liftPayload
31+
32+ -- * LogT - Utility transformer that provides Katip and KatipContext instances
33+ , LogT(..)
34+ , runLogT
35+ , LogTState(..)
31 ) where
36 ) where
32
37
33
38
34-------------------------------------------------------------------------------
39-------------------------------------------------------------------------------
40+import Control.Applicative
41+import Control.Monad.Base
35import Control.Monad.Catch
42import Control.Monad.Catch
36−import Control.Monad.Trans.Class
43+import Control.Monad.Error.Class
44+import Control.Monad.IO.Class
45+import Control.Monad.Reader
46+import Control.Monad.State
37import Control.Monad.Trans.Either (EitherT)
47import Control.Monad.Trans.Either (EitherT)
38import Control.Monad.Trans.Except (ExceptT)
48import Control.Monad.Trans.Except (ExceptT)
39import Control.Monad.Trans.Identity (IdentityT)
49import Control.Monad.Trans.Identity (IdentityT)
40import Control.Monad.Trans.List (ListT)
50import Control.Monad.Trans.List (ListT)
41import Control.Monad.Trans.Maybe (MaybeT)
51import Control.Monad.Trans.Maybe (MaybeT)
42−import Control.Monad.Trans.Reader (ReaderT)
43import Control.Monad.Trans.Resource (ResourceT)
52import Control.Monad.Trans.Resource (ResourceT)
44import Control.Monad.Trans.RWS (RWST)
53import Control.Monad.Trans.RWS (RWST)
45import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST)
54import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST)
46−import Control.Monad.Trans.State (StateT)
47import qualified Control.Monad.Trans.State.Strict as Strict (StateT)
55import qualified Control.Monad.Trans.State.Strict as Strict (StateT)
48−import Control.Monad.Trans.Writer (WriterT)
49import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT)
56import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT)
57+import Control.Monad.Writer
50import Data.Aeson
58import Data.Aeson
51import qualified Data.HashMap.Strict as HM
59import qualified Data.HashMap.Strict as HM
52−import Data.Monoid
60+import Data.Monoid as M
53import Data.Text (Text)
61import Data.Text (Text)
54import Language.Haskell.TH
62import Language.Haskell.TH
55-------------------------------------------------------------------------------
63-------------------------------------------------------------------------------
@@ -179,4 +187,69 @@ logExceptionM
179logExceptionM action sev = action `catchAll` \e -> f e >> throwM e
187logExceptionM action sev = action `catchAll` \e -> f e >> throwM e
180 where
188 where
181 f e = logFM sev (msg e)
189 f e = logFM sev (msg e)
182− msg e = ls ("An exception has occured: " :: Text) <> showLS e
190+ msg e = ls ("An exception has occured: " :: Text) M.<> showLS e
191+
192+
193+-------------------------------------------------------------------------------
194+-- | Provides a simple transformer that defines a 'KatipContext'
195+-- instance for a fixed namespace and context. You will typically only
196+-- use this if you are forced to run in IO but still want to have your
197+-- log context. This is the slightly more powerful version of KatipT
198+-- in that it provides KatipContext instead of just Katip. For instance:
199+--
200+-- @
201+-- threadWithLogging = do
202+-- le <- getLogEnv
203+-- ctx <- getKatipContext
204+-- ns <- getKatipNamespace
205+-- forkIO $ runLogT le ctx ns $ do
206+-- $(logTM) InfoS "Look, I can log in IO and retain context!"
207+-- doOtherStuff
208+-- @
209+newtype LogT m a = LogT {
210+ unLogT :: ReaderT LogTState m a
211+ } deriving ( Functor
212+ , Applicative
213+ , Monad
214+ , MonadIO
215+ , MonadThrow
216+ , MonadCatch
217+ , MonadMask
218+ , MonadBase b
219+ , MonadState s
220+ , MonadWriter w
221+ , MonadError e
222+ , MonadPlus
223+ , Alternative
224+ , MonadFix
225+ , MonadTrans
226+ )
227+
228+
229+data LogTState = LogTState {
230+ ltsLogEnv :: !LogEnv
231+ , ltsContext :: !LogContexts
232+ , ltsNamespace :: !Namespace
233+ }
234+
235+-- Reader is a passthrough. We don't expose our internal reader so as not to conflict
236+instance (MonadReader r m) => MonadReader r (LogT m) where
237+ ask = lift ask
238+ local f (LogT (ReaderT m)) = LogT $ ReaderT $ \r ->
239+ local f (m r)
240+
241+
242+instance (MonadIO m) => Katip (LogT m) where
243+ getLogEnv = LogT $ ReaderT $ \lts -> return (ltsLogEnv lts)
244+
245+
246+instance (MonadIO m) => KatipContext (LogT m) where
247+ getKatipContext = LogT $ ReaderT $ \lts -> return (ltsContext lts)
248+ getKatipNamespace = LogT $ ReaderT $ \lts -> return (ltsNamespace lts)
249+
250+
251+-------------------------------------------------------------------------------
252+runLogT :: (LogItem c) => LogEnv -> c -> Namespace -> LogT m a -> m a
253+runLogT le ctx ns = flip runReaderT lts . unLogT
254+ where
255+ lts = LogTState le (liftPayload ctx) ns