monad-logger 0.3.26 → 0.3.28
raw patch · 3 files changed
+113/−107 lines, 3 filesdep ~basedep ~bytestringdep ~conduit
Dependency ranges changed: base, bytestring, conduit, conduit-extra, exceptions, fast-logger, monad-control, resourcet, transformers
Files
- ChangeLog.md +8/−0
- Control/Monad/Logger.hs +97/−99
- monad-logger.cabal +8/−8
ChangeLog.md view
@@ -1,3 +1,11 @@+## 0.3.28++* Added `WriterLoggingT` for collecting log lines and help with testing++## 0.3.27++* Drop backwards compat with older library versions+ ## 0.3.26 * Add `MonadUnliftIO` instances
Control/Monad/Logger.hs view
@@ -13,12 +13,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TupleSections #-} -- | This module provides the facilities needed for a decoupled logging system. -- -- The 'MonadLogger' class is implemented by monads that give access to a -- logging facility. If you're defining a custom monad, then you may define an -- instance of 'MonadLogger' that routes the log messages to the appropriate--- place (e.g., that's what @yesod-core@'s @GHandler@ does). Otherwise, you+-- place (e.g., that's what @yesod-core@'s @HandlerT@ does). Otherwise, you -- may use the 'LoggingT' monad included in this module (see -- 'runStderrLoggingT'). To simply discard log message, use 'NoLoggingT'. --@@ -35,7 +36,7 @@ -- * Re-export from fast-logger , LogStr , ToLogStr(..)- -- * Helper transformer+ -- * Helper transformers , LoggingT (..) , runStderrLoggingT , runStdoutLoggingT@@ -45,6 +46,9 @@ , withChannelLogger , filterLogger , NoLoggingT (..)+ , WriterLoggingT (..)+ , execWriterLoggingT+ , runWriterLoggingT #if WITH_TEMPLATE_HASKELL -- * TH logging , logDebug@@ -106,22 +110,15 @@ import Control.Concurrent.STM.TBChan import Control.Exception.Lifted (onException, bracket) import Control.Monad (liftM, ap, when, void, forever)-import Control.Monad.Base (MonadBase (liftBase))+import Control.Monad.Base (MonadBase (liftBase), liftBaseDefault) import Control.Monad.IO.Unlift import Control.Monad.Loops (untilM)-import Control.Monad.Trans.Control (MonadBaseControl (..), MonadTransControl (..))+import Control.Monad.Trans.Control (MonadBaseControl (..), MonadTransControl (..), ComposeSt, defaultLiftBaseWith, defaultRestoreM) import qualified Control.Monad.Trans.Class as Trans import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad.Trans.Resource (MonadResource (liftResourceT), MonadThrow, monadThrow)-#if MIN_VERSION_resourcet(1,1,0)-import Control.Monad.Trans.Resource (throwM)-import Control.Monad.Catch (MonadCatch (..)-#if MIN_VERSION_exceptions(0,6,0)- , MonadMask (..)-#endif- )-#endif+import Control.Monad.Trans.Resource (MonadResource (liftResourceT))+import Control.Monad.Catch (MonadThrow (..), MonadCatch (..), MonadMask (..)) import Control.Monad.Trans.Identity ( IdentityT) import Control.Monad.Trans.List ( ListT )@@ -162,18 +159,7 @@ import Prelude hiding (catch) -#if MIN_VERSION_fast_logger(2, 1, 0)--- Using System.Log.FastLogger-#elif MIN_VERSION_bytestring(0, 10, 2)-import qualified Data.ByteString.Lazy as L-import Data.ByteString.Builder (toLazyByteString)-#else-import Blaze.ByteString.Builder (toByteString)-#endif--#if MIN_VERSION_conduit_extra(1,1,0) import Data.Conduit.Lazy (MonadActive, monadActive)-#endif data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text deriving (Eq, Prelude.Show, Prelude.Read, Ord)@@ -394,32 +380,23 @@ instance MonadIO m => MonadIO (NoLoggingT m) where liftIO = Trans.lift . liftIO -#if MIN_VERSION_resourcet(1,1,0) instance MonadThrow m => MonadThrow (NoLoggingT m) where throwM = Trans.lift . throwM instance MonadCatch m => MonadCatch (NoLoggingT m) where catch (NoLoggingT m) c = NoLoggingT $ m `catch` \e -> runNoLoggingT (c e)-#if MIN_VERSION_exceptions(0,6,0) instance MonadMask m => MonadMask (NoLoggingT m) where-#endif mask a = NoLoggingT $ mask $ \u -> runNoLoggingT (a $ q u) where q u (NoLoggingT b) = NoLoggingT $ u b uninterruptibleMask a = NoLoggingT $ uninterruptibleMask $ \u -> runNoLoggingT (a $ q u) where q u (NoLoggingT b) = NoLoggingT $ u b-#else-instance MonadThrow m => MonadThrow (NoLoggingT m) where- monadThrow = Trans.lift . monadThrow-#endif -#if MIN_VERSION_conduit_extra(1,1,0) instance MonadActive m => MonadActive (NoLoggingT m) where monadActive = Trans.lift monadActive instance MonadActive m => MonadActive (LoggingT m) where monadActive = Trans.lift monadActive-#endif instance MonadResource m => MonadResource (NoLoggingT m) where liftResourceT = Trans.lift . liftResourceT@@ -431,32 +408,18 @@ lift = NoLoggingT instance MonadTransControl NoLoggingT where-#if MIN_VERSION_monad_control(1,0,0) type StT NoLoggingT a = a liftWith f = NoLoggingT $ f runNoLoggingT restoreT = NoLoggingT-#else- newtype StT NoLoggingT a = StIdent {unStIdent :: a}- liftWith f = NoLoggingT $ f $ \(NoLoggingT t) -> liftM StIdent t- restoreT = NoLoggingT . liftM unStIdent-#endif {-# INLINE liftWith #-} {-# INLINE restoreT #-} instance MonadBaseControl b m => MonadBaseControl b (NoLoggingT m) where-#if MIN_VERSION_monad_control(1,0,0) type StM (NoLoggingT m) a = StM m a liftBaseWith f = NoLoggingT $ liftBaseWith $ \runInBase -> f $ runInBase . runNoLoggingT restoreM = NoLoggingT . restoreM-#else- newtype StM (NoLoggingT m) a = StMT' (StM m a)- liftBaseWith f = NoLoggingT $- liftBaseWith $ \runInBase ->- f $ liftM StMT' . runInBase . (\(NoLoggingT r) -> r)- restoreM (StMT' base) = NoLoggingT $ restoreM base-#endif instance Monad m => MonadLogger (NoLoggingT m) where monadLoggerLog _ _ _ _ = return ()@@ -469,6 +432,91 @@ withUnliftIO $ \u -> return (UnliftIO (unliftIO u . runNoLoggingT)) +-- | @since 0.3.28+type LogLine = (Loc, LogSource, LogLevel, LogStr)++-- | @since 0.3.28+newtype WriterLoggingT m a = WriterLoggingT { unWriterLoggingT :: m (a, DList LogLine) }++-- | Simple implementation of a difference list to support WriterLoggingT+newtype DList a = DList { unDList :: [a] -> [a] }++emptyDList :: DList a+emptyDList = DList id++singleton :: a -> DList a+singleton = DList . (:)++dListToList :: DList a -> [a]+dListToList (DList dl) = dl []++appendDList :: DList a -> DList a -> DList a+appendDList dl1 dl2 = DList (unDList dl1 . unDList dl2)++-- | Run a block using a @MonadLogger@ instance. Return a value and logs in a list+-- | @since 0.3.28+runWriterLoggingT :: Functor m => WriterLoggingT m a -> m (a, [LogLine])+runWriterLoggingT (WriterLoggingT ma) = fmap dListToList <$> ma++-- | Run a block using a @MonadLogger@ instance. Return logs in a list+-- | @since 0.3.28+execWriterLoggingT :: Functor m => WriterLoggingT m a -> m [LogLine]+execWriterLoggingT ma = snd <$> runWriterLoggingT ma++instance Monad m => Monad (WriterLoggingT m) where+ return = pure+ (WriterLoggingT ma) >>= f = WriterLoggingT $ do+ (a, msgs) <- ma+ (a', msgs') <- unWriterLoggingT $ f a+ pure (a', appendDList msgs msgs')++instance Applicative m => Applicative (WriterLoggingT m) where+ pure a = WriterLoggingT . pure $ (a, emptyDList)+ WriterLoggingT mf <*> WriterLoggingT ma = WriterLoggingT $+ fmap (\((f, msgs), (a, msgs')) -> (f a, appendDList msgs msgs')) ((,) <$> mf <*> ma)++instance Functor m => Functor (WriterLoggingT m) where+ fmap f (WriterLoggingT ma) = WriterLoggingT $+ fmap (\(a, msgs) -> (f a, msgs)) ma++instance Monad m => MonadLogger (WriterLoggingT m) where+ monadLoggerLog loc source level msg = WriterLoggingT . pure $ ((), singleton (loc, source, level, toLogStr msg))+++instance Trans.MonadTrans WriterLoggingT where+ lift ma = WriterLoggingT $ (, emptyDList) <$> ma++instance MonadIO m => MonadIO (WriterLoggingT m) where+ liftIO ioa = WriterLoggingT $ (, emptyDList) <$> liftIO ioa++instance MonadBase b m => MonadBase b (WriterLoggingT m) where+ liftBase = liftBaseDefault++instance MonadTransControl WriterLoggingT where+ type StT WriterLoggingT a = (a, DList LogLine)+ liftWith f = WriterLoggingT $ fmap (\x -> (x, emptyDList))+ (f $ unWriterLoggingT)+ restoreT = WriterLoggingT++instance MonadBaseControl b m => MonadBaseControl b (WriterLoggingT m) where+ type StM (WriterLoggingT m) a = ComposeSt WriterLoggingT m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM++instance MonadThrow m => MonadThrow (WriterLoggingT m) where+ throwM = Trans.lift . throwM++instance MonadCatch m => MonadCatch (WriterLoggingT m) where+ catch (WriterLoggingT m) c =+ WriterLoggingT $ m `catch` \e -> unWriterLoggingT (c e)++instance MonadMask m => MonadMask (WriterLoggingT m) where+ mask a = WriterLoggingT $ (mask $ \ u -> unWriterLoggingT (a $ q u))+ where q u b = WriterLoggingT $ u (unWriterLoggingT b)++ uninterruptibleMask a = WriterLoggingT $ uninterruptibleMask $ \u -> unWriterLoggingT (a $ q u)+ where q u b = WriterLoggingT $ u (unWriterLoggingT b)+ -- | Monad transformer that adds a new logging function. -- -- @since 0.2.2@@ -505,24 +553,17 @@ instance MonadIO m => MonadIO (LoggingT m) where liftIO = Trans.lift . liftIO -#if MIN_VERSION_resourcet(1,1,0) instance MonadThrow m => MonadThrow (LoggingT m) where throwM = Trans.lift . throwM instance MonadCatch m => MonadCatch (LoggingT m) where catch (LoggingT m) c = LoggingT $ \r -> m r `catch` \e -> runLoggingT (c e) r-#if MIN_VERSION_exceptions(0,6,0) instance MonadMask m => MonadMask (LoggingT m) where-#endif mask a = LoggingT $ \e -> mask $ \u -> runLoggingT (a $ q u) e where q u (LoggingT b) = LoggingT (u . b) uninterruptibleMask a = LoggingT $ \e -> uninterruptibleMask $ \u -> runLoggingT (a $ q u) e where q u (LoggingT b) = LoggingT (u . b)-#else-instance MonadThrow m => MonadThrow (LoggingT m) where- monadThrow = Trans.lift . monadThrow-#endif instance MonadResource m => MonadResource (LoggingT m) where liftResourceT = Trans.lift . liftResourceT@@ -534,32 +575,18 @@ lift = LoggingT . const instance MonadTransControl LoggingT where-#if MIN_VERSION_monad_control(1,0,0) type StT LoggingT a = a liftWith f = LoggingT $ \r -> f $ \(LoggingT t) -> t r restoreT = LoggingT . const-#else- newtype StT LoggingT a = StReader {unStReader :: a}- liftWith f = LoggingT $ \r -> f $ \(LoggingT t) -> liftM StReader $ t r- restoreT = LoggingT . const . liftM unStReader-#endif {-# INLINE liftWith #-} {-# INLINE restoreT #-} instance MonadBaseControl b m => MonadBaseControl b (LoggingT m) where-#if MIN_VERSION_monad_control(1,0,0) type StM (LoggingT m) a = StM m a liftBaseWith f = LoggingT $ \reader' -> liftBaseWith $ \runInBase -> f $ runInBase . (\(LoggingT r) -> r reader') restoreM = LoggingT . const . restoreM-#else- newtype StM (LoggingT m) a = StMT (StM m a)- liftBaseWith f = LoggingT $ \reader' ->- liftBaseWith $ \runInBase ->- f $ liftM StMT . runInBase . (\(LoggingT r) -> r reader')- restoreM (StMT base) = LoggingT $ const $ restoreM base-#endif instance MonadIO m => MonadLogger (LoggingT m) where monadLoggerLog a b c d = LoggingT $ \f -> liftIO $ f a b c (toLogStr d)@@ -590,13 +617,7 @@ defaultLogStrBS a b c d = toBS $ defaultLogStr a b c d where-#if MIN_VERSION_fast_logger(2, 1, 0) toBS = fromLogStr-#elif MIN_VERSION_bytestring(0, 10, 2)- toBS = L.toStrict . toLazyByteString . logStrBuilder-#else- toBS = toByteString . logStrBuilder-#endif defaultLogLevelStr :: LogLevel -> LogStr defaultLogLevelStr level = case level of@@ -607,13 +628,8 @@ -> LogSource -> LogLevel -> LogStr-#if MIN_VERSION_fast_logger(0, 2, 0) -> LogStr-#else- -> S8.ByteString-#endif defaultLogStr loc src level msg =-#if MIN_VERSION_fast_logger(0, 2, 0) "[" `mappend` defaultLogLevelStr level `mappend` (if T.null src then mempty@@ -626,24 +642,6 @@ " @(" `mappend` toLogStr (S8.pack fileLocStr) `mappend` ")\n")-#else- S8.concat- [ S8.pack "["- , case level of- LevelOther t -> encodeUtf8 t- _ -> encodeUtf8 $ pack $ drop 5 $ show level- , if T.null src- then S8.empty- else encodeUtf8 $ '#' `T.cons` src- , S8.pack "] "- , case msg of- LS s -> encodeUtf8 $ pack s- LB b -> b- , S8.pack " @("- , encodeUtf8 $ pack fileLocStr- , S8.pack ")\n"- ]-#endif where -- taken from file-location package -- turn the TH Loc loaction information into a human readable string@@ -694,7 +692,7 @@ -- or a custom extraction funtion, and written to a destination. -- -- @since 0.3.17-runChanLoggingT :: MonadIO m => Chan (Loc, LogSource, LogLevel, LogStr) -> LoggingT m a -> m a+runChanLoggingT :: MonadIO m => Chan LogLine -> LoggingT m a -> m a runChanLoggingT chan = (`runLoggingT` sink chan) where sink chan loc src lvl msg = writeChan chan (loc,src,lvl,msg)@@ -705,7 +703,7 @@ -- For use in a dedicated thread with a channel fed by `runChanLoggingT`. -- -- @since 0.3.17-unChanLoggingT :: (MonadLogger m, MonadIO m) => Chan (Loc, LogSource, LogLevel, LogStr) -> m void+unChanLoggingT :: (MonadLogger m, MonadIO m) => Chan LogLine -> m void unChanLoggingT chan = forever $ do (loc,src,lvl,msg) <- liftIO $ readChan chan monadLoggerLog loc src lvl msg
monad-logger.cabal view
@@ -1,5 +1,5 @@ name: monad-logger-version: 0.3.26+version: 0.3.28 synopsis: A class of monads which can log messages. description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/monad-logger>. homepage: https://github.com/kazu-yamamoto/logger@@ -33,17 +33,17 @@ , stm , stm-chans , lifted-base- , resourcet >= 0.4 && < 1.2- , conduit >= 1.0 && < 1.3- , conduit-extra >= 1.0 && < 1.3- , fast-logger >= 2.0 && < 2.5+ , resourcet >= 1.1 && < 1.3+ , conduit >= 1.0 && < 1.4+ , conduit-extra >= 1.1 && < 1.4+ , fast-logger >= 2.1 && < 2.5 , transformers-base- , monad-control+ , monad-control >= 1.0 , monad-loops , mtl- , bytestring+ , bytestring >= 0.10.2 , blaze-builder- , exceptions+ , exceptions >= 0.6 , unliftio-core if impl(ghc >= 8.0.1)