logging-effect 1.0.1 → 1.1.0
raw patch · 4 files changed
+246/−34 lines, 4 filesdep ~basedep ~timedep ~transformers
Dependency ranges changed: base, time, transformers
Files
- Benchmark.hs +2/−2
- Changelog.md +34/−3
- logging-effect.cabal +4/−4
- src/Control/Monad/Log.hs +206/−25
Benchmark.hs view
@@ -26,9 +26,9 @@ , bench "monad-logger" (nfIO (MonadLogger.runStdoutLoggingT monadLoggerLog))] , bgroup "log10k-batched-async" [ bench "logging-effect" (nfIO (LoggingEffect.withFDHandler LoggingEffect.defaultBatchingOptions stdout 0.4 80 $ \h ->- LoggingEffect.runLoggingT (nThreads 10 loggingEffectLog)+ LoggingEffect.runLoggingT (nThreads 10 (replicateM_ 10 loggingEffectLog)) (h . LoggingEffect.renderWithSeverity id)))- , bench "monad-logger" (nfIO (MonadLogger.runStdoutLoggingT (nThreads 10 (MonadLogger.logDebugNS "?" "Log message"))))]+ , bench "monad-logger" (nfIO (MonadLogger.runStdoutLoggingT (nThreads 10 (replicateM_ 10 $ MonadLogger.logDebugNS "?" "Log message"))))] , bgroup "map-and-log" [ bench "map-once" (nfIO (LoggingEffect.runLoggingT (LoggingEffect.mapLogMessage id $ LoggingEffect.mapLogMessage id $ LoggingEffect.mapLogMessage id $ LoggingEffect.mapLogMessage id loggingEffectLog) loggingEffectStdoutHandler))] , bgroup "discard-logs" [ bench "logging-effect" (nfIO (LoggingEffect.discardLogging loggingEffectLog)) , bench "monad-logger" (nfIO (MonadLogger.runNoLoggingT monadLoggerLog))]]
Changelog.md view
@@ -1,7 +1,38 @@-# 1.0.1+# 1.1.0 -* Increase upper bound of `async`.+*Breaking changes*: +- `MonadLog` no longer has `logMessage` as a function. It now has+ `logMessageFree` which takes a free monoid of log messages. If you were just+ using `logging-effect` then this won't affect you, as `logMessage` still exists+ with the same signature outside the type class.++- `MonadLog` now comes with a law that states that logging is a monoid+ homomorphism. This essentially means that you have to treat all log messages+ uniformly.++- Pass-through instances for all "stock" monad transformers have been added+ (all of `transformers`, `CatchT` from exceptions and `FreeT`/`FT` from `free`).++- `WithSeverity` now has instances of `Traversable` and `Foldable`++- `WithTimestamp` now has instances of `Eq`, `Ord`, `Read` and `Show`.++*Additions*:++- A set of convenience functions have been added for quickly logging with+ severity. The combinators are: `logDebug`, `logInfo`, `logNotice`,+ `logWarning`, `logError`, `logCritical`, `logAlert` and `logEmergency`.++- `mapLogMessage` got a companion function `mapLogMessageM` that works with + monadic tranformations.++*Other*++- Many documentation bug fixes.++- INLINEABLE pragmas added.+ # 1.0.0 -* Initial release.+- Initial release
logging-effect.cabal view
@@ -1,5 +1,5 @@ name: logging-effect-version: 1.0.1+version: 1.1.0 synopsis: A mtl-style monad transformer for general purpose & compositional logging homepage: https://github.com/ocharles/logging-effect license: BSD3@@ -13,11 +13,11 @@ library exposed-modules: Control.Monad.Log other-extensions: ViewPatterns, OverloadedStrings, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, PatternSynonyms- build-depends: base >=4.8 && <4.9+ build-depends: base >=4.8 && <4.10 , async >=2.0 && <2.2- , transformers >=0.4 && <0.5+ , transformers >=0.4 && <0.6 , text >=1.2 && <1.3- , time >=1.5 && <1.6+ , time >=1.5 && <1.7 , mtl >= 2.2.1 && <2.3 , exceptions >= 0.8.0.2 && <0.9 , free >= 4.12.1 && < 4.13
src/Control/Monad/Log.hs view
@@ -1,12 +1,14 @@-{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE AutoDeriveTypeable #-}-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}@@ -34,8 +36,13 @@ -- $tutorial-composing -- * @MonadLog@- MonadLog(..), mapLogMessage,+ logMessage, mapLogMessage, mapLogMessageM,+ MonadLog(..), + -- * Convenience logging combinators+ -- $convenience+ logDebug, logInfo, logNotice, logWarning, logError, logCritical, logAlert, logEmergency,+ -- * Message transformers PP.renderPretty, -- ** Timestamps@@ -60,10 +67,11 @@ -- * Discarding logs DiscardLoggingT(DiscardLoggingT,discardLogging) - -- * Aside: A @mtl@ refresher+ -- * Aside: An @mtl@ refresher -- $tutorialMtl ) where +import Prelude hiding (foldMap) import Control.Applicative import Control.Concurrent.Async (async, wait) import Control.Concurrent.STM@@ -86,18 +94,64 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Monoid import Data.Time (UTCTime, getCurrentTime)+#if !MIN_VERSION_base(4, 9, 0) import GHC.SrcLoc (SrcLoc, showSrcLoc) import GHC.Stack+#else+import GHC.Stack (SrcLoc, CallStack, getCallStack, prettySrcLoc)+#endif import System.IO (Handle) import qualified Data.Text.Lazy as LT import qualified Text.PrettyPrint.Leijen.Text as PP +-- For 'MonadLog' pass-through instances.+import qualified Control.Monad.Trans.Identity as Identity+import qualified Control.Monad.Trans.Reader as Reader+import qualified Control.Monad.Trans.State.Lazy as LazyState+import qualified Control.Monad.Trans.State.Strict as StrictState+import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter+import qualified Control.Monad.Trans.Writer.Strict as StrictWriter+import qualified Control.Monad.Trans.Maybe as Maybe+import qualified Control.Monad.Trans.Except as Except+import qualified Control.Monad.Trans.Error as Error+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS+import qualified Control.Monad.Trans.Cont as Cont+import qualified Control.Monad.Trans.List as List+import qualified Control.Monad.Trans.Free as Free+import qualified Control.Monad.Trans.Free.Church as Free+import qualified Control.Monad.Catch.Pure as Exceptions+ -------------------------------------------------------------------------------- -- | The class of monads that support logging.+--+-- Laws:+--+-- /Monoid homomorphism/:+--+-- @+-- 'logMessageFree' a '*>' 'logMessageFree' b = 'logMessageFree' (a '<>' b)+-- @ class Monad m => MonadLog message m | m -> message where- -- | Append a message to the log for this computation.- logMessage :: message -> m ()+ -- | Fold log messages into this computation. Looking to just log a+ -- message? You probably want 'logMessage'.+ --+ -- The perhaps strange type here allows us to construct a monoid out of /any/+ -- type of log message. You can think of this as the simpler type:+ --+ -- @+ -- logMessageFree :: [message] -> m ()+ -- @+ logMessageFree :: (forall n. Monoid n => (message -> n) -> n) -> m ()+ default logMessageFree :: (m ~ t n, MonadTrans t, MonadLog message n) => (forall mon. Monoid mon => (message -> mon) -> mon) -> m ()+ logMessageFree inj = lift (logMessageFree inj)+ {-# INLINEABLE logMessageFree #-} +-- | Append a message to the log for this computation.+logMessage :: MonadLog message m => message -> m ()+logMessage m = logMessageFree (\inject -> inject m)+{-# INLINEABLE logMessage #-}+ -- | Re-interpret the log messages in one computation. This can be useful to -- embed a computation with one log type in a larger general computation. mapLogMessage@@ -106,7 +160,35 @@ mapLogMessage f m = runLoggingT m (logMessage . f)+{-# INLINEABLE mapLogMessage #-} +-- | Monadic version of 'mapLogMessage'. This can be used to annotate a+-- message with something that can only be computed in a monad. See e.g.+-- 'timestamp'.+mapLogMessageM+ :: MonadLog message' m+ => (message -> m message') -> LoggingT message m a -> m a+mapLogMessageM f m =+ runLoggingT m ((>>= logMessage) . f)+{-# INLINEABLE mapLogMessageM #-}++instance MonadLog message m => MonadLog message (Identity.IdentityT m)+instance MonadLog message m => MonadLog message (Reader.ReaderT r m)+instance MonadLog message m => MonadLog message (StrictState.StateT s m)+instance MonadLog message m => MonadLog message (LazyState.StateT s m)+instance (Monoid w, MonadLog message m) => MonadLog message (StrictWriter.WriterT w m)+instance (Monoid w, MonadLog message m) => MonadLog message (LazyWriter.WriterT w m)+instance MonadLog message m => MonadLog message (Maybe.MaybeT m)+instance MonadLog message m => MonadLog message (Except.ExceptT e m)+instance (Error.Error e, MonadLog message m) => MonadLog message (Error.ErrorT e m)+instance (Monoid w, MonadLog message m) => MonadLog message (StrictRWS.RWST r w s m)+instance (Monoid w, MonadLog message m) => MonadLog message (LazyRWS.RWST r w s m)+instance MonadLog message m => MonadLog message (Cont.ContT r m)+instance MonadLog message m => MonadLog message (List.ListT m)+instance (Functor f, MonadLog message m) => MonadLog message (Free.FreeT f m)+instance (Functor f, MonadLog message m) => MonadLog message (Free.FT f m)+instance MonadLog message m => MonadLog message (Exceptions.CatchT m)+ -------------------------------------------------------------------------------- -- | Add \"Severity\" information to a log message. This is often used to convey -- how significant a log message is.@@ -114,7 +196,7 @@ WithSeverity {msgSeverity :: Severity -- ^ Retrieve the 'Severity' a message. ,discardSeverity :: a -- ^ View the underlying message. }- deriving (Eq,Ord,Read,Show,Functor)+ deriving (Eq,Ord,Read,Show,Functor,Traversable,Foldable) -- | Classes of severity for log messages. These have been chosen to match -- @syslog@ severity levels@@ -132,16 +214,72 @@ instance PP.Pretty Severity where pretty = PP.text . LT.pack . show --- | Given a way to render the underlying message @a@ render a message with its--- timestamp.+-- | Given a way to render the underlying message @a@, render a message with its+-- severity. ----- >>> renderWithSeverity id Debug (WithSeverity Info "Flux capacitor is functional")--- [Info] Flux capacitor is functional+-- >>> renderWithSeverity id (WithSeverity Informational "Flux capacitor is functional")+-- [Informational] Flux capacitor is functional renderWithSeverity :: (a -> PP.Doc) -> (WithSeverity a -> PP.Doc) renderWithSeverity k (WithSeverity u a) = PP.brackets (PP.pretty u) PP.<+> PP.align (k a) +-- | @+-- 'logDebug' = 'logMessage' . 'WithSeverity' 'Debug'+-- @+logDebug :: MonadLog (WithSeverity a) m => a -> m ()+logDebug = logMessage . WithSeverity Debug+{-# INLINEABLE logDebug #-}++-- | @+-- 'logInfo' = 'logMessage' . 'WithSeverity' 'Informational'+-- @+logInfo :: MonadLog (WithSeverity a) m => a -> m ()+logInfo = logMessage . WithSeverity Informational+{-# INLINEABLE logInfo #-}++-- | @+-- 'logNotice' = 'logMessage' . 'WithSeverity' 'Notice'+-- @+logNotice :: MonadLog (WithSeverity a) m => a -> m ()+logNotice = logMessage . WithSeverity Notice+{-# INLINEABLE logNotice #-}++-- | @+-- 'logWarning' = 'logMessage' . 'WithSeverity' 'Warning'+-- @+logWarning :: MonadLog (WithSeverity a) m => a -> m ()+logWarning = logMessage . WithSeverity Warning+{-# INLINEABLE logWarning #-}++-- | @+-- 'logError' = 'logMessage' . 'WithSeverity' 'Error'+-- @+logError :: MonadLog (WithSeverity a) m => a -> m ()+logError = logMessage . WithSeverity Error+{-# INLINEABLE logError #-}++-- | @+-- 'logCritical' = 'logMessage' . 'WithSeverity' 'Critical'+-- @+logCritical :: MonadLog (WithSeverity a) m => a -> m ()+logCritical = logMessage . WithSeverity Critical+{-# INLINEABLE logCritical #-}++-- | @+-- 'logAlert' = 'logMessage' . 'WithSeverity' 'Alert'+-- @+logAlert :: MonadLog (WithSeverity a) m => a -> m ()+logAlert = logMessage . WithSeverity Alert+{-# INLINEABLE logAlert #-}++-- | @+-- 'logEmergency' = 'logMessage' . 'WithSeverity' 'Emergency'+-- @+logEmergency :: MonadLog (WithSeverity a) m => a -> m ()+logEmergency = logMessage . WithSeverity Emergency+{-# INLINEABLE logEmergency #-}+ -------------------------------------------------------------------------------- -- | Add a timestamp to log messages. --@@ -154,10 +292,10 @@ -- it's best to avoid incurring this constraint as much as possible, as it is -- generally untestable. data WithTimestamp a =- WithTimestamp {discardTimestamp :: a -- ^ Retireve the time a message was logged.- ,msgTimestamp :: UTCTime -- ^ View the underlying message.+ WithTimestamp {discardTimestamp :: a -- ^ View the underlying message.+ ,msgTimestamp :: UTCTime -- ^ Retireve the time a message was logged. }- deriving (Functor,Traversable,Foldable)+ deriving (Eq,Ord,Read,Show,Functor,Traversable,Foldable) -- | Given a way to render the underlying message @a@ and a way to format -- 'UTCTime', render a message with its timestamp.@@ -177,6 +315,7 @@ timestamp msg = do now <- liftIO getCurrentTime pure (WithTimestamp msg now)+{-# INLINEABLE timestamp #-} -------------------------------------------------------------------------------- -- | Add call stack information to log lines.@@ -185,7 +324,7 @@ -- parameters. For more information, see the GHC manual (section 9.14.4.5). data WithCallStack a = WithCallStack { msgCallStack :: CallStack , discardCallStack :: a }- deriving (Functor,Traversable,Foldable,Show,Eq)+ deriving (Functor,Traversable,Foldable,Show) -- | Given a way to render the underlying message @a@ render a message with a -- callstack.@@ -195,6 +334,11 @@ renderWithCallStack k (WithCallStack stack msg) = k msg PP.<$> PP.indent 2 (prettyCallStack (getCallStack stack)) +#if MIN_VERSION_base(4, 9, 0)+showSrcLoc :: SrcLoc -> String+showSrcLoc = prettySrcLoc+#endif+ prettyCallStack :: [(String,SrcLoc)] -> PP.Doc prettyCallStack [] = "empty callstack" prettyCallStack (root:rest) =@@ -239,18 +383,32 @@ runLoggingT :: LoggingT message m a -> Handler m message -> m a runLoggingT (LoggingT (ReaderT m)) handler = m handler+{-# INLINEABLE runLoggingT #-} instance MonadTrans (LoggingT message) where lift = LoggingT . ReaderT . const+ {-# INLINEABLE lift #-} instance MonadReader r m => MonadReader r (LoggingT message m) where ask = lift ask+ {-# INLINEABLE ask #-} local f (LoggingT (ReaderT m)) = LoggingT (ReaderT (local f . m))+ {-# INLINEABLE local #-} reader f = lift (reader f)+ {-# INLINEABLE reader #-} +newtype Ap m = Ap { runAp :: m () }++instance Applicative m => Monoid (Ap m) where+ mempty = Ap (pure ())+ {-# INLINEABLE mempty #-}+ Ap l `mappend` Ap r = Ap (l *> r)+ {-# INLINEABLE mappend #-}+ -- | The main instance of 'MonadLog', which replaces calls to 'logMessage' with calls to a 'Handler'. instance Monad m => MonadLog message (LoggingT message m) where- logMessage m = LoggingT (ReaderT (\f -> f m))+ logMessageFree foldMap = LoggingT (ReaderT (\handler -> runAp (foldMap (Ap . handler))))+ {-# INLINEABLE logMessageFree #-} instance MonadRWS r w s m => MonadRWS r w s (LoggingT message m) @@ -265,6 +423,7 @@ -> LoggingT message m a -> LoggingT message' n a mapLoggingT eta (LoggingT (ReaderT f)) = LoggingT (ReaderT (eta f))+{-# INLINEABLE mapLoggingT #-} -------------------------------------------------------------------------------- -- | Handlers are mechanisms to interpret the meaning of logging as an action@@ -352,7 +511,10 @@ -- | 'withFDHandler' creates a new 'Handler' that will append a given file -- descriptor (or 'Handle', as it is known in the "base" library). Note that--- this 'Handler' requires log messages to be of type 'Text'.+-- this 'Handler' requires log messages to be of type 'PP.Doc'. This abstractly+-- specifies a pretty-printing for log lines. The two arguments two+-- 'withFDHandler' determine how this pretty-printing should be realised+-- when outputting log lines. -- -- These 'Handler's asynchronously log messages to the given file descriptor, -- rather than blocking.@@ -393,6 +555,7 @@ :: Monoid log => PureLoggingT log m a -> m (a,log) runPureLoggingT (MkPureLoggingT (StateT m)) = m mempty+{-# INLINEABLE runPureLoggingT #-} mkPureLoggingT :: (Monad m,Monoid log)@@ -402,22 +565,28 @@ (StateT (\s -> do (a,l) <- m return (a,s <> l)))+{-# INLINEABLE mkPureLoggingT #-} instance MonadTrans (PureLoggingT log) where lift = MkPureLoggingT . lift+ {-# INLINEABLE lift #-} instance (Functor f, MonadFree f m) => MonadFree f (PureLoggingT log m) -- | A pure handler of 'MonadLog' that accumulates log messages under the structure of their 'Monoid' instance. instance (Monad m, Monoid log) => MonadLog log (PureLoggingT log m) where- logMessage message = mkPureLoggingT (return ((), message))+ logMessageFree foldMap = mkPureLoggingT (return ((), foldMap id))+ {-# INLINEABLE logMessageFree #-} instance MonadRWS r w s m => MonadRWS r w s (PureLoggingT message m) instance MonadState s m => MonadState s (PureLoggingT log m) where state f = lift (state f)+ {-# INLINEABLE state #-} get = lift get+ {-# INLINEABLE get #-} put = lift . put+ {-# INLINEABLE put #-} -------------------------------------------------------------------------------- -- | A 'MonadLog' handler that throws messages away.@@ -440,12 +609,14 @@ instance MonadTrans (DiscardLoggingT message) where lift = DiscardLoggingT+ {-# INLINEABLE lift #-} instance (Functor f,MonadFree f m) => MonadFree f (DiscardLoggingT message m) -- | The trivial instance of 'MonadLog' that simply discards all messages logged. instance Monad m => MonadLog message (DiscardLoggingT message m) where- logMessage _ = return ()+ logMessageFree _ = return ()+ {-# INLINEABLE logMessageFree #-} {- $intro @@ -472,7 +643,7 @@ the @mtl@, this approach uses type classes to keep the choice of monad polymorphic as you program, and you later choose a specific monad transformer stack when you execute your program. For more information, see-<#tutorialMtl Aside: A mtl refresher>.+<#tutorialMtl Aside: An mtl refresher>. -} @@ -548,8 +719,8 @@ First, use the 'MonadLog' type class to indicate that a computation has access to logging. 'MonadLog' is parameterized on the type of messages-that you intend to log. In this example, we will log 'Text' that is-wrapped in the 'WithSeverity'.+that you intend to log. In this example, we will log a 'PP.Doc' that is+wrapped in 'WithSeverity'. @ testApp :: 'MonadLog' ('WithSeverity' 'PP.Doc') m => m ()@@ -606,7 +777,7 @@ @ main :: 'IO' () main =- 'withFDHandler' 'defaultBatchingOptions' 'stdout' 0.4 80 $ \logToStdout ->+ 'withFDHandler' 'defaultBatchingOptions' 'stdout' 0.4 80 $ \\logToStdout -> 'runLoggingT' testApp ('logToStdout' . 'renderWithSeverity' 'id') @ @@ -620,8 +791,8 @@ @ main :: IO () main = do- 'withFDHandler' 'defaultBatchingOptions' 'stderr' 0.4 80 $ \stderrHandler ->- 'withFDHandler' 'defaultBatchingOptions' 'stdout' 0.4 80 $ \stdoutHandler ->+ 'withFDHandler' 'defaultBatchingOptions' 'stderr' 0.4 80 $ \\stderrHandler ->+ 'withFDHandler' 'defaultBatchingOptions' 'stdout' 0.4 80 $ \\stdoutHandler -> 'runLoggingT' m (\\message -> case 'msgSeverity' message of@@ -676,5 +847,15 @@ applications you will probably want to define a new sum-type that combines all of your log messages, and generally sticking with a single log message type per application.++-}++{- $convenience++While @logging-effect@ tries to be as general as possible, there is a fairly+common case of logging, namely basic messages with an indication of severity.+These combinators assume that you will be using 'WithSeverity' at the outer-most+level of your log message stack, though no make no assumptions at what is inside+your log messages. There is a @logX@ combinator for each level in 'Severity'. -}