lumberjack (empty) → 0.1.0.0
raw patch · 6 files changed
+716/−0 lines, 6 filesdep +basedep +contravariantdep +exceptionssetup-changed
Dependencies added: base, contravariant, exceptions, lumberjack, mtl, prettyprinter, prettyprinter-ansi-terminal, text, time
Files
- CHANGELOG.md +5/−0
- LICENSE +13/−0
- Setup.hs +2/−0
- example/ExampleLog.hs +183/−0
- lumberjack.cabal +66/−0
- src/Lumberjack.hs +447/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for lumberjack++## 0.1.0.0 -- 2020-02-13++* Initial Lumberjack logger implementation, based on internal usage.
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright (c) 2020 Galois Inc.++Permission to use, copy, modify, and/or distribute this software for any purpose+with or without fee is hereby granted, provided that the above copyright notice+and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE COPYRIGHT HOLDER DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS+OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER+TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF+THIS SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/ExampleLog.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Monad.Reader+import Data.Functor.Contravariant+import Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Control.Monad.Catch as X+import Lumberjack+import System.IO ( stderr )++----------------------------------------------------------------------+-- Base example:++instance HasLog T.Text IO where+ -- The base IO monad does not have direct "storage" ability in the+ -- monad itself, so it can really only support basic/default+ -- operations which preclude some of the ancillary techniques such+ -- as adding tags automatically. Lumberjack provides some default+ -- functions to support logging directly in the IO monad if this is+ -- desired.+ getLogAction = return defaultGetIOLogAction++exampleTextLoggingInIO :: IO ()+exampleTextLoggingInIO = do+ writeLogM $ T.pack "This is a logged text message in base IO"++ -- In situations where the current monad doesn't provide the log+ -- action, it's possible to provide that directly:++ let myLogAction = LogAction TIO.putStrLn+ writeLog myLogAction $ T.pack "This is another text message, logged in IO with a custom action"+++----------------------------------------------------------------------+-- Example 2: Logging strings using a contramapped converter++instance HasLog [Char] IO where+ -- The defaultGetIOLogAction logs Text, but if the code needed to+ -- log Strings, the contramap functionality can be used to simplify+ -- the adaptation of the existing logger to a new input type.+ getLogAction = return $ T.pack >$< defaultGetIOLogAction++exampleStringLoggingInIO :: IO ()+exampleStringLoggingInIO = do+ writeLogM ("This is a logged string message in base IO" :: String)+ -- example of adjust+++----------------------------------------------------------------------+-- Example 3: Storing the LogAction in a local monad stack++type ReaderEnv = LogAction MyMonad T.Text++newtype MyMonad a = MyMonad { runMyMonad :: ReaderT ReaderEnv IO a }+ deriving ( Applicative, Functor, Monad, MonadReader ReaderEnv, MonadIO )++instance HasLog T.Text MyMonad where+ getLogAction = ask++instance LoggingMonad T.Text MyMonad where+ adjustLogAction = local++exampleStringLoggingInMyMonad :: MyMonad ()+exampleStringLoggingInMyMonad = do+ writeLogM $ T.pack "This is a logged string message in MyMonad"+ adjustLogAction (contramap (("LOG> " :: T.Text) <>)) $ do+ writeLogM $ T.pack "The logger message can be adjusted"+++----------------------------------------------------------------------+-- Example 4: Logging information-rich message objects. Lumberjack+-- helpfully provides a common rich message object. Other message+-- objects can be defined and logged, but the Lumberjack LogMessage+-- attempts to provide a useful set of functionality so that a custom+-- msg type is frequently unnecessary.++type ReaderEnv2 = LogAction MyMonad2 LogMessage++newtype MyMonad2 a = MyMonad2 { runMyMonad2 :: ReaderT ReaderEnv2 IO a }+ deriving ( Applicative, Functor, Monad, MonadReader ReaderEnv2+ , X.MonadThrow, X.MonadCatch, MonadIO )++instance HasLog LogMessage MyMonad2 where+ getLogAction = ask++instance LoggingMonad LogMessage MyMonad2 where+ adjustLogAction = local++-- The above is sufficient to log LogMessage objects, but for+-- convenience, Text can be logged directly as well, using the+-- conversion builtin here.+instance HasLog T.Text MyMonad2 where+ getLogAction = asks $ contramap textToLogMessage+ where+ textToLogMessage t = msgWith { logText = t, logLevel = Info }+++exampleStringLoggingInMyMonad2 :: MyMonad2 ()+exampleStringLoggingInMyMonad2 = do+ writeLogM $ msgWith { logText = "This is a logged string message in MyMonad" }+ -- withLogTag is a helper to set the logTags field for subsequently logged messages+ withLogTag "loc" "inner" $ do+ writeLogM $ msgWith { logText = "doing stuff..." }+ withLogTag "style" "(deep)" $ do+ writeLogM $ msgWith { logText = "deep thinking",+ logLevel = Info+ }+ -- There's also a HasLog for simple messages in this monad+ writeLogM $ ("Text messages can be logged as well" :: T.Text)+ logFunctionCallM "invoking subFunction" $ subFunction+ logProgressM "making good progress"+ writeLogM $ msgWith { logText = "Done now", logLevel = Warning }++subFunction :: (WithLog LogMessage m, Monad m) => m ()+subFunction =+ writeLogM $ msgWith { logText = "subFunction executing" }++----------------------------------------------------------------------++main = do+ exampleTextLoggingInIO+ exampleStringLoggingInIO++ -- The monad stack can just use the regular IO logging action+ -- because the monad stack has MonadIO.+ runReaderT (runMyMonad exampleStringLoggingInMyMonad) defaultGetIOLogAction++ -- Or something different could be configured... without changing+ -- the target code doing the logging+ -- (e.g. exampleStringLoggingInMyMonad).+ runReaderT (runMyMonad exampleStringLoggingInMyMonad) $+ LogAction $ liftIO . \m -> do putStr "LOGMSG << "+ TIO.putStr m+ putStrLn " >>"++ -- Richer messages allow for more detailed information. Of+ -- particular interest, the target code identifies the information+ -- relative to the code (like the severity of the message) but the+ -- handler sets the time of log and performs the conversion from the+ -- LogMessage to the Text that can be output by the base logger used.+ let richStderrLogger = addLogActionTime $+ cvtLogMessageToANSITermText >$< defaultGetIOLogAction+ writeLogM ("** Example of rich message logging" :: String)+ runReaderT (runMyMonad2 exampleStringLoggingInMyMonad2) richStderrLogger+++ -- Sometimes it's convenient to send log output to multiple sources.+ -- In this example, warnings and above are logged to the console,+ -- but all messages are logged to a file (without ANSI terminal+ -- color codes). Again, note that the target code containing the+ -- logging code does not change, only the logger configuration here.+ --+ -- Note that the `cvtLogMessage...` functions are provided by+ -- Lumberjack for a standard method of formatting the LogMessage+ -- supported by Lumberjack. It's possible to write entirely+ -- different formatting functions for the LogMessage and use those+ -- instead.+ --+ -- It's also a good idea to use the `safeLogAction` wrapper to+ -- ensure that exceptions generated by the Logger simply cause log+ -- messages to be discarded rather than causing failure of the+ -- entire application.+ let consoleLogger = logFilter (\m -> Warning <= logLevel m ) $+ cvtLogMessageToANSITermText >$<+ defaultGetIOLogAction+ fileLogger = safeLogAction $+ addLogActionTime $+ cvtLogMessageToPlainText >$<+ LogAction (liftIO . TIO.appendFile "./example.log" . flip (<>) "\n")+ failingLogger = safeLogAction $ -- remove this and the app will exit prematurely+ addLogActionTime $+ cvtLogMessageToPlainText >$<+ LogAction (liftIO . TIO.appendFile "/bogus/location/to/log/to" . flip (<>) "\n")+ writeLogM ("** Example of rich message logging to multiple outputs (see ./example.log)" :: String)+ runReaderT (runMyMonad2 exampleStringLoggingInMyMonad2) $+ consoleLogger <> failingLogger <> fileLogger++ putStrLn "end of example"
+ lumberjack.cabal view
@@ -0,0 +1,66 @@+cabal-version: >=1.10+name: lumberjack+version: 0.1.0.0+synopsis: Trek through your code forest and make logs+description: This is a logging facility. Yes, there are many, and this is the one+ with a beard, wearing flannel and boots, that gets the job done. It's+ not the fanciest, it doesn't have a cargo-van full of features. This+ logger is designed to be straightforward to use, provide a good set of+ standard features, and be useable across a broad set of code.+ .+ * Logging is a monadic activity. This activity is most often+ performed in a monad stack with a MonadIO context to allow+ writing to files.+ . + * The specific logging action implementaions are managed separately+ from the actions of logging messages in the target code. This+ allows logging to be configurable and the manner of logging to+ be specified at startup time without requiring changes in the+ code from which log messages are being generated.+ .+ * The logging implementation code can use cofunctors to adjust+ existing logging.+ .+ * Main code will typically retrieve the logging actions from a+ Reader context in your monad stack.+ .+ * The prettyprinter package is used for formatting.+ +homepage: https://github.com/GaloisInc/lumberjack+bug-reports: https://github.com/GaloisInc/lumberjack/issues+license: ISC+license-file: LICENSE+author: Kevin Quick+maintainer: kquick@galois.com+copyright: 2020, Galois Inc.+category: Logging+build-type: Simple+extra-source-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/GaloisInc/lumberjack.git++library+ hs-source-dirs: src+ exposed-modules: Lumberjack+ build-depends: base >=4.12 && <4.16+ , contravariant+ , exceptions+ , mtl+ , prettyprinter+ , prettyprinter-ansi-terminal+ , text+ , time+ default-language: Haskell2010++executable example_log+ hs-source-dirs: example+ main-is: ExampleLog.hs+ default-language: Haskell2010+ build-depends: base+ , exceptions+ , lumberjack+ , mtl+ , prettyprinter+ , text
+ src/Lumberjack.hs view
@@ -0,0 +1,447 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-------------------------------------------+-- |+-- Module : Lumberjack+-- Copyright : (c) Galois Inc. 2020+-- Maintainer : kquick@galois.com+-- Stability : experimental+-- Portability : POSIX+-- |+--+-- This module defines a general logging facility that can be used to+-- output log messages to various targets.+-------------------------------------------++module Lumberjack+ ( -- * Interface for Logging+ LogAction(..)+ , HasLog(..)+ , LoggingMonad(..)+ , writeLogM+ -- * Logging Utilities+ , safeLogAction+ , logFilter+ -- * Default LogMessage+ , Severity(..)+ , LogType(..)+ , LogMessage(..)+ , msgWith+ , WithLog+ , withLogTag+ , addLogActionTime+ -- * Output formatting for LogMessage+ , cvtLogMessageToPlainText+ , cvtLogMessageToANSITermText+ -- * Helpers and convenience functions+ , logFunctionCall, logFunctionCallM+ , logProgress, logProgressM+ , tshow+ , defaultGetIOLogAction+ )+where++import qualified Control.Monad.Catch as X+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divisible+import Data.Monoid hiding ( (<>) )+import Data.Semigroup+import Data.Text ( Text, pack, empty )+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Data.Text.Prettyprint.Doc as PP+import qualified Data.Text.Prettyprint.Doc.Render.Terminal as PP_Term+import qualified Data.Text.Prettyprint.Doc.Render.Text as PP_Text+import Data.Time.Clock ( UTCTime(..), getCurrentTime, diffUTCTime )+import Data.Time.Format ( defaultTimeLocale, formatTime )+import Data.Void+import System.IO ( stderr )++import Prelude+++-- ----------------------------------------------------------------------+-- * Interface for Logging+--+-- The 'LogAction' is the fundamental operation that decides how to+-- log a provided message.+--+-- Code wishing to output a logged message simply uses the LogAction+-- object:+--+-- > writeLog action msg+--+-- For convenience, the LogAction can be stored in the local operating+-- monad context, from which it can be retrieved (and modified). A+-- monad which can supply a LogAction is a member of the HasLog class,+-- and the 'writeLogM' function will automatically retrieve the+-- LogAction from the monad and write to it:+--+-- > writeLogM msg+--+-- LogActions can be combined via Semigroup operations (<>) and the+-- resulting LogAction will perform both actions with each message.+-- The Monoidal mempty LogAction simply does nothing. For example,+-- logging to both a file and stdout can be done by @logToFile <>+-- logToStdout@.+--+-- LogActions are also Contravariant (and Divisible and Decidable) to+-- allow easy conversion of a LogAction for the base message type into+-- a LogAction for a different message type (or types) that can be+-- converted to (and combined into) the base message type.++-- | The LogAction holds the ability to log a message of type 'msg'+-- (the second parameter) via a monad 'm' (the first parameter).+--+-- LogActions are semigroup and monoid combineable, which results in+-- both LogActions being taken (or no action in the case of mempty),+-- and contravariant to allow the msg to be modified via function+-- prior to being logged (as well as Divisible and Decidable).+newtype LogAction m msg = LogAction { writeLog :: msg -> m () }++instance Applicative m => Semigroup (LogAction m a) where+ LogAction a1 <> LogAction a2 = LogAction $ \a -> a1 a *> a2 a++instance Applicative m => Monoid (LogAction m a) where+ mappend = (<>)+ mempty = LogAction $ \_ -> pure ()++instance Contravariant (LogAction m) where+ contramap f (LogAction a) = LogAction $ a . f++instance (Applicative m) => Divisible (LogAction m) where+ conquer = LogAction $ \_ -> pure ()+ divide splitf lLog rLog = LogAction $ \i ->+ let (l, r) = splitf i+ ll = writeLog lLog l+ rl = writeLog rLog r+ in ll *> rl++instance (Applicative m) => Decidable (LogAction m) where+ lose f = LogAction $ \a -> absurd (f a)+ choose split l r = LogAction $ either (writeLog l) (writeLog r) . split++-- | Any monad which will support retrieving or adjusting a LogAction+-- must support the 'HasLog' class.+class Monad m => HasLog msg m where+ getLogAction :: m (LogAction m msg)++class (Monad m, HasLog msg m) => LoggingMonad msg m where+ adjustLogAction :: (forall k. LogAction k msg -> LogAction k msg) -> m a -> m a+++-- | This invokes the LogAction's logging handler in a monadic context+-- where the logging handler can be retrieved via the 'HasLog' class's+-- 'getLogAction' function.+writeLogM :: HasLog msg m => msg -> m ()+writeLogM m = getLogAction >>= flip writeLog m+++----------------------------------------------------------------------+-- * LogAction Utilities+--+-- The following utility functions can be used to adjust or wrap+-- LogActions to provide additional functionality.++-- | Ensures that the LogAction does not fail if the logging operation+-- itself throws an exception (the exception is ignored).+safeLogAction :: X.MonadCatch m => LogAction m msg -> LogAction m msg+safeLogAction a = LogAction $ \m -> X.catch (writeLog a m) (\(_ex :: X.SomeException) -> return ())++-- | The logFilter can be used on a LogAction to determine which+-- messages the LogAction should be invoked for (only those for which+-- the filter function returns True).+logFilter :: Applicative m => (msg -> Bool) -> LogAction m msg -> LogAction m msg+logFilter f (LogAction l) = LogAction $ \m -> when (f m) (l m)++++----------------------------------------------------------------------+-- * Default LogMessage+--+-- This is the default 'msg' type for the LogAction, containing the+-- various information associated with the logging to be performed.++-- | The Severity indicates the relative importance of the logging+-- message. This can be useful for filtering log messages.+data Severity = Debug | Info | Warning | Error deriving (Ord, Eq, Show)++-- | The LogType indicates what type of message this is. These are+-- printed on the log line and can be used for filtering different+-- types of log messages.+data LogType = Progress | FuncEntry | FuncExit | MiscLog | UserOp+ deriving (Eq, Show)++-- | Each logged output is described by a LogMessage object.+data LogMessage = LogMessage { logType :: LogType+ , logLevel :: Severity+ , logTime :: UTCTime+ , logTags :: [(Text, Text)]+ , logText :: Text+ }++instance Semigroup LogMessage where+ a <> b = LogMessage { logType = if logType a == MiscLog then logType b else logType a+ , logLevel = max (logLevel a) (logLevel b)+ , logTime = max (logTime a) (logTime b)+ , logTags = logTags a <> logTags b+ , logText = case (T.null (logText a), T.null (logText b)) of+ (False, False) -> logText a <> "; " <> logText b+ (True, False) -> logText b+ _ -> logText a+ }++instance Monoid LogMessage where+ mempty = LogMessage MiscLog Debug (UTCTime (toEnum 0) (toEnum 0)) [] empty+ mappend = (<>)++-- | Helper routine to return an empty LogMessage, whose fields can+-- then be updated.+msgWith :: LogMessage+msgWith = mempty+++-- | Add the current timestamp to the LogMessage being logged+addLogActionTime :: MonadIO m => LogAction m LogMessage -> LogAction m LogMessage+addLogActionTime a = LogAction $ \m -> do t <- liftIO getCurrentTime+ writeLog a $ m <> mempty { logTime = t }+++-- | This type is a Constraint that should be applied to any client+-- function that will perform logging in a monad context. The 'msg'+-- is the type of message that will be logged, and the 'm' is the+-- monad under which the logging is performed.+type WithLog msg m = ({- X.MonadCatch m, -} HasLog msg m)+++-- | Log messages can have any number of key/value tags applied to+-- them. This function establishes a new key/value tag pair that will+-- be in effect for the monadic operation passed as the third+-- argument.+-- withLogTag tname tval op = local (adjustLogAction $ addLogTag tname tval) op+withLogTag :: (LoggingMonad LogMessage m) => Text -> Text -> m a -> m a+withLogTag tname tval op =+ let tagmsg = mempty { logTags = [(tname, tval)] }+ in (adjustLogAction $ contramap (tagmsg <>)) op+++-- ----------------------------------------------------------------------+-- * Output formatting for LogMessage+--+-- Optimal LogMessage formatting uses prettyprinter output with a+-- 'PrettyLogAnn' annotation type which assigns different annotations+-- to different parts of the log message. This is achieved by calling+-- 'prettyLogMessage'.+--+-- Alternatively, the 'Pretty' class 'pretty'+-- method can be used to get log message formatting for generic+-- annotation types, but the different parts of the message will not+-- be distinguished via annotation values.++data PrettyLogAnn = AnnLogType LogType+ | AnnSeverity Severity+ | AnnTime+ | AnnTimeMinSec+ | AnnTag+ | AnnTagVal++-- Use prettyLogType instead+instance PP.Pretty LogType where pretty = anyPrettyLogType++anyPrettyLogType :: LogType -> PP.Doc ann+anyPrettyLogType Progress = PP.pretty ("progress" :: Text)+anyPrettyLogType FuncEntry = PP.pretty ("entered" :: Text)+anyPrettyLogType FuncExit = PP.pretty ("completed" :: Text)+anyPrettyLogType UserOp = PP.pretty ("User-Op" :: Text)+anyPrettyLogType MiscLog = PP.pretty ("misc" :: Text)++prettyLogType :: LogType -> PP.Doc PrettyLogAnn+prettyLogType t = PP.annotate (AnnLogType t) $ anyPrettyLogType t++-- Use prettySev instead+instance PP.Pretty Severity where pretty = anyPrettySev++anyPrettySev :: Severity -> PP.Doc ann+anyPrettySev Error = PP.pretty ("ERR " :: Text)+anyPrettySev Warning = PP.pretty ("Warn" :: Text)+anyPrettySev Info = PP.pretty ("I " :: Text)+anyPrettySev Debug = PP.pretty ("Dbg " :: Text)++prettySev :: Severity -> PP.Doc PrettyLogAnn+prettySev s = PP.annotate (AnnSeverity s) $ anyPrettySev s++-- Use prettyTime instead+instance PP.Pretty UTCTime where+ pretty t = PP.hcat [ PP.pretty (formatTime defaultTimeLocale "%Z-%F:%H:" t)+ , PP.pretty (formatTime defaultTimeLocale "%M:%S" t)+ , PP.pretty (take 4 (formatTime defaultTimeLocale ".%q" t))+ ]++prettyTime :: UTCTime -> PP.Doc PrettyLogAnn+prettyTime t =+ if t == UTCTime (toEnum 0) (toEnum 0)+ then PP.annotate AnnTime $ PP.emptyDoc+ else PP.hcat+ [ PP.annotate AnnTime $ PP.pretty (formatTime defaultTimeLocale "%Z-%F_%H:" t)+ , PP.annotate AnnTimeMinSec $ PP.pretty (formatTime defaultTimeLocale "%M:%S" t)+ , PP.annotate AnnTime $ PP.pretty (take 4 (formatTime defaultTimeLocale ".%q" t))+ ]++anyPrettyTags :: [(Text, Text)] -> PP.Doc ann+anyPrettyTags =+ let anyPrettyTag (tag, val) = PP.group $ PP.cat [ PP.pretty tag+ , PP.equals+ , PP.pretty val+ ]+ in foldl (\acc tagval -> acc PP.<+> (anyPrettyTag tagval)) mempty++prettyTags :: [(Text, Text)] -> PP.Doc PrettyLogAnn+prettyTags =+ let ppTag (tag, val) = PP.group $ PP.hcat [ PP.annotate AnnTag $ PP.pretty tag+ , PP.equals+ , PP.annotate AnnTagVal $ PP.pretty val+ ]+ in foldl (\acc tagval -> acc PP.<+> (ppTag tagval)) mempty++-- | Format the log message with annotation values designating the+-- different portions of the pretty-printed value.+--+-- The 'Pretty' class 'pretty' method can be used for generic+-- annotations, but this yields less information for output management.+prettyLogMessage :: LogMessage -> PP.Doc PrettyLogAnn+prettyLogMessage (LogMessage {..}) = PP.hsep [ prettyTime logTime+ , prettySev logLevel+ , PP.brackets (prettyLogType logType)+ , prettyTags logTags+ , PP.pretty logText+ ]++instance PP.Pretty LogMessage where+ pretty (LogMessage {..}) = PP.hsep [ PP.pretty logTime+ , PP.pretty logLevel+ , PP.brackets (PP.pretty logType)+ , anyPrettyTags logTags+ , PP.pretty logText+ ]+++-- | The 'termStyle' converts the LogMessage annotations into ANSI+-- terminal styles to add colors and other effects such as bolding to+-- various portions of log messages (for use with+-- prettyprinter-ansi-terminal).+termStyle :: PrettyLogAnn -> PP_Term.AnsiStyle+termStyle (AnnLogType Progress) = PP_Term.colorDull PP_Term.Green+termStyle (AnnLogType FuncEntry) = PP_Term.colorDull PP_Term.Magenta+termStyle (AnnLogType FuncExit) = PP_Term.colorDull PP_Term.Cyan+termStyle (AnnLogType UserOp) = PP_Term.bold <> PP_Term.color PP_Term.Green+termStyle (AnnLogType MiscLog) = mempty+termStyle (AnnSeverity Error) = PP_Term.bold <> PP_Term.color PP_Term.Red <> PP_Term.bgColor PP_Term.Yellow+termStyle (AnnSeverity Warning) = PP_Term.bold <> PP_Term.colorDull PP_Term.Red+termStyle (AnnSeverity Info) = mempty+termStyle (AnnSeverity Debug) = PP_Term.color PP_Term.Blue+termStyle AnnTime = mempty+termStyle AnnTimeMinSec = PP_Term.color PP_Term.White <> PP_Term.bold+termStyle AnnTag = PP_Term.color PP_Term.Black <> PP_Term.bold+termStyle AnnTagVal = PP_Term.color PP_Term.Black <> PP_Term.bold+++-- | Standard function to convert a LogMessage into Text with ANSI+-- terminal colors and bolding and other styling. This can be used as+-- the default converter for a logger (via contramap).+cvtLogMessageToANSITermText :: LogMessage -> Text+cvtLogMessageToANSITermText = PP_Term.renderStrict .+ PP.reAnnotateS termStyle .+ PP.layoutSmart PP.defaultLayoutOptions .+ prettyLogMessage++-- | Standard function for converting a LogMessage into plain Text (no+-- colors or bolding, just text). This can be used as the default+-- converter for a logger (via contramap).+cvtLogMessageToPlainText :: LogMessage -> Text+cvtLogMessageToPlainText = PP_Text.renderStrict .+ PP.layoutSmart PP.defaultLayoutOptions .+ prettyLogMessage++-- ----------------------------------------------------------------------+-- * Helpers and convenience functions+--+-- These functions are not part of the core Logging implementation,+-- but can be useful to clients to perform common or default+-- operations.++-- | A wrapper for a monadic function call that will log on entry+-- (Debug) and exit (Info) from the function, and note the total+-- amount of time taken during execution of the function. Note that+-- no strictness is applied to the internal monadic operation, so the+-- time taken may be misleading. Like 'logFunctionCallM' but needs an+-- explicit 'LogAction' whereas 'logFunctionCallM' will retrieve the+-- 'LogAction' from the current monadic context.+logFunctionCall :: (MonadIO m) => LogAction m LogMessage -> Text -> m a -> m a+logFunctionCall = logFunctionCallWith . writeLog++-- | A wrapper for a monadic function call that will log on entry+-- (Debug) and exit (Info) from the function, and note the total+-- amount of time taken during execution of the function. Note that+-- no strictness is applied to the internal monadic operation, so the+-- time taken may be misleading.+logFunctionCallM :: (MonadIO m, WithLog LogMessage m) => Text -> m a -> m a+logFunctionCallM = logFunctionCallWith writeLogM++-- | Internal function implementing the body for 'logFunctionCall' or+-- 'logFunctionCallM'+logFunctionCallWith :: (MonadIO m) => (LogMessage -> m ()) -> Text -> m a -> m a+logFunctionCallWith logger fName f =+ do logger $ msgWith { logType = FuncEntry, logText = fName }+ t <- liftIO getCurrentTime+ r <- f+ t' <- liftIO getCurrentTime+ let dt = diffUTCTime t' t+ logger $ msgWith { logType = FuncExit, logLevel = Info+ , logText = fName <> ", executed for " <> pack (show dt) }+ return r+++-- | Called to output a log message to indicate that some progress has+-- been made.+logProgress :: (MonadIO m) => LogAction m LogMessage -> Text -> m ()+logProgress action txt = writeLog action $ msgWith { logLevel = Info, logType = Progress, logText = txt }+++-- | Called to output a log message within a Logging monad to indicate+-- that some progress has been made.+logProgressM :: (MonadIO m, WithLog LogMessage m) => Text -> m ()+logProgressM txt = writeLogM $ msgWith { logLevel = Info, logType = Progress, logText = txt }+++-- | This is a helper because the LogMessage normally wants a Text,+-- but show delivers a String.+tshow :: (Show a) => a -> Text+tshow = pack . show+++-- | When using a simple IO monad, there is no ability to store a+-- LogAction in the base monad. The client can specify a specific+-- HasLog instance for IO that is appropriate to that client, and that+-- HasLog can optionally use the 'defaultGetIOLogAction' as the+-- 'getLogAction' implementation to log pretty messages with ANSI+-- styling to stdout.+--+-- > instance HasLog Env Text IO where+-- > getLogAction = return defaultGetIOLogAction+-- > ...+defaultGetIOLogAction :: MonadIO m => LogAction m T.Text+defaultGetIOLogAction = LogAction $ liftIO . TIO.hPutStrLn stderr