summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xCHANGELOG.md5
-rw-r--r--LICENSE13
-rw-r--r--Setup.hs2
-rw-r--r--example/ExampleLog.hs183
-rw-r--r--lumberjack.cabal66
-rw-r--r--src/Lumberjack.hs447
6 files changed, 716 insertions, 0 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100755
index 0000000..4b05575
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for lumberjack
+
+## 0.1.0.0 -- 2020-02-13
+
+* Initial Lumberjack logger implementation, based on internal usage.
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..7ace263
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/example/ExampleLog.hs b/example/ExampleLog.hs
new file mode 100644
index 0000000..4ba3f8f
--- /dev/null
+++ b/example/ExampleLog.hs
@@ -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"
diff --git a/lumberjack.cabal b/lumberjack.cabal
new file mode 100644
index 0000000..f28546e
--- /dev/null
+++ b/lumberjack.cabal
@@ -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
diff --git a/src/Lumberjack.hs b/src/Lumberjack.hs
new file mode 100644
index 0000000..e6f780e
--- /dev/null
+++ b/src/Lumberjack.hs
@@ -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