logging-effect (empty) → 1.0.0
raw patch · 5 files changed
+794/−0 lines, 5 filesdep +asyncdep +basedep +bytestringsetup-changed
Dependencies added: async, base, bytestring, criterion, exceptions, fast-logger, free, lifted-async, logging-effect, monad-control, monad-logger, mtl, stm, stm-delay, text, time, transformers, transformers-base, wl-pprint-text
Files
- Benchmark.hs +46/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- logging-effect.cabal +36/−0
- src/Control/Monad/Log.hs +680/−0
+ Benchmark.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Monad (replicateM_)+import Criterion.Main+import qualified Control.Monad.Log as LoggingEffect+import qualified Control.Monad.Logger as MonadLogger+import qualified Data.ByteString as BS+import System.Log.FastLogger (fromLogStr, toLogStr)+import Data.Monoid ((<>))+import qualified Data.Text.IO as T+import qualified Text.PrettyPrint.Leijen.Text as PP+import System.IO (stdout)+import Control.Concurrent.Async.Lifted+import Data.Foldable (sequenceA_)+import Data.Time++main :: IO ()+main = defaultMain [ bgroup "log10k" [ bench "logging-effect" (nfIO (LoggingEffect.runLoggingT loggingEffectLog loggingEffectStdoutHandler))+ , bench "monad-logger" (nfIO (MonadLogger.runLoggingT monadLoggerLog monadLoggerStdoutHandler))]+ , bgroup "log10k-batched"+ [ bench "logging-effect" (nfIO (LoggingEffect.withFDHandler LoggingEffect.defaultBatchingOptions stdout 0.4 80 $ \h ->+ LoggingEffect.runLoggingT loggingEffectLog+ (h . LoggingEffect.renderWithSeverity id)))+ , 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)+ (h . LoggingEffect.renderWithSeverity id)))+ , bench "monad-logger" (nfIO (MonadLogger.runStdoutLoggingT (nThreads 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))]]++loggingEffectStdoutHandler = PP.putDoc . (<> PP.linebreak) . LoggingEffect.renderWithSeverity id++loggingEffectLog :: LoggingEffect.MonadLog (LoggingEffect.WithSeverity PP.Doc) m => m ()+loggingEffectLog = LoggingEffect.logMessage (LoggingEffect.WithSeverity LoggingEffect.Debug "Log message")++monadLoggerLog :: MonadLogger.MonadLogger m => m ()+monadLoggerLog = MonadLogger.logDebugNS "?" "Log message"++monadLoggerStdoutHandler = \_ _ level str -> BS.putStrLn (fromLogStr (toLogStr (show level) <> str))++nThreads n m = runConcurrently (sequenceA_ (replicate n (Concurrently m)))
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Ollie Charles++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Ollie Charles nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ logging-effect.cabal view
@@ -0,0 +1,36 @@+name: logging-effect+version: 1.0.0+synopsis: A mtl-style monad transformer for general purpose & compositional logging+homepage: https://github.com/ocharles/logging-effect+license: BSD3+license-file: LICENSE+author: Ollie Charles+maintainer: ollie@ocharles.org.uk+build-type: Simple+cabal-version: >=1.10++library+ exposed-modules: Control.Monad.Log+ other-extensions: ViewPatterns, OverloadedStrings, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, PatternSynonyms+ build-depends: base >=4.8 && <4.9+ , async >=2.0 && <2.1+ , transformers >=0.4 && <0.5+ , text >=1.2 && <1.3+ , time >=1.5 && <1.6+ , mtl >= 2.2.1 && <2.3+ , exceptions >= 0.8.0.2 && <0.9+ , free >= 4.12.1 && < 4.13+ , stm >= 2.4.4.1 && < 2.5+ , stm-delay >= 0.1.1.1 && < 0.2+ , wl-pprint-text >= 1.1.0.4 && < 1.2+ , monad-control >= 1.0.0.4 && < 1.1+ , transformers-base >= 0.4.4 && < 0.5+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -O2 -Wall++Benchmark benchmark-logging-effect+ type: exitcode-stdio-1.0+ main-is: Benchmark.hs+ build-depends: base, logging-effect, criterion, monad-logger, fast-logger, text, bytestring, wl-pprint-text, lifted-async, time+ ghc-options: -O2
+ src/Control/Monad/Log.hs view
@@ -0,0 +1,680 @@+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++module Control.Monad.Log+ ( -- * Introduction+ -- $intro++ -- * Getting Started+ -- $tutorialIntro++ -- ** Working with @logging-effect@+ -- *** Emitting log messages+ -- $tutorial-monadlog++ -- *** Outputting with 'LoggingT'+ -- $tutorial-loggingt++ -- *** Adapting and composing logging+ -- $tutorial-composing++ -- * @MonadLog@+ MonadLog(..), mapLogMessage,++ -- * Message transformers+ PP.renderPretty,+ -- ** Timestamps+ WithTimestamp(..), timestamp, renderWithTimestamp,+ -- ** Severity+ WithSeverity(..), Severity(..), renderWithSeverity,+ -- ** Call stacks+ WithCallStack(..), withCallStack, renderWithCallStack,++ -- * @LoggingT@, a general handler+ LoggingT(..), runLoggingT, mapLoggingT,++ -- ** 'LoggingT' Handlers+ Handler, withFDHandler,++ -- *** Batched handlers+ withBatchedHandler, BatchingOptions(..), defaultBatchingOptions,++ -- * Pure logging+ PureLoggingT(..), runPureLoggingT,++ -- * Discarding logs+ DiscardLoggingT(DiscardLoggingT,discardLogging)++ -- * Aside: An @mtl@ refresher+ -- $tutorialMtl+ ) where++import Control.Applicative+import Control.Concurrent.Async (async, wait)+import Control.Concurrent.STM+import Control.Concurrent.STM.Delay+import Control.Monad (MonadPlus, guard)+import Control.Monad.Base+import Control.Monad.Catch (MonadThrow(..), MonadMask(..), MonadCatch(..), bracket)+import Control.Monad.Cont.Class (MonadCont(..))+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.Fix+import Control.Monad.Free.Class (MonadFree(..))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.RWS.Class (MonadRWS)+import Control.Monad.Reader.Class (MonadReader(..))+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Control+import Control.Monad.Trans.Reader (ReaderT(..))+import Control.Monad.Trans.State.Strict (StateT(..))+import Control.Monad.Writer.Class (MonadWriter(..))+import Data.Monoid+import Data.Time (UTCTime, getCurrentTime)+import GHC.SrcLoc (SrcLoc, showSrcLoc)+import GHC.Stack+import System.IO (Handle)+import qualified Data.Text.Lazy as LT+import qualified Text.PrettyPrint.Leijen.Text as PP++--------------------------------------------------------------------------------+-- | The class of monads that support logging.+class Monad m => MonadLog message m | m -> message where+ -- | Append a message to the log for this computation.+ logMessage :: message -> m ()++-- | 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+ :: MonadLog message' m+ => (message -> message') -> LoggingT message m a -> m a+mapLogMessage f m =+ runLoggingT m+ (logMessage . f)++--------------------------------------------------------------------------------+-- | Add \"Severity\" information to a log message. This is often used to convey+-- how significant a log message is.+data WithSeverity a =+ WithSeverity {msgSeverity :: Severity -- ^ Retrieve the 'Severity' a message.+ ,discardSeverity :: a -- ^ View the underlying message.+ }+ deriving (Eq,Ord,Read,Show,Functor)++-- | Classes of severity for log messages. These have been chosen to match+-- @syslog@ severity levels+data Severity =+ Emergency -- ^ System is unusable. By @syslog@ convention, this level should not be used by applications.+ | Alert -- ^ Should be corrected immediately.+ | Critical -- ^ Critical conditions.+ | Error -- ^ Error conditions.+ | Warning -- ^ May indicate that an error will occur if action is not taken.+ | Notice -- ^ Events that are unusual, but not error conditions.+ | Informational -- ^ Normal operational messages that require no action.+ | Debug -- ^ Information useful to developers for debugging the application.+ deriving (Eq,Enum,Bounded,Read,Show,Ord)++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.+--+-- >>> renderWithSeverity id Debug (WithSeverity Info "Flux capacitor is functional")+-- [Info] 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)++--------------------------------------------------------------------------------+-- | Add a timestamp to log messages.+--+-- Note that while most log message transformers are designed to be used at the+-- point of logging, this transformer is best applied within the handler.+-- This is advised as timestamps are generally applied uniformly, so doing it+-- in the handler is fine (no extra information or context of the program is+-- required). The other reason is that logging with a timestamp requires+-- 'MonadIO' - while the rest of your computation is free to use 'MonadIO',+-- 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.+ }+ deriving (Functor,Traversable,Foldable)++-- | Given a way to render the underlying message @a@ and a way to format+-- 'UTCTime', render a message with its timestamp.+--+-- >>> renderWithTimestamp (formatTime defaultTimeLocale rfc822DateFormat) id timestamppedLogMessage+-- [Tue, 19 Jan 2016 11:29:42 UTC] Setting target speed to plaid+renderWithTimestamp :: (UTCTime -> String)+ -- ^ How to format the timestamp.+ -> (a -> PP.Doc)+ -- ^ How to render the rest of the message.+ -> (WithTimestamp a -> PP.Doc)+renderWithTimestamp formatter k (WithTimestamp a t) =+ PP.brackets (PP.text (LT.pack (formatter t))) PP.<+> PP.align (k a)++-- | Add the current time as a timestamp to a message.+timestamp :: (MonadIO m) => a -> m (WithTimestamp a)+timestamp msg = do+ now <- liftIO getCurrentTime+ pure (WithTimestamp msg now)++--------------------------------------------------------------------------------+-- | Add call stack information to log lines.+--+-- This functional requires that you pass around the call stack via implicit+-- 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)++-- | Given a way to render the underlying message @a@ render a message with a+-- callstack.+--+-- The callstack will be pretty-printed underneith the log message itself.+renderWithCallStack :: (a -> PP.Doc) -> WithCallStack a -> PP.Doc+renderWithCallStack k (WithCallStack stack msg) =+ k msg PP.<$> PP.indent 2 (prettyCallStack (getCallStack stack))++prettyCallStack :: [(String,SrcLoc)] -> PP.Doc+prettyCallStack [] = "empty callstack"+prettyCallStack (root:rest) =+ prettyCallSite root PP.<$> PP.indent 2 (PP.vsep (map prettyCallSite rest))+ where prettyCallSite (f,loc) =+ PP.text (LT.pack f) <> ", called at " <>+ PP.text (LT.pack (showSrcLoc loc))++-- | Construct a 'WithCallStack' log message.+--+-- This should normally be preferred over just using 'WithCallStack' as it will+-- append a new entry to the stack - pointing to this exact log line. However,+-- if you are creating a combinator (such as a wrapper that logs and throws+-- an exception), you may be better manually capturing the 'CallStack' and+-- using 'WithCallStack'.+withCallStack :: (?stack :: CallStack) => a -> WithCallStack a+withCallStack = WithCallStack ?stack++--------------------------------------------------------------------------------+-- | 'LoggingT' is a very general handler for the 'MonadLog' effect. Whenever a+-- log entry is emitted, the given 'Handler' is invoked, producing some+-- side-effect (such as writing to @stdout@, or appending a database table).+newtype LoggingT message m a =+ LoggingT (ReaderT (Handler m message) m a)+ deriving (Monad,Applicative,Functor,MonadFix,Alternative,MonadPlus,MonadIO,MonadWriter w,MonadCont,MonadError e,MonadMask,MonadCatch,MonadThrow,MonadState s)++instance MonadBase b m => MonadBase b (LoggingT message m) where+ liftBase = lift . liftBase++instance MonadBaseControl b m => MonadBaseControl b (LoggingT message m) where+ type StM (LoggingT message m) a = StM m a+ liftBaseWith runInBase =+ LoggingT (ReaderT (\handler ->+ liftBaseWith+ (\runInReader ->+ runInBase (\(LoggingT (ReaderT m)) ->+ runInReader (m handler)))))+ restoreM st = LoggingT (ReaderT (\_ -> restoreM st))++-- | Given a 'Handler' for a given @message@, interleave this 'Handler' into the+-- underlying @m@ computation whenever 'logMessage' is called.+runLoggingT+ :: LoggingT message m a -> Handler m message -> m a+runLoggingT (LoggingT (ReaderT m)) handler = m handler++instance MonadTrans (LoggingT message) where+ lift = LoggingT . ReaderT . const++instance MonadReader r m => MonadReader r (LoggingT message m) where+ ask = lift ask+ local f (LoggingT (ReaderT m)) = LoggingT (ReaderT (local f . m))+ reader f = lift (reader f)++-- | 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))++instance MonadRWS r w s m => MonadRWS r w s (LoggingT message m)++instance (Functor f,MonadFree f m) => MonadFree f (LoggingT message m)++-- | 'LoggingT' unfortunately does admit an instance of the @MFunctor@ type+-- class, which provides the @hoist@ method to change the monad underneith+-- a monad transformer. However, it is possible to do this with 'LoggingT'+-- provided that you have a way to re-interpret a log handler in the+-- original monad.+mapLoggingT :: (forall x. (Handler m message -> m x) -> (Handler n message' -> n x))+ -> LoggingT message m a+ -> LoggingT message' n a+mapLoggingT eta (LoggingT (ReaderT f)) = LoggingT (ReaderT (eta f))++--------------------------------------------------------------------------------+-- | Handlers are mechanisms to interpret the meaning of logging as an action+-- in the underlying monad. They are simply functions from log messages to+-- @m@-actions.+type Handler m message = message -> m ()++-- | Options that be used to configure 'withBatchingHandler'.+data BatchingOptions =+ BatchingOptions {flushMaxDelay :: Int -- ^ The maximum amount of time to wait between flushes+ ,flushMaxQueueSize :: Int -- ^ The maximum amount of messages to hold in memory between flushes}+ ,blockWhenFull :: Bool -- ^ If the 'Handler' becomes full, 'logMessage' will block until the queue is flushed if 'blockWhenFull' is 'True', otherwise it will drop that message and continue.+ }+ deriving (Eq,Ord,Read,Show)++-- | Defaults for 'BatchingOptions'+--+-- @+-- 'defaultBatchingOptions' = 'BatchingOptions' {'flushMaxDelay' = 1000000+-- ,'flushMaxQueueSize' = 100+-- ,'blockWhenFull' = 'True'}+-- @+defaultBatchingOptions :: BatchingOptions+defaultBatchingOptions = BatchingOptions 1000000 100 True++-- | Create a new batched handler. Batched handlers take batches of messages to+-- log at once, which can be more performant than logging each individual+-- message.+--+-- A batched handler flushes under three criteria:+--+-- 1. The flush interval has elapsed and the queue is not empty.+-- 2. The queue has become full and needs to be flushed.+-- 3. The scope of 'withBatchedHandler' is exited.+--+-- Batched handlers queue size and flush period can be configured via+-- 'BatchingOptions'.+withBatchedHandler :: (MonadIO io,MonadMask io)+ => BatchingOptions+ -> ([message] -> IO ())+ -> (Handler io message -> io a)+ -> io a+withBatchedHandler BatchingOptions{..} flush k =+ do do closed <- liftIO (newTVarIO False)+ channel <- liftIO (newTBQueueIO flushMaxQueueSize)+ bracket (liftIO (async (repeatWhileTrue (publish closed channel))))+ (\publisher ->+ do liftIO (do atomically (writeTVar closed True)+ wait publisher))+ (\_ ->+ k (\msg ->+ liftIO (atomically+ (writeTBQueue channel msg <|>+ check (not blockWhenFull)))))+ where repeatWhileTrue m =+ do again <- m+ if again+ then repeatWhileTrue m+ else return ()+ publish closed channel =+ do flushAlarm <- newDelay flushMaxDelay+ (messages,stillOpen) <-+ atomically+ (do messages <-+ flushAfter flushAlarm <|> flushFull <|> flushOnClose+ stillOpen <- fmap not (readTVar closed)+ return (messages,stillOpen))+ flush messages+ pure stillOpen+ where flushAfter flushAlarm =+ do waitDelay flushAlarm+ isEmptyTBQueue channel >>= guard . not+ emptyTBQueue channel+ flushFull =+ do isFullTBQueue channel >>= guard+ emptyTBQueue channel+ flushOnClose =+ do readTVar closed >>= guard+ emptyTBQueue channel+ emptyTBQueue q =+ do mx <- tryReadTBQueue q+ case mx of+ Nothing -> return []+ Just x -> fmap (x :) (emptyTBQueue q)++-- | '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'.+--+-- These 'Handler's asynchronously log messages to the given file descriptor,+-- rather than blocking.+withFDHandler+ :: (MonadIO io,MonadMask io)+ => BatchingOptions+ -> Handle -- ^ The 'Handle' to write log messages to.+ -> Float -- ^ The @ribbonFrac@ parameter to 'PP.renderPretty'+ -> Int -- ^ The amount of characters per line. Lines longer than this will be pretty-printed across multiple lines if possible.+ -> (Handler io PP.Doc -> io a)+ -> io a+withFDHandler options fd ribbonFrac width =+ withBatchedHandler options+ (PP.displayIO fd . PP.renderPretty ribbonFrac width . (<> PP.linebreak) . PP.vsep)++--------------------------------------------------------------------------------+-- | A 'MonadLog' handler optimised for pure usage. Log messages are accumulated+-- strictly, given that messasges form a 'Monoid'.+newtype PureLoggingT log m a = MkPureLoggingT (StateT log m a)+ deriving (Functor,Applicative,Monad,MonadFix,MonadCatch,MonadThrow,MonadIO,MonadMask,MonadReader r,MonadWriter w,MonadCont,MonadError e,Alternative,MonadPlus)++instance MonadBase b m => MonadBase b (PureLoggingT message m) where+ liftBase = lift . liftBase++instance MonadTransControl (PureLoggingT message) where+ type StT (PureLoggingT message) a = StT (StateT message) a+ liftWith = defaultLiftWith MkPureLoggingT (\(MkPureLoggingT m) -> m)+ restoreT = defaultRestoreT MkPureLoggingT++instance MonadBaseControl b m => MonadBaseControl b (PureLoggingT message m) where+ type StM (PureLoggingT message m) a = ComposeSt (PureLoggingT message) m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM++-- | Run a computation with access to logging by accumulating a log under its+-- 'Monoid' instance.+runPureLoggingT+ :: Monoid log+ => PureLoggingT log m a -> m (a,log)+runPureLoggingT (MkPureLoggingT (StateT m)) = m mempty++mkPureLoggingT+ :: (Monad m,Monoid log)+ => m (a,log) -> PureLoggingT log m a+mkPureLoggingT m =+ MkPureLoggingT+ (StateT (\s ->+ do (a,l) <- m+ return (a,s <> l)))++instance MonadTrans (PureLoggingT log) where+ lift = MkPureLoggingT . 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))++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)+ get = lift get+ put = lift . put++--------------------------------------------------------------------------------+-- | A 'MonadLog' handler that throws messages away.+--+-- The documentation may appear a bit confusing, but note that the full type of+-- 'discardLogging' is:+--+-- @+-- 'discardLogging' :: 'DiscardLoggingT' messsage m a -> m a+-- @+newtype DiscardLoggingT message m a =+ DiscardLoggingT {discardLogging :: m a -- ^ Run a 'MonadLog' computation by throwing away all log requests.+ }+ deriving (Functor,Applicative,Monad,MonadFix,MonadCatch,MonadThrow,MonadIO,MonadMask,MonadReader r,MonadWriter w,MonadCont,MonadError e,Alternative,MonadPlus,MonadState s,MonadRWS r w s,MonadBase b)++instance MonadBaseControl b m => MonadBaseControl b (DiscardLoggingT message m) where+ type StM (DiscardLoggingT message m) a = StM m a+ liftBaseWith runInBase = lift (liftBaseWith (\runInOrig -> runInBase (runInOrig . discardLogging)))+ restoreM = lift . restoreM++instance MonadTrans (DiscardLoggingT message) where+ lift = DiscardLoggingT++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 ()++{- $intro++@logging-effect@ provides a toolkit for general logging in Haskell programs+and libraries. The library consists of the type class 'MonadLog' to add log+output to computations, and this library comes with a set of instances to help+you decide how this logging should be performed. There are predefined handlers+to write to file handles, to accumulate logs purely, or to discard logging+entirely.++Unlike other logging libraries available on Hackage, 'MonadLog' does /not/+assume that you will be logging text information. Instead, the choice of logging+data is up to you. This leads to a highly compositional form of logging, with+the able to reinterpret logs into different formats, and avoid throwing+information away if your final output is structured (such as logging to a+relational database).++-}++{- $tutorialIntro++@logging-effect@ is designed to be used via the 'MonadLog' type class and+encourages an "mtl" style approach to programming. If you're not familiar with+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 #tutorialMtl#++If you are already familiar with the @mtl@ you can skip this section. This is not+designed to be an exhaustive introduction to the @mtl@ library, but hopefully+via a short example you'll have a basic familarity with the approach.++In this example, we'll write a program with access to state and general 'IO'+actions. One way to do this would be to work with monad transformers, stacking+'StateT' on top of 'IO':++@+import "Control.Monad.Trans.State.Strict" ('StateT', 'get', 'put')+import "Control.Monad.Trans.Class" ('lift')++transformersProgram :: 'StateT' 'Int' 'IO' ()+transformersProgram = do+ stateNow <- 'get'+ 'lift' launchMissles+ 'put' (stateNow + 42)+@++This is OK, but it's not very flexible. For example, the transformers library+actually provides us with two implementations of state monads - strict and a+lazy variant. In the above approach we have forced the user into a choice (we+chose the strict variant), but this can be undesirable. We could imagine that+in the future there may be even more implementations of state monads (for+example, a state monad that persists state entirely on a remote machine) - if+requirements change we are unable to reuse this program without changing its+type.++With the @mtl@, we instead program to an /abstract specification/ of the effects+we require, and we postpone the choice of handler until the point when the+computation is ran.++Rewriting the @transformersProgram@ using the @mtl@, we have the following:++@+import "Control.Monad.State.Class" ('MonadState'('get', 'put'))+import "Control.Monad.IO.Class" ('MonadIO'('liftIO'))++mtlProgram :: ('MonadState' 'Int' m, 'MonadIO' m) => m ()+mtlProgram = do+ stateNow <- 'get'+ 'liftIO' launchMissles+ 'put' (stateNow + 42)+@++Notice that @mtlProgram@ doesn't specify a concrete choice of state monad. The+"transformers" library gives us two choices - strict or lazy state monads. We+make the choice of a specific monad stack when we run our program:++@+import "Control.Monad.Trans.State.Strict" ('execStateT')++main :: 'IO' ()+main = 'execStateT' mtlProgram 99+@++Here we chose the strict variant via 'execStateT'. Using 'execStateT'+/eliminates/ the 'MonadState' type class from @mtlProgram@, so now we only have+to fulfill the 'MonadIO' obligation. There is only one way to handle this, and+that's by working in the 'IO' monad. Fortunately we're inside the @main@+function, which is in the 'IO' monad, so we're all good.++-}++{- $tutorial-monadlog++To add logging to your applications, you will need to make two changes.++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'.++@+testApp :: 'MonadLog' ('WithSeverity' 'PP.Doc') m => m ()+testApp = do+ logMessage ('WithSeverity' 'Informational' "Don't mind me")+ logMessage ('WithSeverity' 'Error' "But do mind me!")+@++Note that this does /not/ specify where the logs "go", we'll address that when+we run the program.++-}++{- $tutorial-loggingt++Next, we need to run this computation under a 'MonadLog' effect handler. The+most flexible handler is 'LoggingT'. 'LoggingT' runs a 'MonadLog' computation+by providing it with a 'Handler', which is a computation that can be in the+underlying monad.++For example, we can easily fulfill the 'MonadLog' type class by just using+'print' as our 'Handler':++>>> runLoggingT testApp print+WithSeverity {msgSeverity = Informational, discardSeverity = "Don't mind me"}+WithSeverity {msgSeverity = Error, discardSeverity = "But do mind me!"}++The log messages are printed according to their 'Show' instances, and - while+this works - it is not particularly user friendly. As 'Handler's are just functions+from log messages to monadic actions, we can easily reformat log messages.+@logging-effect@ comes with a few "log message transformers" (such as+'WithSeverity'), and each of these message transformers has a canonical way to+render in a human-readable format:++>>> runLoggingT testApp (print . renderWithSeverity id)+[Informational] Don't mind me+[Error] But do mind me!++That's looking much more usable - and in fact this approach is probably fine for+command line applications.++However, for longer running high performance applications there is a slight+problem. Remember that 'runLoggingT' simply interleaves the given 'Handler'+whenever 'logMessage' is called. By providing 'print' as a 'Handler', our+application will actually block until the log is complete. This is undesirable+for high performance applications, where it's much better to log asynchronously.++@logging-effect@ comes with "batched handlers" for this problem. Batched handlers+are handlers that log asynchronously, are flushed periodically, and have maximum+memory impact. Batched handlers are created with 'withBatchedHandler', though+if you are just logging to file descriptors you can also use 'withFDHandler'.+We'll use this next to log to @STDOUT@:++@+main :: 'IO' ()+main =+ 'withFDHandler' 'defaultBatchingOptions' 'stdout' 0.4 80 $ \logToStdout ->+ 'runLoggingT' testApp ('logToStdout' . 'renderWithSeverity' 'id')+@++Finally, as 'Handler's are just functions (we can't stress this enough!) you+are free to slice-and-dice your log messages however you want. As our log+messages are structured, we can pattern match on the messages and dispatch them+to multiple handlers. In this final example of using 'LoggingT' we'll split+our log messages between @STDOUT@ and @STDERR@, and change the formatting of+error messages:++@+main :: IO ()+main = do+ 'withFDHandler' 'defaultBatchingOptions' 'stderr' 0.4 80 $ \stderrHandler ->+ 'withFDHandler' 'defaultBatchingOptions' 'stdout' 0.4 80 $ \stdoutHandler ->+ 'runLoggingT' m+ (\\message ->+ case 'msgSeverity' message of+ 'Error' -> stderrHandler ('discardSeverity' message)+ _ -> stdoutHandler ('renderWithSeverity' id message))+@++>>> main+[Informational] Don't mind me!+BUT DO MIND ME!++-}++{- $tutorial-composing++So far we've considered very small applications where all log messages fit nicely+into a single type. However, as applications grow and begin to reuse components,+it's unlikely that this approach will scale. @logging-effect@ comes with a+mapping function - 'mapLogMessage' - which allows us to map log messages from one+type to another (just like how we can use 'map' to change elements of a list).++For example, we've already seen the basic @testApp@ computation above that used+'WithSeverity' to add severity information to log messages. Elsewhere we might+have some older code that doesn't yet have any severity information:++@+legacyCode :: 'MonadLog' 'PP.Doc' m => m ()+legacyCode = 'logMessage' "Does anyone even remember writing this function?"+@++Here @legacyCode@ is only logging 'PP.Doc', while our @testApp@ is logging+'WithSeverity' 'PP.Doc'. What happens if we compose these programs?++>>> :t testApp >> legacyCode+ Couldn't match type ‘Doc’ with ‘WithSeverity Doc’++Whoops! 'MonadLog' has /functional dependencies/ on the type class which means+that there can only be a single way to log per monad. One solution might be+to 'lift' one set of logs into the other:++>>> :t testApp >> lift legacyCode+ :: (MonadTrans t, MonadLog Doc m, MonadLog (WithSeverity Doc) (t m)) => t m ()++And indeed, this is /a/ solution, but it's not a particularly nice one.++Instead, we can map both of these computations into a common log format:++>>> :t mapLogMessage Left testApp >> mapLogMessage Right (logMessage "Hello")+ :: (MonadLog (Either (WithSeverity Doc) Doc) m) => m ()++This is a trivial way of combining two different types of log message. In larger+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.++-}