diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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