{-# 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.
--
-- 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.
-------------------------------------------

module Lumberjack
  ( -- * Interface for Logging
    LogAction(..)
  , HasLog(..)
  , LoggingMonad(..)
  , writeLogM
    -- * Logging Utilities
    --
    -- The following utility functions can be used to adjust or wrap
    -- LogActions to provide additional functionality.
  , safeLogAction
  , logFilter
    -- * LogMessage rich logging type
    -- $richMsgType
  , Severity(..)
  , LogType(..)
  , LogMessage(..)
  , msgWith
  , WithLog
  , withLogTag
  , addLogActionTime
    -- ** Output formatting for LogMessage
    -- $richMsgFormatting
  , cvtLogMessageToPlainText
  , cvtLogMessageToANSITermText
    -- * Helpers and convenience functions
    -- $helpers
  , 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 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 { LogAction m msg -> msg -> m ()
writeLog :: msg -> m () }

instance Applicative m => Semigroup (LogAction m a) where
  LogAction a -> m ()
a1 <> :: LogAction m a -> LogAction m a -> LogAction m a
<> LogAction a -> m ()
a2 = (a -> m ()) -> LogAction m a
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((a -> m ()) -> LogAction m a) -> (a -> m ()) -> LogAction m a
forall a b. (a -> b) -> a -> b
$ \a
a -> a -> m ()
a1 a
a m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> a -> m ()
a2 a
a

instance Applicative m => Monoid (LogAction m a) where
  mappend :: LogAction m a -> LogAction m a -> LogAction m a
mappend = LogAction m a -> LogAction m a -> LogAction m a
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: LogAction m a
mempty = (a -> m ()) -> LogAction m a
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((a -> m ()) -> LogAction m a) -> (a -> m ()) -> LogAction m a
forall a b. (a -> b) -> a -> b
$ \a
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance Contravariant (LogAction m) where
  contramap :: (a -> b) -> LogAction m b -> LogAction m a
contramap a -> b
f (LogAction b -> m ()
a) = (a -> m ()) -> LogAction m a
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((a -> m ()) -> LogAction m a) -> (a -> m ()) -> LogAction m a
forall a b. (a -> b) -> a -> b
$ b -> m ()
a (b -> m ()) -> (a -> b) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

instance (Applicative m) => Divisible (LogAction m) where
  conquer :: LogAction m a
conquer = (a -> m ()) -> LogAction m a
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((a -> m ()) -> LogAction m a) -> (a -> m ()) -> LogAction m a
forall a b. (a -> b) -> a -> b
$ \a
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  divide :: (a -> (b, c)) -> LogAction m b -> LogAction m c -> LogAction m a
divide a -> (b, c)
splitf LogAction m b
lLog LogAction m c
rLog = (a -> m ()) -> LogAction m a
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((a -> m ()) -> LogAction m a) -> (a -> m ()) -> LogAction m a
forall a b. (a -> b) -> a -> b
$ \a
i ->
    let (b
l, c
r) = a -> (b, c)
splitf a
i
        ll :: m ()
ll = LogAction m b -> b -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
writeLog LogAction m b
lLog b
l
        rl :: m ()
rl = LogAction m c -> c -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
writeLog LogAction m c
rLog c
r
    in m ()
ll m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
rl

instance (Applicative m) => Decidable (LogAction m) where
  lose :: (a -> Void) -> LogAction m a
lose a -> Void
f = (a -> m ()) -> LogAction m a
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((a -> m ()) -> LogAction m a) -> (a -> m ()) -> LogAction m a
forall a b. (a -> b) -> a -> b
$ \a
a -> Void -> m ()
forall a. Void -> a
absurd (a -> Void
f a
a)
  choose :: (a -> Either b c)
-> LogAction m b -> LogAction m c -> LogAction m a
choose a -> Either b c
split LogAction m b
l LogAction m c
r = (a -> m ()) -> LogAction m a
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((a -> m ()) -> LogAction m a) -> (a -> m ()) -> LogAction m a
forall a b. (a -> b) -> a -> b
$ (b -> m ()) -> (c -> m ()) -> Either b c -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (LogAction m b -> b -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
writeLog LogAction m b
l) (LogAction m c -> c -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
writeLog LogAction m c
r) (Either b c -> m ()) -> (a -> Either b c) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either b c
split


-- | Any monad which will support retrieving a LogAction from the
-- Monad's environment should support the 'HasLog' class.
class Monad m => HasLog msg m where
  getLogAction :: m (LogAction m msg)


-- | 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)


-- | An instance of the 'LoggingMonad' class can be defined for the
-- base monadic logging action to allow adjusting that logging action.
-- This class can only be instantiated (and only needs to be
-- instantiated) for the base message type; all other message types
-- will use contramapping to convert their message type to the
-- 'LoggingMonad' base message type.
class (Monad m, HasLog msg m) => LoggingMonad msg m where
  adjustLogAction :: (forall k. LogAction k msg -> LogAction k msg) -> m a -> m a


-- | This obtains the 'LogAction' from the current monad's environment
-- to use for outputting the log message.  Most code will use this function.
writeLogM :: HasLog msg m => msg -> m ()
writeLogM :: msg -> m ()
writeLogM msg
m = m (LogAction m msg)
forall msg (m :: * -> *). HasLog msg m => m (LogAction m msg)
getLogAction m (LogAction m msg) -> (LogAction m msg -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LogAction m msg -> msg -> m ()) -> msg -> LogAction m msg -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LogAction m msg -> msg -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
writeLog msg
m


----------------------------------------------------------------------
-- * Logging Utilities


-- | 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 :: LogAction m msg -> LogAction m msg
safeLogAction LogAction m msg
a = (msg -> m ()) -> LogAction m msg
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((msg -> m ()) -> LogAction m msg)
-> (msg -> m ()) -> LogAction m msg
forall a b. (a -> b) -> a -> b
$ \msg
m -> m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
X.catch (LogAction m msg -> msg -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
writeLog LogAction m msg
a msg
m) (\(SomeException
_ex :: X.SomeException) -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
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 :: (msg -> Bool) -> LogAction m msg -> LogAction m msg
logFilter msg -> Bool
f (LogAction msg -> m ()
l) = (msg -> m ()) -> LogAction m msg
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((msg -> m ()) -> LogAction m msg)
-> (msg -> m ()) -> LogAction m msg
forall a b. (a -> b) -> a -> b
$ \msg
m -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (msg -> Bool
f msg
m) (msg -> m ()
l msg
m)



----------------------------------------------------------------------
-- * LogMessage rich logging type

-- $richMsgType
--
-- This is an enhanced 'msg' type for the LogAction, containing
-- various auxiliary information associated with the log message.
-- While 'Lumberjack' can be used with other message types, this
-- message type should provide support for most of the common logging
-- auxiliary data and can therefore be used "out of the box".


-- | 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 (Eq Severity
Eq Severity
-> (Severity -> Severity -> Ordering)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Severity)
-> (Severity -> Severity -> Severity)
-> Ord Severity
Severity -> Severity -> Bool
Severity -> Severity -> Ordering
Severity -> Severity -> Severity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Severity -> Severity -> Severity
$cmin :: Severity -> Severity -> Severity
max :: Severity -> Severity -> Severity
$cmax :: Severity -> Severity -> Severity
>= :: Severity -> Severity -> Bool
$c>= :: Severity -> Severity -> Bool
> :: Severity -> Severity -> Bool
$c> :: Severity -> Severity -> Bool
<= :: Severity -> Severity -> Bool
$c<= :: Severity -> Severity -> Bool
< :: Severity -> Severity -> Bool
$c< :: Severity -> Severity -> Bool
compare :: Severity -> Severity -> Ordering
$ccompare :: Severity -> Severity -> Ordering
$cp1Ord :: Eq Severity
Ord, Severity -> Severity -> Bool
(Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool) -> Eq Severity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Severity -> Severity -> Bool
$c/= :: Severity -> Severity -> Bool
== :: Severity -> Severity -> Bool
$c== :: Severity -> Severity -> Bool
Eq, Int -> Severity -> ShowS
[Severity] -> ShowS
Severity -> String
(Int -> Severity -> ShowS)
-> (Severity -> String) -> ([Severity] -> ShowS) -> Show Severity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Severity] -> ShowS
$cshowList :: [Severity] -> ShowS
show :: Severity -> String
$cshow :: Severity -> String
showsPrec :: Int -> Severity -> ShowS
$cshowsPrec :: Int -> Severity -> ShowS
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 (LogType -> LogType -> Bool
(LogType -> LogType -> Bool)
-> (LogType -> LogType -> Bool) -> Eq LogType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogType -> LogType -> Bool
$c/= :: LogType -> LogType -> Bool
== :: LogType -> LogType -> Bool
$c== :: LogType -> LogType -> Bool
Eq, Int -> LogType -> ShowS
[LogType] -> ShowS
LogType -> String
(Int -> LogType -> ShowS)
-> (LogType -> String) -> ([LogType] -> ShowS) -> Show LogType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogType] -> ShowS
$cshowList :: [LogType] -> ShowS
show :: LogType -> String
$cshow :: LogType -> String
showsPrec :: Int -> LogType -> ShowS
$cshowsPrec :: Int -> LogType -> ShowS
Show)


-- | Each logged output is described by a LogMessage object.
data LogMessage = LogMessage { LogMessage -> LogType
logType :: LogType
                             , LogMessage -> Severity
logLevel :: Severity
                             , LogMessage -> UTCTime
logTime :: UTCTime
                             , LogMessage -> [(Text, Text)]
logTags :: [(Text, Text)]
                             , LogMessage -> Text
logText :: Text
                             }

instance Semigroup LogMessage where
  LogMessage
a <> :: LogMessage -> LogMessage -> LogMessage
<> LogMessage
b = LogMessage :: LogType
-> Severity -> UTCTime -> [(Text, Text)] -> Text -> LogMessage
LogMessage { logType :: LogType
logType = if LogMessage -> LogType
logType LogMessage
a LogType -> LogType -> Bool
forall a. Eq a => a -> a -> Bool
== LogType
MiscLog then LogMessage -> LogType
logType LogMessage
b else LogMessage -> LogType
logType LogMessage
a
                      , logLevel :: Severity
logLevel = Severity -> Severity -> Severity
forall a. Ord a => a -> a -> a
max (LogMessage -> Severity
logLevel LogMessage
a) (LogMessage -> Severity
logLevel LogMessage
b)
                      , logTime :: UTCTime
logTime = UTCTime -> UTCTime -> UTCTime
forall a. Ord a => a -> a -> a
max (LogMessage -> UTCTime
logTime LogMessage
a) (LogMessage -> UTCTime
logTime LogMessage
b)
                      , logTags :: [(Text, Text)]
logTags = LogMessage -> [(Text, Text)]
logTags LogMessage
a [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. Semigroup a => a -> a -> a
<> LogMessage -> [(Text, Text)]
logTags LogMessage
b
                      , logText :: Text
logText = case (Text -> Bool
T.null (LogMessage -> Text
logText LogMessage
a), Text -> Bool
T.null (LogMessage -> Text
logText LogMessage
b)) of
                                  (Bool
False, Bool
False) -> LogMessage -> Text
logText LogMessage
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LogMessage -> Text
logText LogMessage
b
                                  (Bool
True, Bool
False) -> LogMessage -> Text
logText LogMessage
b
                                  (Bool, Bool)
_ -> LogMessage -> Text
logText LogMessage
a
                      }

instance Monoid LogMessage where
  mempty :: LogMessage
mempty = LogType
-> Severity -> UTCTime -> [(Text, Text)] -> Text -> LogMessage
LogMessage LogType
MiscLog Severity
Debug (Day -> DiffTime -> UTCTime
UTCTime (Int -> Day
forall a. Enum a => Int -> a
toEnum Int
0) (Int -> DiffTime
forall a. Enum a => Int -> a
toEnum Int
0)) [] Text
empty
  mappend :: LogMessage -> LogMessage -> LogMessage
mappend = LogMessage -> LogMessage -> LogMessage
forall a. Semigroup a => a -> a -> a
(<>)


-- | Helper routine to return an empty LogMessage, whose fields can
-- then be updated.
msgWith :: LogMessage
msgWith :: LogMessage
msgWith = LogMessage
forall a. Monoid a => a
mempty


-- | Add the current timestamp to the LogMessage being logged
addLogActionTime :: MonadIO m => LogAction m LogMessage -> LogAction m LogMessage
addLogActionTime :: LogAction m LogMessage -> LogAction m LogMessage
addLogActionTime LogAction m LogMessage
a = (LogMessage -> m ()) -> LogAction m LogMessage
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((LogMessage -> m ()) -> LogAction m LogMessage)
-> (LogMessage -> m ()) -> LogAction m LogMessage
forall a b. (a -> b) -> a -> b
$ \LogMessage
m -> do UTCTime
t <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                                          LogAction m LogMessage -> LogMessage -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
writeLog LogAction m LogMessage
a (LogMessage -> m ()) -> LogMessage -> m ()
forall a b. (a -> b) -> a -> b
$ LogMessage
m LogMessage -> LogMessage -> LogMessage
forall a. Semigroup a => a -> a -> a
<> LogMessage
forall a. Monoid a => a
mempty { logTime :: UTCTime
logTime = UTCTime
t }


-- | 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 :: Text -> Text -> m a -> m a
withLogTag Text
tname Text
tval m a
op =
    let tagmsg :: LogMessage
tagmsg = LogMessage
forall a. Monoid a => a
mempty { logTags :: [(Text, Text)]
logTags = [(Text
tname, Text
tval)] }
    in ((forall (k :: * -> *).
 LogAction k LogMessage -> LogAction k LogMessage)
-> m a -> m a
forall msg (m :: * -> *) a.
LoggingMonad msg m =>
(forall (k :: * -> *). LogAction k msg -> LogAction k msg)
-> m a -> m a
adjustLogAction ((forall (k :: * -> *).
  LogAction k LogMessage -> LogAction k LogMessage)
 -> m a -> m a)
-> (forall (k :: * -> *).
    LogAction k LogMessage -> LogAction k LogMessage)
-> m a
-> m a
forall a b. (a -> b) -> a -> b
$ (LogMessage -> LogMessage)
-> LogAction k LogMessage -> LogAction k LogMessage
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (LogMessage
tagmsg LogMessage -> LogMessage -> LogMessage
forall a. Semigroup a => a -> a -> a
<>)) m a
op


-- ----------------------------------------------------------------------
-- * Output formatting for LogMessage

-- $richMsgFormatting
--
-- When the 'LogMessage' logging type is used, 'Lumberjack' provides a
-- standard set of output formatting functions.  The output uses the
-- prettyprinter package to generate 'Doc' output with annotations
-- specifying the type of markup to be applied to various portions of
-- the output.
--
-- There are multiple rendering functions that can be supplied as
-- contramap converters to the base 'LogAction'.  One rendering
-- function outputs a log message in plain text, while the other uses
-- the prettyprinter-ansi-terminal package to generate various ANSI
-- highlighting and color codes for writing enhanced output to a TTY.


-- | Normal 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 :: LogType -> Doc ann
pretty = LogType -> Doc ann
forall ann. LogType -> Doc ann
anyPrettyLogType

anyPrettyLogType :: LogType -> PP.Doc ann
anyPrettyLogType :: LogType -> Doc ann
anyPrettyLogType LogType
Progress  = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"progress" :: Text)
anyPrettyLogType LogType
FuncEntry = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"entered" :: Text)
anyPrettyLogType LogType
FuncExit  = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"completed" :: Text)
anyPrettyLogType LogType
UserOp    = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"User-Op" :: Text)
anyPrettyLogType LogType
MiscLog   = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"misc" :: Text)

prettyLogType :: LogType -> PP.Doc PrettyLogAnn
prettyLogType :: LogType -> Doc PrettyLogAnn
prettyLogType LogType
t = PrettyLogAnn -> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall ann. ann -> Doc ann -> Doc ann
PP.annotate (LogType -> PrettyLogAnn
AnnLogType LogType
t) (Doc PrettyLogAnn -> Doc PrettyLogAnn)
-> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall a b. (a -> b) -> a -> b
$ LogType -> Doc PrettyLogAnn
forall ann. LogType -> Doc ann
anyPrettyLogType LogType
t

-- Use prettySev instead
instance PP.Pretty Severity where pretty :: Severity -> Doc ann
pretty = Severity -> Doc ann
forall ann. Severity -> Doc ann
anyPrettySev

anyPrettySev :: Severity -> PP.Doc ann
anyPrettySev :: Severity -> Doc ann
anyPrettySev Severity
Error   = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"ERR " :: Text)
anyPrettySev Severity
Warning = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"Warn" :: Text)
anyPrettySev Severity
Info    = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"I   " :: Text)
anyPrettySev Severity
Debug   = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"Dbg " :: Text)

prettySev :: Severity -> PP.Doc PrettyLogAnn
prettySev :: Severity -> Doc PrettyLogAnn
prettySev Severity
s = PrettyLogAnn -> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall ann. ann -> Doc ann -> Doc ann
PP.annotate (Severity -> PrettyLogAnn
AnnSeverity Severity
s) (Doc PrettyLogAnn -> Doc PrettyLogAnn)
-> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall a b. (a -> b) -> a -> b
$ Severity -> Doc PrettyLogAnn
forall ann. Severity -> Doc ann
anyPrettySev Severity
s

-- Use prettyTime instead
instance PP.Pretty UTCTime where
  pretty :: UTCTime -> Doc ann
pretty UTCTime
t = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.hcat [ String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Z-%F:%H:" UTCTime
t)
                     , String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%M:%S" UTCTime
t)
                     , String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
4 (TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
".%q" UTCTime
t))
                     ]

prettyTime :: UTCTime -> PP.Doc PrettyLogAnn
prettyTime :: UTCTime -> Doc PrettyLogAnn
prettyTime UTCTime
t =
  if UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== Day -> DiffTime -> UTCTime
UTCTime (Int -> Day
forall a. Enum a => Int -> a
toEnum Int
0) (Int -> DiffTime
forall a. Enum a => Int -> a
toEnum Int
0)
  then PrettyLogAnn -> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall ann. ann -> Doc ann -> Doc ann
PP.annotate PrettyLogAnn
AnnTime (Doc PrettyLogAnn -> Doc PrettyLogAnn)
-> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall a b. (a -> b) -> a -> b
$ Doc PrettyLogAnn
forall ann. Doc ann
PP.emptyDoc
  else [Doc PrettyLogAnn] -> Doc PrettyLogAnn
forall ann. [Doc ann] -> Doc ann
PP.hcat
       [ PrettyLogAnn -> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall ann. ann -> Doc ann -> Doc ann
PP.annotate PrettyLogAnn
AnnTime (Doc PrettyLogAnn -> Doc PrettyLogAnn)
-> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall a b. (a -> b) -> a -> b
$ String -> Doc PrettyLogAnn
forall a ann. Pretty a => a -> Doc ann
PP.pretty (TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Z-%F_%H:" UTCTime
t)
       , PrettyLogAnn -> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall ann. ann -> Doc ann -> Doc ann
PP.annotate PrettyLogAnn
AnnTimeMinSec (Doc PrettyLogAnn -> Doc PrettyLogAnn)
-> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall a b. (a -> b) -> a -> b
$ String -> Doc PrettyLogAnn
forall a ann. Pretty a => a -> Doc ann
PP.pretty (TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%M:%S" UTCTime
t)
       , PrettyLogAnn -> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall ann. ann -> Doc ann -> Doc ann
PP.annotate PrettyLogAnn
AnnTime (Doc PrettyLogAnn -> Doc PrettyLogAnn)
-> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall a b. (a -> b) -> a -> b
$ String -> Doc PrettyLogAnn
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
4 (TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
".%q" UTCTime
t))
       ]

anyPrettyTags :: [(Text, Text)] -> PP.Doc ann
anyPrettyTags :: [(Text, Text)] -> Doc ann
anyPrettyTags =
  let anyPrettyTag :: (a, a) -> Doc ann
anyPrettyTag (a
tag, a
val) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.cat [ a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty a
tag
                                                  , Doc ann
forall ann. Doc ann
PP.equals
                                                  , a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty a
val
                                                  ]
  in (Doc ann -> (Text, Text) -> Doc ann)
-> Doc ann -> [(Text, Text)] -> Doc ann
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Doc ann
acc (Text, Text)
tagval -> Doc ann
acc Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> ((Text, Text) -> Doc ann
forall a a ann. (Pretty a, Pretty a) => (a, a) -> Doc ann
anyPrettyTag (Text, Text)
tagval)) Doc ann
forall a. Monoid a => a
mempty

prettyTags :: [(Text, Text)] -> PP.Doc PrettyLogAnn
prettyTags :: [(Text, Text)] -> Doc PrettyLogAnn
prettyTags =
  let ppTag :: (a, a) -> Doc PrettyLogAnn
ppTag (a
tag, a
val) = Doc PrettyLogAnn -> Doc PrettyLogAnn
forall ann. Doc ann -> Doc ann
PP.group (Doc PrettyLogAnn -> Doc PrettyLogAnn)
-> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall a b. (a -> b) -> a -> b
$ [Doc PrettyLogAnn] -> Doc PrettyLogAnn
forall ann. [Doc ann] -> Doc ann
PP.hcat [ PrettyLogAnn -> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall ann. ann -> Doc ann -> Doc ann
PP.annotate PrettyLogAnn
AnnTag (Doc PrettyLogAnn -> Doc PrettyLogAnn)
-> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall a b. (a -> b) -> a -> b
$ a -> Doc PrettyLogAnn
forall a ann. Pretty a => a -> Doc ann
PP.pretty a
tag
                                            , Doc PrettyLogAnn
forall ann. Doc ann
PP.equals
                                            , PrettyLogAnn -> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall ann. ann -> Doc ann -> Doc ann
PP.annotate PrettyLogAnn
AnnTagVal (Doc PrettyLogAnn -> Doc PrettyLogAnn)
-> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall a b. (a -> b) -> a -> b
$ a -> Doc PrettyLogAnn
forall a ann. Pretty a => a -> Doc ann
PP.pretty a
val
                                            ]
  in (Doc PrettyLogAnn -> (Text, Text) -> Doc PrettyLogAnn)
-> Doc PrettyLogAnn -> [(Text, Text)] -> Doc PrettyLogAnn
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Doc PrettyLogAnn
acc (Text, Text)
tagval -> Doc PrettyLogAnn
acc Doc PrettyLogAnn -> Doc PrettyLogAnn -> Doc PrettyLogAnn
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> ((Text, Text) -> Doc PrettyLogAnn
forall a a. (Pretty a, Pretty a) => (a, a) -> Doc PrettyLogAnn
ppTag (Text, Text)
tagval)) Doc PrettyLogAnn
forall a. Monoid a => a
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 -> Doc PrettyLogAnn
prettyLogMessage (LogMessage {[(Text, Text)]
Text
UTCTime
LogType
Severity
logText :: Text
logTags :: [(Text, Text)]
logTime :: UTCTime
logLevel :: Severity
logType :: LogType
logText :: LogMessage -> Text
logTags :: LogMessage -> [(Text, Text)]
logTime :: LogMessage -> UTCTime
logLevel :: LogMessage -> Severity
logType :: LogMessage -> LogType
..}) = [Doc PrettyLogAnn] -> Doc PrettyLogAnn
forall ann. [Doc ann] -> Doc ann
PP.hsep [ UTCTime -> Doc PrettyLogAnn
prettyTime UTCTime
logTime
                                             , Severity -> Doc PrettyLogAnn
prettySev Severity
logLevel
                                             , Doc PrettyLogAnn -> Doc PrettyLogAnn
forall ann. Doc ann -> Doc ann
PP.brackets (LogType -> Doc PrettyLogAnn
prettyLogType LogType
logType)
                                             , [(Text, Text)] -> Doc PrettyLogAnn
prettyTags [(Text, Text)]
logTags
                                             , Text -> Doc PrettyLogAnn
forall a ann. Pretty a => a -> Doc ann
PP.pretty Text
logText
                                             ]

instance PP.Pretty LogMessage where
  pretty :: LogMessage -> Doc ann
pretty (LogMessage {[(Text, Text)]
Text
UTCTime
LogType
Severity
logText :: Text
logTags :: [(Text, Text)]
logTime :: UTCTime
logLevel :: Severity
logType :: LogType
logText :: LogMessage -> Text
logTags :: LogMessage -> [(Text, Text)]
logTime :: LogMessage -> UTCTime
logLevel :: LogMessage -> Severity
logType :: LogMessage -> LogType
..}) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.hsep [ UTCTime -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty UTCTime
logTime
                                     , Severity -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Severity
logLevel
                                     , Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.brackets (LogType -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty LogType
logType)
                                     , [(Text, Text)] -> Doc ann
forall ann. [(Text, Text)] -> Doc ann
anyPrettyTags [(Text, Text)]
logTags
                                     , Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Text
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 :: PrettyLogAnn -> AnsiStyle
termStyle (AnnLogType LogType
Progress)  = Color -> AnsiStyle
PP_Term.colorDull Color
PP_Term.Green
termStyle (AnnLogType LogType
FuncEntry) = Color -> AnsiStyle
PP_Term.colorDull Color
PP_Term.Magenta
termStyle (AnnLogType LogType
FuncExit)  = Color -> AnsiStyle
PP_Term.colorDull Color
PP_Term.Cyan
termStyle (AnnLogType LogType
UserOp)    = AnsiStyle
PP_Term.bold AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
PP_Term.color Color
PP_Term.Green
termStyle (AnnLogType LogType
MiscLog)   = AnsiStyle
forall a. Monoid a => a
mempty
termStyle (AnnSeverity Severity
Error)   = AnsiStyle
PP_Term.bold AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
PP_Term.color Color
PP_Term.Red AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
PP_Term.bgColor Color
PP_Term.Yellow
termStyle (AnnSeverity Severity
Warning) = AnsiStyle
PP_Term.bold AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
PP_Term.colorDull Color
PP_Term.Red
termStyle (AnnSeverity Severity
Info)    = AnsiStyle
forall a. Monoid a => a
mempty
termStyle (AnnSeverity Severity
Debug)   = Color -> AnsiStyle
PP_Term.color Color
PP_Term.Blue
termStyle PrettyLogAnn
AnnTime       = AnsiStyle
forall a. Monoid a => a
mempty
termStyle PrettyLogAnn
AnnTimeMinSec = Color -> AnsiStyle
PP_Term.color Color
PP_Term.White AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
PP_Term.bold
termStyle PrettyLogAnn
AnnTag    = Color -> AnsiStyle
PP_Term.color Color
PP_Term.Black AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
PP_Term.bold
termStyle PrettyLogAnn
AnnTagVal = Color -> AnsiStyle
PP_Term.color Color
PP_Term.Black AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
PP_Term.bold


-- | Standard 'LogMessage' rendering 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 :: LogMessage -> Text
cvtLogMessageToANSITermText = SimpleDocStream AnsiStyle -> Text
PP_Term.renderStrict (SimpleDocStream AnsiStyle -> Text)
-> (LogMessage -> SimpleDocStream AnsiStyle) -> LogMessage -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                              (PrettyLogAnn -> AnsiStyle)
-> SimpleDocStream PrettyLogAnn -> SimpleDocStream AnsiStyle
forall ann ann'.
(ann -> ann') -> SimpleDocStream ann -> SimpleDocStream ann'
PP.reAnnotateS PrettyLogAnn -> AnsiStyle
termStyle (SimpleDocStream PrettyLogAnn -> SimpleDocStream AnsiStyle)
-> (LogMessage -> SimpleDocStream PrettyLogAnn)
-> LogMessage
-> SimpleDocStream AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                              LayoutOptions -> Doc PrettyLogAnn -> SimpleDocStream PrettyLogAnn
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutSmart LayoutOptions
PP.defaultLayoutOptions (Doc PrettyLogAnn -> SimpleDocStream PrettyLogAnn)
-> (LogMessage -> Doc PrettyLogAnn)
-> LogMessage
-> SimpleDocStream PrettyLogAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                              LogMessage -> Doc PrettyLogAnn
prettyLogMessage

-- | Standard 'LogMessage' rendering function for converting a
-- 'LogMessage' into plain 'Text' (no colors or other highlighting).
-- This can be used as the default converter for a logger (via
-- contramap).
cvtLogMessageToPlainText :: LogMessage -> Text
cvtLogMessageToPlainText :: LogMessage -> Text
cvtLogMessageToPlainText = SimpleDocStream PrettyLogAnn -> Text
forall ann. SimpleDocStream ann -> Text
PP_Text.renderStrict (SimpleDocStream PrettyLogAnn -> Text)
-> (LogMessage -> SimpleDocStream PrettyLogAnn)
-> LogMessage
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                           LayoutOptions -> Doc PrettyLogAnn -> SimpleDocStream PrettyLogAnn
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutSmart LayoutOptions
PP.defaultLayoutOptions (Doc PrettyLogAnn -> SimpleDocStream PrettyLogAnn)
-> (LogMessage -> Doc PrettyLogAnn)
-> LogMessage
-> SimpleDocStream PrettyLogAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                           LogMessage -> Doc PrettyLogAnn
prettyLogMessage

-- ----------------------------------------------------------------------
-- * Helpers and convenience functions

-- $helpers
-- 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 function call that will call the provided
-- 'LogAction' with a 'Debug' log on entry to the function and an
-- 'Info' log on exit from the function.  The total amount of time
-- taken during execution of the function will be included in the exit
-- log message.  No strictness is applied to the invoked 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 :: LogAction m LogMessage -> Text -> m a -> m a
logFunctionCall = (LogMessage -> m ()) -> Text -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
(LogMessage -> m ()) -> Text -> m a -> m a
logFunctionCallWith ((LogMessage -> m ()) -> Text -> m a -> m a)
-> (LogAction m LogMessage -> LogMessage -> m ())
-> LogAction m LogMessage
-> Text
-> m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogAction m LogMessage -> LogMessage -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
writeLog


-- | A wrapper for a monadic function call that will 'Debug' log on
-- entry to and 'Info' log on exit from the function.  The exit log
-- will also note the total amount of time taken during execution of
-- the function.  Be advised 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 :: Text -> m a -> m a
logFunctionCallM = (LogMessage -> m ()) -> Text -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
(LogMessage -> m ()) -> Text -> m a -> m a
logFunctionCallWith LogMessage -> m ()
forall msg (m :: * -> *). HasLog msg m => msg -> m ()
writeLogM


-- | Internal function implementing the body for 'logFunctionCall' or
-- 'logFunctionCallM'
logFunctionCallWith :: (MonadIO m) => (LogMessage -> m ()) -> Text -> m a -> m a
logFunctionCallWith :: (LogMessage -> m ()) -> Text -> m a -> m a
logFunctionCallWith LogMessage -> m ()
logger Text
fName m a
f =
  do LogMessage -> m ()
logger (LogMessage -> m ()) -> LogMessage -> m ()
forall a b. (a -> b) -> a -> b
$ LogMessage
msgWith { logType :: LogType
logType = LogType
FuncEntry, logText :: Text
logText = Text
fName }
     UTCTime
t <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
     a
r <- m a
f
     UTCTime
t' <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
     let dt :: NominalDiffTime
dt = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t' UTCTime
t
     LogMessage -> m ()
logger (LogMessage -> m ()) -> LogMessage -> m ()
forall a b. (a -> b) -> a -> b
$ LogMessage
msgWith { logType :: LogType
logType = LogType
FuncExit, logLevel :: Severity
logLevel = Severity
Info
                      , logText :: Text
logText = Text
fName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", executed for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (NominalDiffTime -> String
forall a. Show a => a -> String
show NominalDiffTime
dt) }
     a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r


-- | Called to output a log message to indicate that some progress in
-- the current activity has been made.
logProgress :: (MonadIO m) => LogAction m LogMessage -> Text -> m ()
logProgress :: LogAction m LogMessage -> Text -> m ()
logProgress LogAction m LogMessage
action Text
txt = LogAction m LogMessage -> LogMessage -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
writeLog LogAction m LogMessage
action (LogMessage -> m ()) -> LogMessage -> m ()
forall a b. (a -> b) -> a -> b
$ LogMessage
msgWith { logLevel :: Severity
logLevel = Severity
Info, logType :: LogType
logType = LogType
Progress, logText :: Text
logText = Text
txt }


-- | Called to output a log message within a 'HasLog' monad to indicate
-- that some progress in the current activity has been made.
logProgressM :: (MonadIO m, WithLog LogMessage m) => Text -> m ()
logProgressM :: Text -> m ()
logProgressM Text
txt = LogMessage -> m ()
forall msg (m :: * -> *). HasLog msg m => msg -> m ()
writeLogM (LogMessage -> m ()) -> LogMessage -> m ()
forall a b. (a -> b) -> a -> b
$ LogMessage
msgWith { logLevel :: Severity
logLevel = Severity
Info, logType :: LogType
logType = LogType
Progress, logText :: Text
logText = Text
txt }


-- | This is a helper function.  The LogMessage normally wants a Text,
-- but show delivers a String, so 'tshow' can be used to get the
-- needed format.
tshow :: (Show a) => a -> Text
tshow :: a -> Text
tshow = String -> Text
pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
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 m Text
defaultGetIOLogAction = (Text -> m ()) -> LogAction m Text
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((Text -> m ()) -> LogAction m Text)
-> (Text -> m ()) -> LogAction m Text
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr