├── .gitignore ├── Benchmark.hs ├── Changelog.md ├── LICENSE ├── Setup.hs ├── default.nix ├── logging-effect.cabal ├── shell.nix ├── src └── Control │ └── Monad │ └── Log.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | dist-newstyle/ 3 | .ghc.environment.* 4 | -------------------------------------------------------------------------------- /Benchmark.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main where 4 | 5 | import Control.Monad (replicateM_) 6 | import Criterion.Main 7 | import qualified Control.Monad.Log as LoggingEffect 8 | import qualified Control.Monad.Logger as MonadLogger 9 | import qualified Data.ByteString.Char8 as BS 10 | import System.Log.FastLogger (fromLogStr, toLogStr) 11 | import Data.Monoid ((<>)) 12 | import qualified Data.Text.IO as T 13 | import qualified Data.Text.Prettyprint.Doc as PP 14 | import qualified Data.Text.Prettyprint.Doc.Render.Text as PP 15 | import System.IO (stdout) 16 | import Control.Concurrent.Async.Lifted 17 | import Data.Foldable (sequenceA_) 18 | import Data.Time 19 | 20 | main :: IO () 21 | main = defaultMain [ bgroup "log10k" [ bench "logging-effect" (nfIO (LoggingEffect.runLoggingT loggingEffectLog loggingEffectStdoutHandler)) 22 | , bench "monad-logger" (nfIO (MonadLogger.runLoggingT monadLoggerLog monadLoggerStdoutHandler))] 23 | , bgroup "log10k-batched" 24 | [ bench "logging-effect" (nfIO (LoggingEffect.withFDHandler LoggingEffect.defaultBatchingOptions stdout 0.4 80 $ \h -> 25 | LoggingEffect.runLoggingT loggingEffectLog 26 | (h . LoggingEffect.renderWithSeverity id))) 27 | , bench "monad-logger" (nfIO (MonadLogger.runStdoutLoggingT monadLoggerLog))] 28 | , bgroup "log10k-batched-async" 29 | [ bench "logging-effect" (nfIO (LoggingEffect.withFDHandler LoggingEffect.defaultBatchingOptions stdout 0.4 80 $ \h -> 30 | LoggingEffect.runLoggingT (nThreads 10 (replicateM_ 10 loggingEffectLog)) 31 | (h . LoggingEffect.renderWithSeverity id))) 32 | , bench "monad-logger" (nfIO (MonadLogger.runStdoutLoggingT (nThreads 10 (replicateM_ 10 $ MonadLogger.logDebugNS "?" "Log message"))))] 33 | , bgroup "map-and-log" [ bench "map-once" (nfIO (LoggingEffect.runLoggingT (LoggingEffect.mapLogMessage id $ LoggingEffect.mapLogMessage id $ LoggingEffect.mapLogMessage id $ LoggingEffect.mapLogMessage id loggingEffectLog) loggingEffectStdoutHandler))] 34 | , bgroup "discard-logs" [ bench "logging-effect" (nfIO (LoggingEffect.discardLogging loggingEffectLog)) 35 | , bench "monad-logger" (nfIO (MonadLogger.runNoLoggingT monadLoggerLog))]] 36 | 37 | loggingEffectStdoutHandler = PP.putDoc . (<> PP.line') . LoggingEffect.renderWithSeverity id 38 | 39 | loggingEffectLog :: LoggingEffect.MonadLog (LoggingEffect.WithSeverity (PP.Doc ann)) m => m () 40 | loggingEffectLog = LoggingEffect.logMessage (LoggingEffect.WithSeverity LoggingEffect.Debug "Log message") 41 | 42 | monadLoggerLog :: MonadLogger.MonadLogger m => m () 43 | monadLoggerLog = MonadLogger.logDebugNS "?" "Log message" 44 | 45 | monadLoggerStdoutHandler = \_ _ level str -> BS.putStrLn (fromLogStr (toLogStr (show level) <> str)) 46 | 47 | nThreads n m = runConcurrently (sequenceA_ (replicate n (Concurrently m))) 48 | -------------------------------------------------------------------------------- /Changelog.md: -------------------------------------------------------------------------------- 1 | ## 1.4.0 -- 2023-03-26 2 | 3 | * Build with GHC 9.6 4 | * Build with `free-5.2` 5 | * Remove instances for `ListT`, as this type is deprecated and removed from `transformers-0.6`. 6 | * Remove instances for `ErrorT`, as this type is deprecated and removed from `transformers-0.6`. 7 | 8 | ## 1.3.13 -- 2022-02-20 9 | 10 | ### Other changes 11 | 12 | * Increased the upper-bound of time to < 1.13. 13 | * Increased the upper-bound of base to < 4.17. 14 | * Increased the upper-bound of semigroups to < 0.21. 15 | 16 | ## 1.3.12 -- 2020-12-14 17 | 18 | ### Other changes 19 | 20 | * Increase the upper-bound of time to < 1.12. 21 | * Increase the upper-bound of prettyprinter to < 1.8. 22 | 23 | --- 24 | 25 | ## 1.3.11 -- 2020-08-18 26 | 27 | ### Other changes 28 | 29 | * Increase the lower-bound of unliftio-core to 0.2.0.0 30 | 31 | --- 32 | 33 | ## 1.3.10 -- 2020-06-17 34 | 35 | ### Other changes 36 | 37 | * Add MonadUnliftIO instance to DiscardLoggingT 38 | * Support `base-4.14` 39 | 40 | --- 41 | 42 | ## 1.3.9 -- 2020-01-25 43 | 44 | ### Other Changes 45 | 46 | * Support `prettyprinter-1.6` 47 | 48 | --- 49 | 50 | ## 1.3.8 -- 2019-11-10 51 | 52 | ### Other Changes 53 | 54 | * Support `prettyprinter-1.5` 55 | 56 | --- 57 | 58 | ## 1.3.7 -- 2019-10-22 59 | 60 | ### Other Changes 61 | 62 | * Support `prettyprinter-1.4` 63 | 64 | --- 65 | 66 | ## 1.3.6 -- 2019-09-19 67 | 68 | ### New 69 | 70 | * Added `MonadFail` instances. 71 | 72 | --- 73 | 74 | ## 1.3.5 -- 2019-09-17 75 | 76 | ### Other Changes 77 | 78 | * Support `base-4.13` 79 | * Support GHC 8.8.1 80 | * Support `prettyprinter-1.3` 81 | 82 | --- 83 | 84 | ## 1.3.4 -- 2019-05-15 85 | 86 | ### Other Changes 87 | 88 | * Support `semigroups-0.19`. 89 | 90 | --- 91 | 92 | ## 1.3.3 -- 2018-09-30 93 | 94 | ### Other Changes 95 | 96 | * Support `stm-2.5`. 97 | * Support `base-4.12`. 98 | 99 | --- 100 | 101 | ## 1.3.2 -- 2018-07-06 102 | 103 | ### Other Changes 104 | 105 | * Support `free-5.1`. 106 | 107 | --- 108 | 109 | ## 1.3.1 110 | 111 | * Add `MonadUnliftIO` instance for `LoggingT`. 112 | 113 | --- 114 | 115 | # 1.3.0 116 | 117 | ## Major Changes 118 | 119 | * Switch from `wl-pprint-text` to `prettyprinter`. 120 | 121 | ## Other changes 122 | 123 | * Change the type of the `ribbonFrac` parameter of `withFDHandler` 124 | from `Float` to `Double` to reflect the underlying `prettyprinter` 125 | API. 126 | 127 | --- 128 | 129 | # 1.2.6 130 | 131 | ## Other Changes 132 | 133 | * Increased upper bound of `base` and support GHC 8.4. 134 | 135 | --- 136 | 137 | # 1.2.5 138 | 139 | ## Other Changes 140 | 141 | * Increased upper bound of `exceptions`. 142 | 143 | --- 144 | 145 | # 1.2.4 146 | 147 | ## Other Changes 148 | 149 | * Increased upper bound of `exceptions`. 150 | 151 | --- 152 | 153 | # 1.2.3 154 | 155 | ## Other Changes 156 | 157 | * Increased upper of `async`. 158 | 159 | --- 160 | 161 | # 1.2.2 162 | 163 | ## Other Changes 164 | 165 | * Increased upper bound of `free` and `time`. 166 | 167 | --- 168 | 169 | # 1.2.1 170 | 171 | ## Other Changes 172 | 173 | * Increased upper bound of `base` to allow < 4.11. 174 | 175 | --- 176 | 177 | # 1.2.0 178 | 179 | ## Major Changes 180 | 181 | - `withFDHandler` now explicitly flushes the file handle whenever log entries 182 | are rendered out. Thanks to @filterfish for identifying this omission that 183 | could lead to log messages being dropped. 184 | 185 | Upgrade steps: no changes other than updating `logging-effect`. 186 | 187 | --- 188 | 189 | # 1.1.3 190 | 191 | ## Other Changes 192 | 193 | - Increased upper bound of `time` to allow < 1.9. 194 | 195 | --- 196 | 197 | # 1.1.2 198 | 199 | ## Other changes 200 | 201 | - Increased upper bound of `time` 202 | 203 | --- 204 | 205 | # 1.1.1 206 | 207 | - `withBatchedHandler` no longer prints empty log messages. Previously, 208 | if you ran a program that didn't log but used `withBatchedHandler` (or anything 209 | that used that), an empty log message would be output. Thanks to @codedmart 210 | for fixing this. 211 | 212 | --- 213 | 214 | # 1.1.0 215 | 216 | *Breaking changes*: 217 | 218 | - `MonadLog` no longer has `logMessage` as a function. It now has 219 | `logMessageFree` which takes a free monoid of log messages. If you were just 220 | using `logging-effect` then this won't affect you, as `logMessage` still exists 221 | with the same signature outside the type class. 222 | 223 | - `MonadLog` now comes with a law that states that logging is a monoid 224 | homomorphism. This essentially means that you have to treat all log messages 225 | uniformly. 226 | 227 | - Pass-through instances for all "stock" monad transformers have been added 228 | (all of `transformers`, `CatchT` from exceptions and `FreeT`/`FT` from `free`). 229 | 230 | - `WithSeverity` now has instances of `Traversable` and `Foldable` 231 | 232 | - `WithTimestamp` now has instances of `Eq`, `Ord`, `Read` and `Show`. 233 | 234 | *Additions*: 235 | 236 | - A set of convenience functions have been added for quickly logging with 237 | severity. The combinators are: `logDebug`, `logInfo`, `logNotice`, 238 | `logWarning`, `logError`, `logCritical`, `logAlert` and `logEmergency`. 239 | 240 | - `mapLogMessage` got a companion function `mapLogMessageM` that works with 241 | monadic tranformations. 242 | 243 | *Other* 244 | 245 | - Many documentation bug fixes. 246 | 247 | - INLINEABLE pragmas added. 248 | 249 | --- 250 | 251 | # 1.0.0 252 | 253 | - Initial release 254 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Ollie Charles 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Ollie Charles nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, async, base, bytestring, criterion, exceptions 2 | , fast-logger, free, lifted-async, monad-control, monad-logger, mtl 3 | , prettyprinter, semigroups, stdenv, stm, stm-delay, text, time 4 | , transformers, transformers-base, wl-pprint-text 5 | }: 6 | mkDerivation { 7 | pname = "logging-effect"; 8 | version = "1.3.0"; 9 | src = ./.; 10 | libraryHaskellDepends = [ 11 | async base exceptions free monad-control mtl prettyprinter 12 | semigroups stm stm-delay text time transformers transformers-base 13 | ]; 14 | benchmarkHaskellDepends = [ 15 | base bytestring criterion fast-logger lifted-async monad-logger 16 | text time wl-pprint-text 17 | ]; 18 | homepage = "https://github.com/ocharles/logging-effect"; 19 | description = "A mtl-style monad transformer for general purpose & compositional logging"; 20 | license = stdenv.lib.licenses.bsd3; 21 | } 22 | -------------------------------------------------------------------------------- /logging-effect.cabal: -------------------------------------------------------------------------------- 1 | name: logging-effect 2 | version: 1.4.0 3 | synopsis: A mtl-style monad transformer for general purpose & compositional logging 4 | homepage: https://github.com/ocharles/logging-effect 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Ollie Charles 8 | maintainer: ollie@ocharles.org.uk 9 | build-type: Simple 10 | cabal-version: >=1.10 11 | extra-source-files: Changelog.md 12 | 13 | library 14 | exposed-modules: Control.Monad.Log 15 | other-extensions: ViewPatterns, OverloadedStrings, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, PatternSynonyms 16 | build-depends: base >=4.8 && <4.19 17 | , async >=2.0 && <2.3 18 | , transformers >=0.4 && <0.7 19 | , text >=1.2 && <2.1 20 | , time >=1.5 && <1.13 21 | , mtl >= 2.2.1 && <2.4 22 | , exceptions >= 0.8.0.2 && <0.11 23 | , free >= 4.12.1 && < 5.3 24 | , stm >= 2.4.4.1 && < 2.6 25 | , stm-delay >= 0.1.1.1 && < 0.2 26 | , prettyprinter >= 1.2 && < 1.8 27 | , monad-control >= 1.0.0.4 && < 1.1 28 | , transformers-base >= 0.4.4 && < 0.5 29 | , semigroups >= 0.16.2.2 && < 0.21 30 | , unliftio-core >= 0.2.0.0 && < 0.3 31 | hs-source-dirs: src 32 | default-language: Haskell2010 33 | ghc-options: -O2 -Wall 34 | 35 | Benchmark benchmark-logging-effect 36 | type: exitcode-stdio-1.0 37 | main-is: Benchmark.hs 38 | build-depends: base, logging-effect, criterion, monad-logger, fast-logger, text, bytestring, prettyprinter, lifted-async, time 39 | ghc-options: -O2 40 | default-language: Haskell2010 41 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}, compiler ? "default", doBenchmark ? false }: 2 | 3 | let 4 | 5 | inherit (nixpkgs) pkgs; 6 | 7 | f = { mkDerivation, async, base, bytestring, criterion 8 | , exceptions, fast-logger, free, lifted-async, monad-control 9 | , monad-logger, mtl, prettyprinter, semigroups, stdenv, stm 10 | , stm-delay, text, time, transformers, transformers-base 11 | , unliftio-core 12 | }: 13 | mkDerivation { 14 | pname = "logging-effect"; 15 | version = "1.3.0"; 16 | src = ./.; 17 | libraryHaskellDepends = [ 18 | async base exceptions free monad-control mtl prettyprinter 19 | semigroups stm stm-delay text time transformers transformers-base 20 | unliftio-core 21 | ]; 22 | benchmarkHaskellDepends = [ 23 | base bytestring criterion fast-logger lifted-async monad-logger 24 | prettyprinter text time 25 | ]; 26 | homepage = "https://github.com/ocharles/logging-effect"; 27 | description = "A mtl-style monad transformer for general purpose & compositional logging"; 28 | license = stdenv.lib.licenses.bsd3; 29 | }; 30 | 31 | haskellPackages = if compiler == "default" 32 | then pkgs.haskellPackages 33 | else pkgs.haskell.packages.${compiler}; 34 | 35 | variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id; 36 | 37 | drv = variant (haskellPackages.callPackage f {}); 38 | 39 | in 40 | 41 | if pkgs.lib.inNixShell then drv.env else drv 42 | -------------------------------------------------------------------------------- /src/Control/Monad/Log.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE AutoDeriveTypeable #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE DeriveFoldable #-} 5 | {-# LANGUAGE DeriveFunctor #-} 6 | {-# LANGUAGE DeriveTraversable #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE FunctionalDependencies #-} 10 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 11 | {-# LANGUAGE ImplicitParams #-} 12 | {-# LANGUAGE MultiParamTypeClasses #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | {-# LANGUAGE RankNTypes #-} 15 | {-# LANGUAGE RecordWildCards #-} 16 | {-# LANGUAGE StandaloneDeriving #-} 17 | {-# LANGUAGE TypeFamilies #-} 18 | {-# LANGUAGE UndecidableInstances #-} 19 | 20 | module Control.Monad.Log 21 | ( -- * Introduction 22 | -- $intro 23 | 24 | -- * Getting Started 25 | -- $tutorialIntro 26 | 27 | -- ** Working with @logging-effect@ 28 | -- *** Emitting log messages 29 | -- $tutorial-monadlog 30 | 31 | -- *** Outputting with 'LoggingT' 32 | -- $tutorial-loggingt 33 | 34 | -- *** Adapting and composing logging 35 | -- $tutorial-composing 36 | 37 | -- * @MonadLog@ 38 | logMessage, mapLogMessage, mapLogMessageM, 39 | MonadLog(..), 40 | 41 | -- * Convenience logging combinators 42 | -- $convenience 43 | logDebug, logInfo, logNotice, logWarning, logError, logCritical, logAlert, logEmergency, 44 | 45 | -- * Message transformers 46 | PP.layoutPretty, 47 | -- ** Timestamps 48 | WithTimestamp(..), timestamp, renderWithTimestamp, 49 | -- ** Severity 50 | WithSeverity(..), Severity(..), renderWithSeverity, 51 | -- ** Call stacks 52 | WithCallStack(..), withCallStack, renderWithCallStack, 53 | 54 | -- * @LoggingT@, a general handler 55 | LoggingT(..), runLoggingT, mapLoggingT, 56 | 57 | -- ** 'LoggingT' Handlers 58 | Handler, withFDHandler, 59 | 60 | -- *** Batched handlers 61 | withBatchedHandler, BatchingOptions(..), defaultBatchingOptions, 62 | 63 | -- * Pure logging 64 | PureLoggingT(..), runPureLoggingT, 65 | 66 | -- * Discarding logs 67 | DiscardLoggingT(DiscardLoggingT,discardLogging) 68 | 69 | -- * Aside: An @mtl@ refresher 70 | -- $tutorialMtl 71 | ) where 72 | 73 | import Prelude hiding (foldMap) 74 | import Control.Applicative 75 | import Control.Concurrent.Async (async, wait) 76 | import Control.Concurrent.STM 77 | import Control.Concurrent.STM.Delay 78 | import Control.Monad (MonadPlus, guard) 79 | import Control.Monad.Base 80 | import Control.Monad.Catch (MonadThrow(..), MonadMask(..), MonadCatch(..), bracket) 81 | import Control.Monad.Cont.Class (MonadCont(..)) 82 | import Control.Monad.Error.Class (MonadError(..)) 83 | import Control.Monad.Fix 84 | import Control.Monad.Free.Class (MonadFree(..)) 85 | import Control.Monad.IO.Class (MonadIO, liftIO) 86 | import Control.Monad.IO.Unlift (MonadUnliftIO(..), UnliftIO(..), withUnliftIO) 87 | import Control.Monad.RWS.Class (MonadRWS) 88 | import Control.Monad.Reader.Class (MonadReader(..)) 89 | import Control.Monad.State.Class (MonadState(..)) 90 | import Control.Monad.Trans.Class (MonadTrans(..)) 91 | import Control.Monad.Trans.Control 92 | import Control.Monad.Trans.Reader (ReaderT(..)) 93 | import Control.Monad.Trans.State.Strict (StateT(..)) 94 | import Control.Monad.Writer.Class (MonadWriter(..)) 95 | import Data.Semigroup ((<>)) 96 | import Data.Time (UTCTime, getCurrentTime) 97 | #if MIN_VERSION_base(4,9,0) 98 | import qualified Control.Monad.Fail as Fail 99 | #endif 100 | #if !MIN_VERSION_base(4, 9, 0) 101 | import GHC.SrcLoc (SrcLoc, showSrcLoc) 102 | import GHC.Stack 103 | #else 104 | import GHC.Stack (SrcLoc, CallStack, getCallStack, prettySrcLoc) 105 | #endif 106 | import System.IO (Handle, hFlush) 107 | import qualified Data.Text.Lazy as LT 108 | import qualified Data.Text.Prettyprint.Doc as PP 109 | import qualified Data.Text.Prettyprint.Doc.Render.Text as PP 110 | import qualified Data.List.NonEmpty as NEL 111 | 112 | -- For 'MonadLog' pass-through instances. 113 | import qualified Control.Monad.Trans.Identity as Identity 114 | import qualified Control.Monad.Trans.Reader as Reader 115 | import qualified Control.Monad.Trans.State.Lazy as LazyState 116 | import qualified Control.Monad.Trans.State.Strict as StrictState 117 | import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter 118 | import qualified Control.Monad.Trans.Writer.Strict as StrictWriter 119 | import qualified Control.Monad.Trans.Maybe as Maybe 120 | import qualified Control.Monad.Trans.Except as Except 121 | import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS 122 | import qualified Control.Monad.Trans.RWS.Strict as StrictRWS 123 | import qualified Control.Monad.Trans.Cont as Cont 124 | import qualified Control.Monad.Trans.Free as Free 125 | import qualified Control.Monad.Trans.Free.Church as Free 126 | import qualified Control.Monad.Catch.Pure as Exceptions 127 | 128 | -------------------------------------------------------------------------------- 129 | -- | The class of monads that support logging. 130 | -- 131 | -- Laws: 132 | -- 133 | -- /Monoid homomorphism/: 134 | -- 135 | -- @ 136 | -- 'logMessageFree' a '*>' 'logMessageFree' b = 'logMessageFree' (a '<>' b) 137 | -- @ 138 | class Monad m => MonadLog message m | m -> message where 139 | -- | Fold log messages into this computation. Looking to just log a 140 | -- message? You probably want 'logMessage'. 141 | -- 142 | -- The perhaps strange type here allows us to construct a monoid out of /any/ 143 | -- type of log message. You can think of this as the simpler type: 144 | -- 145 | -- @ 146 | -- logMessageFree :: [message] -> m () 147 | -- @ 148 | logMessageFree :: (forall n. Monoid n => (message -> n) -> n) -> m () 149 | default logMessageFree :: (m ~ t n, MonadTrans t, MonadLog message n) => (forall mon. Monoid mon => (message -> mon) -> mon) -> m () 150 | logMessageFree inj = lift (logMessageFree inj) 151 | {-# INLINEABLE logMessageFree #-} 152 | 153 | -- | Append a message to the log for this computation. 154 | logMessage :: MonadLog message m => message -> m () 155 | logMessage m = logMessageFree (\inject -> inject m) 156 | {-# INLINEABLE logMessage #-} 157 | 158 | -- | Re-interpret the log messages in one computation. This can be useful to 159 | -- embed a computation with one log type in a larger general computation. 160 | mapLogMessage 161 | :: MonadLog message' m 162 | => (message -> message') -> LoggingT message m a -> m a 163 | mapLogMessage f m = 164 | runLoggingT m 165 | (logMessage . f) 166 | {-# INLINEABLE mapLogMessage #-} 167 | 168 | -- | Monadic version of 'mapLogMessage'. This can be used to annotate a 169 | -- message with something that can only be computed in a monad. See e.g. 170 | -- 'timestamp'. 171 | mapLogMessageM 172 | :: MonadLog message' m 173 | => (message -> m message') -> LoggingT message m a -> m a 174 | mapLogMessageM f m = 175 | runLoggingT m ((>>= logMessage) . f) 176 | {-# INLINEABLE mapLogMessageM #-} 177 | 178 | instance MonadLog message m => MonadLog message (Identity.IdentityT m) 179 | instance MonadLog message m => MonadLog message (Reader.ReaderT r m) 180 | instance MonadLog message m => MonadLog message (StrictState.StateT s m) 181 | instance MonadLog message m => MonadLog message (LazyState.StateT s m) 182 | instance (Monoid w, MonadLog message m) => MonadLog message (StrictWriter.WriterT w m) 183 | instance (Monoid w, MonadLog message m) => MonadLog message (LazyWriter.WriterT w m) 184 | instance MonadLog message m => MonadLog message (Maybe.MaybeT m) 185 | instance MonadLog message m => MonadLog message (Except.ExceptT e m) 186 | instance (Monoid w, MonadLog message m) => MonadLog message (StrictRWS.RWST r w s m) 187 | instance (Monoid w, MonadLog message m) => MonadLog message (LazyRWS.RWST r w s m) 188 | instance MonadLog message m => MonadLog message (Cont.ContT r m) 189 | instance (Functor f, MonadLog message m) => MonadLog message (Free.FreeT f m) 190 | instance (Functor f, MonadLog message m) => MonadLog message (Free.FT f m) 191 | instance MonadLog message m => MonadLog message (Exceptions.CatchT m) 192 | 193 | -------------------------------------------------------------------------------- 194 | -- | Add \"Severity\" information to a log message. This is often used to convey 195 | -- how significant a log message is. 196 | data WithSeverity a = 197 | WithSeverity {msgSeverity :: Severity -- ^ Retrieve the 'Severity' a message. 198 | ,discardSeverity :: a -- ^ View the underlying message. 199 | } 200 | deriving (Eq,Ord,Read,Show,Functor,Traversable,Foldable) 201 | 202 | -- | Classes of severity for log messages. These have been chosen to match 203 | -- @syslog@ severity levels 204 | data Severity = 205 | Emergency -- ^ System is unusable. By @syslog@ convention, this level should not be used by applications. 206 | | Alert -- ^ Should be corrected immediately. 207 | | Critical -- ^ Critical conditions. 208 | | Error -- ^ Error conditions. 209 | | Warning -- ^ May indicate that an error will occur if action is not taken. 210 | | Notice -- ^ Events that are unusual, but not error conditions. 211 | | Informational -- ^ Normal operational messages that require no action. 212 | | Debug -- ^ Information useful to developers for debugging the application. 213 | deriving (Eq,Enum,Bounded,Read,Show,Ord) 214 | 215 | instance PP.Pretty Severity where 216 | pretty = PP.pretty . LT.pack . show 217 | 218 | -- | Given a way to render the underlying message @a@, render a message with its 219 | -- severity. 220 | -- 221 | -- >>> renderWithSeverity id (WithSeverity Informational "Flux capacitor is functional") 222 | -- [Informational] Flux capacitor is functional 223 | renderWithSeverity 224 | :: (a -> PP.Doc ann) -> (WithSeverity a -> PP.Doc ann) 225 | renderWithSeverity k (WithSeverity u a) = 226 | PP.brackets (PP.pretty u) PP.<+> PP.align (k a) 227 | 228 | -- | @ 229 | -- 'logDebug' = 'logMessage' . 'WithSeverity' 'Debug' 230 | -- @ 231 | logDebug :: MonadLog (WithSeverity a) m => a -> m () 232 | logDebug = logMessage . WithSeverity Debug 233 | {-# INLINEABLE logDebug #-} 234 | 235 | -- | @ 236 | -- 'logInfo' = 'logMessage' . 'WithSeverity' 'Informational' 237 | -- @ 238 | logInfo :: MonadLog (WithSeverity a) m => a -> m () 239 | logInfo = logMessage . WithSeverity Informational 240 | {-# INLINEABLE logInfo #-} 241 | 242 | -- | @ 243 | -- 'logNotice' = 'logMessage' . 'WithSeverity' 'Notice' 244 | -- @ 245 | logNotice :: MonadLog (WithSeverity a) m => a -> m () 246 | logNotice = logMessage . WithSeverity Notice 247 | {-# INLINEABLE logNotice #-} 248 | 249 | -- | @ 250 | -- 'logWarning' = 'logMessage' . 'WithSeverity' 'Warning' 251 | -- @ 252 | logWarning :: MonadLog (WithSeverity a) m => a -> m () 253 | logWarning = logMessage . WithSeverity Warning 254 | {-# INLINEABLE logWarning #-} 255 | 256 | -- | @ 257 | -- 'logError' = 'logMessage' . 'WithSeverity' 'Error' 258 | -- @ 259 | logError :: MonadLog (WithSeverity a) m => a -> m () 260 | logError = logMessage . WithSeverity Error 261 | {-# INLINEABLE logError #-} 262 | 263 | -- | @ 264 | -- 'logCritical' = 'logMessage' . 'WithSeverity' 'Critical' 265 | -- @ 266 | logCritical :: MonadLog (WithSeverity a) m => a -> m () 267 | logCritical = logMessage . WithSeverity Critical 268 | {-# INLINEABLE logCritical #-} 269 | 270 | -- | @ 271 | -- 'logAlert' = 'logMessage' . 'WithSeverity' 'Alert' 272 | -- @ 273 | logAlert :: MonadLog (WithSeverity a) m => a -> m () 274 | logAlert = logMessage . WithSeverity Alert 275 | {-# INLINEABLE logAlert #-} 276 | 277 | -- | @ 278 | -- 'logEmergency' = 'logMessage' . 'WithSeverity' 'Emergency' 279 | -- @ 280 | logEmergency :: MonadLog (WithSeverity a) m => a -> m () 281 | logEmergency = logMessage . WithSeverity Emergency 282 | {-# INLINEABLE logEmergency #-} 283 | 284 | -------------------------------------------------------------------------------- 285 | -- | Add a timestamp to log messages. 286 | -- 287 | -- Note that while most log message transformers are designed to be used at the 288 | -- point of logging, this transformer is best applied within the handler. 289 | -- This is advised as timestamps are generally applied uniformly, so doing it 290 | -- in the handler is fine (no extra information or context of the program is 291 | -- required). The other reason is that logging with a timestamp requires 292 | -- 'MonadIO' - while the rest of your computation is free to use 'MonadIO', 293 | -- it's best to avoid incurring this constraint as much as possible, as it is 294 | -- generally untestable. 295 | data WithTimestamp a = 296 | WithTimestamp {discardTimestamp :: a -- ^ View the underlying message. 297 | ,msgTimestamp :: UTCTime -- ^ Retireve the time a message was logged. 298 | } 299 | deriving (Eq,Ord,Read,Show,Functor,Traversable,Foldable) 300 | 301 | -- | Given a way to render the underlying message @a@ and a way to format 302 | -- 'UTCTime', render a message with its timestamp. 303 | -- 304 | -- >>> renderWithTimestamp (formatTime defaultTimeLocale rfc822DateFormat) id timestamppedLogMessage 305 | -- [Tue, 19 Jan 2016 11:29:42 UTC] Setting target speed to plaid 306 | renderWithTimestamp :: (UTCTime -> String) 307 | -- ^ How to format the timestamp. 308 | -> (a -> PP.Doc ann) 309 | -- ^ How to render the rest of the message. 310 | -> (WithTimestamp a -> PP.Doc ann) 311 | renderWithTimestamp formatter k (WithTimestamp a t) = 312 | PP.brackets (PP.pretty (LT.pack (formatter t))) PP.<+> PP.align (k a) 313 | 314 | -- | Add the current time as a timestamp to a message. 315 | timestamp :: (MonadIO m) => a -> m (WithTimestamp a) 316 | timestamp msg = do 317 | now <- liftIO getCurrentTime 318 | pure (WithTimestamp msg now) 319 | {-# INLINEABLE timestamp #-} 320 | 321 | -------------------------------------------------------------------------------- 322 | -- | Add call stack information to log lines. 323 | -- 324 | -- This functional requires that you pass around the call stack via implicit 325 | -- parameters. For more information, see the GHC manual (section 9.14.4.5). 326 | data WithCallStack a = WithCallStack { msgCallStack :: CallStack 327 | , discardCallStack :: a } 328 | deriving (Functor,Traversable,Foldable,Show) 329 | 330 | -- | Given a way to render the underlying message @a@ render a message with a 331 | -- callstack. 332 | -- 333 | -- The callstack will be pretty-printed underneath the log message itself. 334 | renderWithCallStack :: (a -> PP.Doc ann) -> WithCallStack a -> PP.Doc ann 335 | renderWithCallStack k (WithCallStack stack msg) = 336 | k msg <> PP.line <> PP.indent 2 (prettyCallStack (getCallStack stack)) 337 | 338 | #if MIN_VERSION_base(4, 9, 0) 339 | showSrcLoc :: SrcLoc -> String 340 | showSrcLoc = prettySrcLoc 341 | #endif 342 | 343 | prettyCallStack :: [(String,SrcLoc)] -> PP.Doc ann 344 | prettyCallStack [] = "empty callstack" 345 | prettyCallStack (root:rest) = 346 | prettyCallSite root <> PP.line <> PP.indent 2 (PP.vsep (map prettyCallSite rest)) 347 | where prettyCallSite (f,loc) = 348 | PP.pretty (LT.pack f) <> ", called at " <> 349 | PP.pretty (LT.pack (showSrcLoc loc)) 350 | 351 | -- | Construct a 'WithCallStack' log message. 352 | -- 353 | -- This should normally be preferred over just using 'WithCallStack' as it will 354 | -- append a new entry to the stack - pointing to this exact log line. However, 355 | -- if you are creating a combinator (such as a wrapper that logs and throws 356 | -- an exception), you may be better manually capturing the 'CallStack' and 357 | -- using 'WithCallStack'. 358 | withCallStack :: (?stack :: CallStack) => a -> WithCallStack a 359 | withCallStack = WithCallStack ?stack 360 | 361 | -------------------------------------------------------------------------------- 362 | -- | 'LoggingT' is a very general handler for the 'MonadLog' effect. Whenever a 363 | -- log entry is emitted, the given 'Handler' is invoked, producing some 364 | -- side-effect (such as writing to @stdout@, or appending a database table). 365 | newtype LoggingT message m a = 366 | LoggingT (ReaderT (Handler m message) m a) 367 | deriving (Monad,Applicative,Functor,MonadFix,Alternative,MonadPlus,MonadIO,MonadUnliftIO,MonadWriter w,MonadCont,MonadError e,MonadMask,MonadCatch,MonadThrow,MonadState s, Fail.MonadFail) 368 | 369 | instance MonadBase b m => MonadBase b (LoggingT message m) where 370 | liftBase = lift . liftBase 371 | 372 | instance MonadBaseControl b m => MonadBaseControl b (LoggingT message m) where 373 | type StM (LoggingT message m) a = StM m a 374 | liftBaseWith runInBase = 375 | LoggingT (ReaderT (\handler -> 376 | liftBaseWith 377 | (\runInReader -> 378 | runInBase (\(LoggingT (ReaderT m)) -> 379 | runInReader (m handler))))) 380 | restoreM st = LoggingT (ReaderT (\_ -> restoreM st)) 381 | 382 | -- | Given a 'Handler' for a given @message@, interleave this 'Handler' into the 383 | -- underlying @m@ computation whenever 'logMessage' is called. 384 | runLoggingT 385 | :: LoggingT message m a -> Handler m message -> m a 386 | runLoggingT (LoggingT (ReaderT m)) handler = m handler 387 | {-# INLINEABLE runLoggingT #-} 388 | 389 | instance MonadTrans (LoggingT message) where 390 | lift = LoggingT . ReaderT . const 391 | {-# INLINEABLE lift #-} 392 | 393 | instance MonadReader r m => MonadReader r (LoggingT message m) where 394 | ask = lift ask 395 | {-# INLINEABLE ask #-} 396 | local f (LoggingT (ReaderT m)) = LoggingT (ReaderT (local f . m)) 397 | {-# INLINEABLE local #-} 398 | reader f = lift (reader f) 399 | {-# INLINEABLE reader #-} 400 | 401 | newtype Ap m = Ap { runAp :: m () } 402 | 403 | instance Applicative m => Semigroup (Ap m) where 404 | Ap l <> Ap r = Ap (l *> r) 405 | {-# INLINEABLE (<>) #-} 406 | 407 | instance Applicative m => Monoid (Ap m) where 408 | mempty = Ap (pure ()) 409 | {-# INLINEABLE mempty #-} 410 | #if !(MIN_VERSION_base(4,11,0)) 411 | Ap l `mappend` Ap r = Ap (l *> r) 412 | {-# INLINEABLE mappend #-} 413 | #endif 414 | 415 | -- | The main instance of 'MonadLog', which replaces calls to 'logMessage' with calls to a 'Handler'. 416 | instance Monad m => MonadLog message (LoggingT message m) where 417 | logMessageFree foldMap = LoggingT (ReaderT (\handler -> runAp (foldMap (Ap . handler)))) 418 | {-# INLINEABLE logMessageFree #-} 419 | 420 | instance MonadRWS r w s m => MonadRWS r w s (LoggingT message m) 421 | 422 | instance (Functor f,MonadFree f m) => MonadFree f (LoggingT message m) 423 | 424 | -- | 'LoggingT' unfortunately does admit an instance of the @MFunctor@ type 425 | -- class, which provides the @hoist@ method to change the monad underneath 426 | -- a monad transformer. However, it is possible to do this with 'LoggingT' 427 | -- provided that you have a way to re-interpret a log handler in the 428 | -- original monad. 429 | mapLoggingT :: (forall x. (Handler m message -> m x) -> (Handler n message' -> n x)) 430 | -> LoggingT message m a 431 | -> LoggingT message' n a 432 | mapLoggingT eta (LoggingT (ReaderT f)) = LoggingT (ReaderT (eta f)) 433 | {-# INLINEABLE mapLoggingT #-} 434 | 435 | -------------------------------------------------------------------------------- 436 | -- | Handlers are mechanisms to interpret the meaning of logging as an action 437 | -- in the underlying monad. They are simply functions from log messages to 438 | -- @m@-actions. 439 | type Handler m message = message -> m () 440 | 441 | -- | Options that be used to configure 'withBatchingHandler'. 442 | data BatchingOptions = 443 | BatchingOptions {flushMaxDelay :: Int -- ^ The maximum amount of time to wait between flushes 444 | ,flushMaxQueueSize :: Int -- ^ The maximum amount of messages to hold in memory between flushes} 445 | ,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. 446 | } 447 | deriving (Eq,Ord,Read,Show) 448 | 449 | -- | Defaults for 'BatchingOptions' 450 | -- 451 | -- @ 452 | -- 'defaultBatchingOptions' = 'BatchingOptions' {'flushMaxDelay' = 1000000 453 | -- ,'flushMaxQueueSize' = 100 454 | -- ,'blockWhenFull' = 'True'} 455 | -- @ 456 | defaultBatchingOptions :: BatchingOptions 457 | defaultBatchingOptions = BatchingOptions 1000000 100 True 458 | 459 | -- | Create a new batched handler. Batched handlers take batches of messages to 460 | -- log at once, which can be more performant than logging each individual 461 | -- message. 462 | -- 463 | -- A batched handler flushes under three criteria: 464 | -- 465 | -- 1. The flush interval has elapsed and the queue is not empty. 466 | -- 2. The queue has become full and needs to be flushed. 467 | -- 3. The scope of 'withBatchedHandler' is exited. 468 | -- 469 | -- Batched handlers queue size and flush period can be configured via 470 | -- 'BatchingOptions'. 471 | withBatchedHandler :: (MonadIO io,MonadMask io) 472 | => BatchingOptions 473 | -> (NEL.NonEmpty message -> IO ()) 474 | -> (Handler io message -> io a) 475 | -> io a 476 | withBatchedHandler BatchingOptions{..} flush k = 477 | do closed <- liftIO (newTVarIO False) 478 | channel <- liftIO (newTBQueueIO (fromIntegral flushMaxQueueSize)) 479 | bracket (liftIO (async (repeatWhileTrue (publish closed channel)))) 480 | (\publisher -> 481 | do liftIO (do atomically (writeTVar closed True) 482 | wait publisher)) 483 | (\_ -> 484 | k (\msg -> 485 | liftIO (atomically 486 | (writeTBQueue channel msg <|> 487 | check (not blockWhenFull))))) 488 | where repeatWhileTrue m = 489 | do again <- m 490 | if again 491 | then repeatWhileTrue m 492 | else return () 493 | publish closed channel = 494 | do flushAlarm <- newDelay flushMaxDelay 495 | (messages,stillOpen) <- 496 | atomically 497 | (do messages <- 498 | flushAfter flushAlarm <|> flushFull <|> flushOnClose 499 | stillOpen <- fmap not (readTVar closed) 500 | return (messages,stillOpen)) 501 | mapM_ flush (NEL.nonEmpty messages) 502 | pure stillOpen 503 | where flushAfter flushAlarm = 504 | do waitDelay flushAlarm 505 | isEmptyTBQueue channel >>= guard . not 506 | emptyTBQueue channel 507 | flushFull = 508 | do isFullTBQueue channel >>= guard 509 | emptyTBQueue channel 510 | flushOnClose = 511 | do readTVar closed >>= guard 512 | emptyTBQueue channel 513 | emptyTBQueue q = 514 | do mx <- tryReadTBQueue q 515 | case mx of 516 | Nothing -> return [] 517 | Just x -> fmap (x :) (emptyTBQueue q) 518 | 519 | -- | 'withFDHandler' creates a new 'Handler' that will append a given file 520 | -- descriptor (or 'Handle', as it is known in the "base" library). Note that 521 | -- this 'Handler' requires log messages to be of type 'PP.Doc'. This abstractly 522 | -- specifies a pretty-printing for log lines. The two arguments two 523 | -- 'withFDHandler' determine how this pretty-printing should be realised 524 | -- when outputting log lines. 525 | -- 526 | -- These 'Handler's asynchronously log messages to the given file descriptor, 527 | -- rather than blocking. 528 | withFDHandler 529 | :: (MonadIO io,MonadMask io) 530 | => BatchingOptions 531 | -> Handle -- ^ The 'Handle' to write log messages to. 532 | -> Double -- ^ The @ribbonFrac@ parameter to 'PP.renderPretty' 533 | -> Int -- ^ The amount of characters per line. Lines longer than this will be pretty-printed across multiple lines if possible. 534 | -> (Handler io (PP.Doc ann) -> io a) 535 | -> io a 536 | withFDHandler options fd ribbonFrac width = withBatchedHandler options flush 537 | where 538 | flush messages = do 539 | PP.renderIO 540 | fd 541 | (PP.layoutPretty 542 | (PP.LayoutOptions (PP.AvailablePerLine width ribbonFrac)) 543 | (PP.vsep (NEL.toList messages) <> PP.line')) 544 | hFlush fd 545 | 546 | -------------------------------------------------------------------------------- 547 | -- | A 'MonadLog' handler optimised for pure usage. Log messages are accumulated 548 | -- strictly, given that messages form a 'Monoid'. 549 | newtype PureLoggingT log m a = MkPureLoggingT (StateT log m a) 550 | deriving (Functor,Applicative,Monad,MonadFix,MonadCatch,MonadThrow,MonadIO,MonadMask,MonadReader r,MonadWriter w,MonadCont,MonadError e,Alternative,MonadPlus,Fail.MonadFail) 551 | 552 | instance MonadBase b m => MonadBase b (PureLoggingT message m) where 553 | liftBase = lift . liftBase 554 | 555 | instance MonadTransControl (PureLoggingT message) where 556 | type StT (PureLoggingT message) a = StT (StateT message) a 557 | liftWith = defaultLiftWith MkPureLoggingT (\(MkPureLoggingT m) -> m) 558 | restoreT = defaultRestoreT MkPureLoggingT 559 | 560 | instance MonadBaseControl b m => MonadBaseControl b (PureLoggingT message m) where 561 | type StM (PureLoggingT message m) a = ComposeSt (PureLoggingT message) m a 562 | liftBaseWith = defaultLiftBaseWith 563 | restoreM = defaultRestoreM 564 | 565 | -- | Run a computation with access to logging by accumulating a log under its 566 | -- 'Monoid' instance. 567 | runPureLoggingT 568 | :: Monoid log 569 | => PureLoggingT log m a -> m (a,log) 570 | runPureLoggingT (MkPureLoggingT (StateT m)) = m mempty 571 | {-# INLINEABLE runPureLoggingT #-} 572 | 573 | mkPureLoggingT 574 | :: (Monad m,Monoid log) 575 | => m (a,log) -> PureLoggingT log m a 576 | mkPureLoggingT m = 577 | MkPureLoggingT 578 | (StateT (\s -> 579 | do (a,l) <- m 580 | return (a,mappend s l))) 581 | {-# INLINEABLE mkPureLoggingT #-} 582 | 583 | instance MonadTrans (PureLoggingT log) where 584 | lift = MkPureLoggingT . lift 585 | {-# INLINEABLE lift #-} 586 | 587 | instance (Functor f, MonadFree f m) => MonadFree f (PureLoggingT log m) 588 | 589 | -- | A pure handler of 'MonadLog' that accumulates log messages under the structure of their 'Monoid' instance. 590 | instance (Monad m, Monoid log) => MonadLog log (PureLoggingT log m) where 591 | logMessageFree foldMap = mkPureLoggingT (return ((), foldMap id)) 592 | {-# INLINEABLE logMessageFree #-} 593 | 594 | instance MonadRWS r w s m => MonadRWS r w s (PureLoggingT message m) 595 | 596 | instance MonadState s m => MonadState s (PureLoggingT log m) where 597 | state f = lift (state f) 598 | {-# INLINEABLE state #-} 599 | get = lift get 600 | {-# INLINEABLE get #-} 601 | put = lift . put 602 | {-# INLINEABLE put #-} 603 | 604 | -------------------------------------------------------------------------------- 605 | -- | A 'MonadLog' handler that throws messages away. 606 | -- 607 | -- The documentation may appear a bit confusing, but note that the full type of 608 | -- 'discardLogging' is: 609 | -- 610 | -- @ 611 | -- 'discardLogging' :: 'DiscardLoggingT' message m a -> m a 612 | -- @ 613 | newtype DiscardLoggingT message m a = 614 | DiscardLoggingT {discardLogging :: m a -- ^ Run a 'MonadLog' computation by throwing away all log requests. 615 | } 616 | deriving (Functor,Applicative,Monad,MonadFix,MonadCatch,MonadThrow,MonadIO,MonadUnliftIO,MonadMask,MonadReader r,MonadWriter w,MonadCont,MonadError e,Alternative,MonadPlus,MonadState s,MonadRWS r w s,MonadBase b,Fail.MonadFail) 617 | 618 | instance MonadBaseControl b m => MonadBaseControl b (DiscardLoggingT message m) where 619 | type StM (DiscardLoggingT message m) a = StM m a 620 | liftBaseWith runInBase = lift (liftBaseWith (\runInOrig -> runInBase (runInOrig . discardLogging))) 621 | restoreM = lift . restoreM 622 | 623 | instance MonadTrans (DiscardLoggingT message) where 624 | lift = DiscardLoggingT 625 | {-# INLINEABLE lift #-} 626 | 627 | instance (Functor f,MonadFree f m) => MonadFree f (DiscardLoggingT message m) 628 | 629 | -- | The trivial instance of 'MonadLog' that simply discards all messages logged. 630 | instance Monad m => MonadLog message (DiscardLoggingT message m) where 631 | logMessageFree _ = return () 632 | {-# INLINEABLE logMessageFree #-} 633 | 634 | {- $intro 635 | 636 | @logging-effect@ provides a toolkit for general logging in Haskell programs 637 | and libraries. The library consists of the type class 'MonadLog' to add log 638 | output to computations, and this library comes with a set of instances to help 639 | you decide how this logging should be performed. There are predefined handlers 640 | to write to file handles, to accumulate logs purely, or to discard logging 641 | entirely. 642 | 643 | Unlike other logging libraries available on Hackage, 'MonadLog' does /not/ 644 | assume that you will be logging text information. Instead, the choice of logging 645 | data is up to you. This leads to a highly compositional form of logging, with 646 | the ability to reinterpret logs into different formats, and avoid throwing 647 | information away if your final output is structured (such as logging to a 648 | relational database). 649 | 650 | -} 651 | 652 | {- $tutorialIntro 653 | 654 | @logging-effect@ is designed to be used via the 'MonadLog' type class and 655 | encourages an "mtl" style approach to programming. If you're not familiar with 656 | the @mtl@, this approach uses type classes to keep the choice of monad 657 | polymorphic as you program, and you later choose a specific monad transformer 658 | stack when you execute your program. For more information, see 659 | <#tutorialMtl Aside: An mtl refresher>. 660 | 661 | -} 662 | 663 | {- $tutorialMtl #tutorialMtl# 664 | 665 | If you are already familiar with the @mtl@ you can skip this section. This is not 666 | designed to be an exhaustive introduction to the @mtl@ library, but hopefully 667 | via a short example you'll have a basic familarity with the approach. 668 | 669 | In this example, we'll write a program with access to state and general 'IO' 670 | actions. One way to do this would be to work with monad transformers, stacking 671 | 'StateT' on top of 'IO': 672 | 673 | @ 674 | import "Control.Monad.Trans.State.Strict" ('StateT', 'get', 'put') 675 | import "Control.Monad.Trans.Class" ('lift') 676 | 677 | transformersProgram :: 'StateT' 'Int' 'IO' () 678 | transformersProgram = do 679 | stateNow <- 'get' 680 | 'lift' launchMissles 681 | 'put' (stateNow + 42) 682 | @ 683 | 684 | This is OK, but it's not very flexible. For example, the transformers library 685 | actually provides us with two implementations of state monads - strict and a 686 | lazy variant. In the above approach we have forced the user into a choice (we 687 | chose the strict variant), but this can be undesirable. We could imagine that 688 | in the future there may be even more implementations of state monads (for 689 | example, a state monad that persists state entirely on a remote machine) - if 690 | requirements change we are unable to reuse this program without changing its 691 | type. 692 | 693 | With the @mtl@, we instead program to an /abstract specification/ of the effects 694 | we require, and we postpone the choice of handler until the point when the 695 | computation is ran. 696 | 697 | Rewriting the @transformersProgram@ using the @mtl@, we have the following: 698 | 699 | @ 700 | import "Control.Monad.State.Class" ('MonadState'('get', 'put')) 701 | import "Control.Monad.IO.Class" ('MonadIO'('liftIO')) 702 | 703 | mtlProgram :: ('MonadState' 'Int' m, 'MonadIO' m) => m () 704 | mtlProgram = do 705 | stateNow <- 'get' 706 | 'liftIO' launchMissles 707 | 'put' (stateNow + 42) 708 | @ 709 | 710 | Notice that @mtlProgram@ doesn't specify a concrete choice of state monad. The 711 | "transformers" library gives us two choices - strict or lazy state monads. We 712 | make the choice of a specific monad stack when we run our program: 713 | 714 | @ 715 | import "Control.Monad.Trans.State.Strict" ('execStateT') 716 | 717 | main :: 'IO' () 718 | main = 'execStateT' mtlProgram 99 719 | @ 720 | 721 | Here we chose the strict variant via 'execStateT'. Using 'execStateT' 722 | /eliminates/ the 'MonadState' type class from @mtlProgram@, so now we only have 723 | to fulfill the 'MonadIO' obligation. There is only one way to handle this, and 724 | that's by working in the 'IO' monad. Fortunately we're inside the @main@ 725 | function, which is in the 'IO' monad, so we're all good. 726 | 727 | -} 728 | 729 | {- $tutorial-monadlog 730 | 731 | To add logging to your applications, you will need to make two changes. 732 | 733 | First, use the 'MonadLog' type class to indicate that a computation has 734 | access to logging. 'MonadLog' is parameterized on the type of messages 735 | that you intend to log. In this example, we will log a 'PP.Doc' that is 736 | wrapped in 'WithSeverity'. 737 | 738 | @ 739 | testApp :: 'MonadLog' ('WithSeverity' ('PP.Doc' ann)) m => m () 740 | testApp = do 741 | logMessage ('WithSeverity' 'Informational' "Don't mind me") 742 | logMessage ('WithSeverity' 'Error' "But do mind me!") 743 | @ 744 | 745 | Note that this does /not/ specify where the logs "go", we'll address that when 746 | we run the program. 747 | 748 | -} 749 | 750 | {- $tutorial-loggingt 751 | 752 | Next, we need to run this computation under a 'MonadLog' effect handler. The 753 | most flexible handler is 'LoggingT'. 'LoggingT' runs a 'MonadLog' computation 754 | by providing it with a 'Handler', which is a computation that can be in the 755 | underlying monad. 756 | 757 | For example, we can easily fulfill the 'MonadLog' type class by just using 758 | 'print' as our 'Handler': 759 | 760 | >>> runLoggingT testApp print 761 | WithSeverity {msgSeverity = Informational, discardSeverity = "Don't mind me"} 762 | WithSeverity {msgSeverity = Error, discardSeverity = "But do mind me!"} 763 | 764 | The log messages are printed according to their 'Show' instances, and - while 765 | this works - it is not particularly user friendly. As 'Handler's are just functions 766 | from log messages to monadic actions, we can easily reformat log messages. 767 | @logging-effect@ comes with a few "log message transformers" (such as 768 | 'WithSeverity'), and each of these message transformers has a canonical way to 769 | render in a human-readable format: 770 | 771 | >>> runLoggingT testApp (print . renderWithSeverity id) 772 | [Informational] Don't mind me 773 | [Error] But do mind me! 774 | 775 | That's looking much more usable - and in fact this approach is probably fine for 776 | command line applications. 777 | 778 | However, for longer running high performance applications there is a slight 779 | problem. Remember that 'runLoggingT' simply interleaves the given 'Handler' 780 | whenever 'logMessage' is called. By providing 'print' as a 'Handler', our 781 | application will actually block until the log is complete. This is undesirable 782 | for high performance applications, where it's much better to log asynchronously. 783 | 784 | @logging-effect@ comes with "batched handlers" for this problem. Batched handlers 785 | are handlers that log asynchronously, are flushed periodically, and have maximum 786 | memory impact. Batched handlers are created with 'withBatchedHandler', though 787 | if you are just logging to file descriptors you can also use 'withFDHandler'. 788 | We'll use this next to log to @STDOUT@: 789 | 790 | @ 791 | main :: 'IO' () 792 | main = 793 | 'withFDHandler' 'defaultBatchingOptions' 'stdout' 0.4 80 $ \\logToStdout -> 794 | 'runLoggingT' testApp ('logToStdout' . 'renderWithSeverity' 'id') 795 | @ 796 | 797 | Finally, as 'Handler's are just functions (we can't stress this enough!) you 798 | are free to slice-and-dice your log messages however you want. As our log 799 | messages are structured, we can pattern match on the messages and dispatch them 800 | to multiple handlers. In this final example of using 'LoggingT' we'll split 801 | our log messages between @STDOUT@ and @STDERR@, and change the formatting of 802 | error messages: 803 | 804 | @ 805 | main :: IO () 806 | main = do 807 | 'withFDHandler' 'defaultBatchingOptions' 'stderr' 0.4 80 $ \\stderrHandler -> 808 | 'withFDHandler' 'defaultBatchingOptions' 'stdout' 0.4 80 $ \\stdoutHandler -> 809 | 'runLoggingT' testApp 810 | (\\message -> 811 | case 'msgSeverity' message of 812 | 'Error' -> stderrHandler ('discardSeverity' message) 813 | _ -> stdoutHandler ('renderWithSeverity' id message)) 814 | @ 815 | 816 | >>> main 817 | [Informational] Don't mind me! 818 | BUT DO MIND ME! 819 | 820 | -} 821 | 822 | {- $tutorial-composing 823 | 824 | So far we've considered very small applications where all log messages fit nicely 825 | into a single type. However, as applications grow and begin to reuse components, 826 | it's unlikely that this approach will scale. @logging-effect@ comes with a 827 | mapping function - 'mapLogMessage' - which allows us to map log messages from one 828 | type to another (just like how we can use 'map' to change elements of a list). 829 | 830 | For example, we've already seen the basic @testApp@ computation above that used 831 | 'WithSeverity' to add severity information to log messages. Elsewhere we might 832 | have some older code that doesn't yet have any severity information: 833 | 834 | @ 835 | legacyCode :: 'MonadLog' ('PP.Doc' ann) m => m () 836 | legacyCode = 'logMessage' "Does anyone even remember writing this function?" 837 | @ 838 | 839 | Here @legacyCode@ is only logging 'PP.Doc', while our @testApp@ is logging 840 | 'WithSeverity' 'PP.Doc'. What happens if we compose these programs? 841 | 842 | >>> :t runLoggingT (testApp >> legacyCode) (const (pure ())) 843 | Couldn't match type ‘WithSeverity (Doc ann1)’ with '(Doc ann0)' 844 | 845 | Whoops! 'MonadLog' has /functional dependencies/ on the type class which means 846 | that there can only be a single way to log per monad. One solution might be 847 | to 'lift' one set of logs into the other: 848 | 849 | >>> :t runLoggingT (testApp >> lift legacyCode) (const (pure ())) 850 | :: MonadLog (Doc ann) m => m () 851 | 852 | And indeed, this is /a/ solution, but it's not a particularly nice one. 853 | 854 | Instead, we can map both of these computations into a common log format: 855 | 856 | >>> :t mapLogMessage Left testApp >> mapLogMessage Right (logMessage "Hello") 857 | :: (MonadLog (Either (WithSeverity (Doc ann)) (Doc ann)) m) => m () 858 | 859 | This is a trivial way of combining two different types of log message. In larger 860 | applications you will probably want to define a new sum-type that combines all of 861 | your log messages, and generally sticking with a single log message type per 862 | application. 863 | 864 | -} 865 | 866 | {- $convenience 867 | 868 | While @logging-effect@ tries to be as general as possible, there is a fairly 869 | common case of logging, namely basic messages with an indication of severity. 870 | These combinators assume that you will be using 'WithSeverity' at the outer-most 871 | level of your log message stack, though no make no assumptions at what is inside 872 | your log messages. There is a @logX@ combinator for each level in 'Severity'. 873 | 874 | -} 875 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.5 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | --------------------------------------------------------------------------------