{-# 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 Prettyprinter as PP
import qualified Prettyprinter.Render.Terminal as PP_Term
import qualified Prettyprinter.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 { forall (m :: * -> *) msg. 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 = forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction forall a b. (a -> b) -> a -> b
$ \a
a -> a -> m ()
a1 a
a 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 = forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: LogAction m a
mempty = forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction forall a b. (a -> b) -> a -> b
$ \a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

instance (Applicative m) => Decidable (LogAction m) where
  lose :: forall a. (a -> Void) -> LogAction m a
lose a -> Void
f = forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction forall a b. (a -> b) -> a -> b
$ \a
a -> forall a. Void -> a
absurd (a -> Void
f a
a)
  choose :: forall a b c.
(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 = forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
writeLog LogAction m b
l) (forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
writeLog LogAction m c
r) 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 :: forall msg (m :: * -> *). HasLog msg m => msg -> m ()
writeLogM msg
m = forall msg (m :: * -> *). HasLog msg m => m (LogAction m msg)
getLogAction forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 :: forall (m :: * -> *) msg.
MonadCatch m =>
LogAction m msg -> LogAction m msg
safeLogAction LogAction m msg
a = forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction forall a b. (a -> b) -> a -> b
$ \msg
m -> forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
X.catch (forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
writeLog LogAction m msg
a msg
m) (\(SomeException
_ex :: X.SomeException) -> 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 :: forall (m :: * -> *) msg.
Applicative m =>
(msg -> Bool) -> LogAction m msg -> LogAction m msg
logFilter msg -> Bool
f (LogAction msg -> m ()
l) = forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction forall a b. (a -> b) -> a -> b
$ \msg
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 message 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
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
Ord, Severity -> Severity -> Bool
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
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
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
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 :: LogType
logType = if LogMessage -> LogType
logType LogMessage
a forall a. Eq a => a -> a -> Bool
== LogType
MiscLog then LogMessage -> LogType
logType LogMessage
b else LogMessage -> LogType
logType LogMessage
a
                      , logLevel :: Severity
logLevel = forall a. Ord a => a -> a -> a
max (LogMessage -> Severity
logLevel LogMessage
a) (LogMessage -> Severity
logLevel LogMessage
b)
                      , logTime :: UTCTime
logTime = 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 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 forall a. Semigroup a => a -> a -> a
<> 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 (forall a. Enum a => Int -> a
toEnum Int
0) (forall a. Enum a => Int -> a
toEnum Int
0)) [] Text
empty
  mappend :: LogMessage -> LogMessage -> LogMessage
mappend = 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 = forall a. Monoid a => a
mempty


-- | This operator is a convenient infix operator for logging a Text
-- message.  This is especially useful when used in conjunction with
-- the @OverloadedStrings@ language pragma:
--
--   >>> warning|# "This is your last warning"
--   >>> error|# "Failure has occurred"

(|#) :: (LogMessage -> a) -> Text -> a
LogMessage -> a
o |# :: forall a. (LogMessage -> a) -> Text -> a
|# Text
t = LogMessage -> a
o (LogMessage
msgWith { logText :: Text
logText = Text
t })
infixr 0 |#


-- | Add the current timestamp to the LogMessage being logged
addLogActionTime :: MonadIO m => LogAction m LogMessage -> LogAction m LogMessage
addLogActionTime :: forall (m :: * -> *).
MonadIO m =>
LogAction m LogMessage -> LogAction m LogMessage
addLogActionTime LogAction m LogMessage
a = forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction forall a b. (a -> b) -> a -> b
$ \LogMessage
m -> do UTCTime
t <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                                          forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
writeLog LogAction m LogMessage
a forall a b. (a -> b) -> a -> b
$ LogMessage
m forall a. Semigroup a => a -> a -> a
<> 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 :: forall (m :: * -> *) a.
LoggingMonad LogMessage m =>
Text -> Text -> m a -> m a
withLogTag Text
tname Text
tval m a
op =
    let tagmsg :: LogMessage
tagmsg = forall a. Monoid a => a
mempty { logTags :: [(Text, Text)]
logTags = [(Text
tname, Text
tval)] }
    in (forall msg (m :: * -> *) a.
LoggingMonad msg m =>
(forall (k :: * -> *). LogAction k msg -> LogAction k msg)
-> m a -> m a
adjustLogAction forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (LogMessage
tagmsg 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 'Prettyprinter.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 'Prettyprinter.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 :: forall ann. LogType -> Doc ann
pretty = forall ann. LogType -> Doc ann
anyPrettyLogType

anyPrettyLogType :: LogType -> PP.Doc ann
anyPrettyLogType :: forall ann. LogType -> Doc ann
anyPrettyLogType LogType
Progress  = forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"progress" :: Text)
anyPrettyLogType LogType
FuncEntry = forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"entered" :: Text)
anyPrettyLogType LogType
FuncExit  = forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"completed" :: Text)
anyPrettyLogType LogType
UserOp    = forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"User-Op" :: Text)
anyPrettyLogType LogType
MiscLog   = 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 = forall ann. ann -> Doc ann -> Doc ann
PP.annotate (LogType -> PrettyLogAnn
AnnLogType LogType
t) forall a b. (a -> b) -> a -> b
$ forall ann. LogType -> Doc ann
anyPrettyLogType LogType
t

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

anyPrettySev :: Severity -> PP.Doc ann
anyPrettySev :: forall ann. Severity -> Doc ann
anyPrettySev Severity
Error   = forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"ERR " :: Text)
anyPrettySev Severity
Warning = forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"Warn" :: Text)
anyPrettySev Severity
Info    = forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text
"I   " :: Text)
anyPrettySev Severity
Debug   = 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 = forall ann. ann -> Doc ann -> Doc ann
PP.annotate (Severity -> PrettyLogAnn
AnnSeverity Severity
s) forall a b. (a -> b) -> a -> b
$ forall ann. Severity -> Doc ann
anyPrettySev Severity
s

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

anyPrettyTags :: [(Text, Text)] -> PP.Doc ann
anyPrettyTags :: forall ann. [(Text, Text)] -> Doc ann
anyPrettyTags =
  let anyPrettyTag :: (a, a) -> Doc ann
anyPrettyTag (a
tag, a
val) = forall ann. Doc ann -> Doc ann
PP.group forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
PP.cat [ forall a ann. Pretty a => a -> Doc ann
PP.pretty a
tag
                                                  , forall ann. Doc ann
PP.equals
                                                  , forall a ann. Pretty a => a -> Doc ann
PP.pretty a
val
                                                  ]
  in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Doc ann
acc (Text, Text)
tagval -> Doc ann
acc forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> (forall {a} {a} {ann}. (Pretty a, Pretty a) => (a, a) -> Doc ann
anyPrettyTag (Text, Text)
tagval)) 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) = forall ann. Doc ann -> Doc ann
PP.group forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
PP.hcat [ forall ann. ann -> Doc ann -> Doc ann
PP.annotate PrettyLogAnn
AnnTag forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
PP.pretty a
tag
                                            , forall ann. Doc ann
PP.equals
                                            , forall ann. ann -> Doc ann -> Doc ann
PP.annotate PrettyLogAnn
AnnTagVal forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
PP.pretty a
val
                                            ]
  in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Doc PrettyLogAnn
acc (Text, Text)
tagval -> Doc PrettyLogAnn
acc forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> (forall {a} {a}. (Pretty a, Pretty a) => (a, a) -> Doc PrettyLogAnn
ppTag (Text, Text)
tagval)) forall a. Monoid a => a
mempty


-- | Format the log message with annotation values designating the
-- different portions of the pretty-printed value.
--
-- The 'Prettyprinter.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
..}) = forall ann. [Doc ann] -> Doc ann
PP.hsep [ UTCTime -> Doc PrettyLogAnn
prettyTime UTCTime
logTime
                                             , Severity -> Doc PrettyLogAnn
prettySev Severity
logLevel
                                             , forall ann. Doc ann -> Doc ann
PP.brackets (LogType -> Doc PrettyLogAnn
prettyLogType LogType
logType)
                                             , [(Text, Text)] -> Doc PrettyLogAnn
prettyTags [(Text, Text)]
logTags
                                             , forall a ann. Pretty a => a -> Doc ann
PP.pretty Text
logText
                                             ]

instance PP.Pretty LogMessage where
  pretty :: forall ann. 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
..}) = forall ann. [Doc ann] -> Doc ann
PP.hsep [ forall a ann. Pretty a => a -> Doc ann
PP.pretty UTCTime
logTime
                                     , forall a ann. Pretty a => a -> Doc ann
PP.pretty Severity
logLevel
                                     , forall ann. Doc ann -> Doc ann
PP.brackets (forall a ann. Pretty a => a -> Doc ann
PP.pretty LogType
logType)
                                     , forall ann. [(Text, Text)] -> Doc ann
anyPrettyTags [(Text, Text)]
logTags
                                     , 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 forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
PP_Term.color Color
PP_Term.Green
termStyle (AnnLogType LogType
MiscLog)   = forall a. Monoid a => a
mempty
termStyle (AnnSeverity Severity
Error)   = AnsiStyle
PP_Term.bold forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
PP_Term.color Color
PP_Term.Red forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
PP_Term.bgColor Color
PP_Term.Yellow
termStyle (AnnSeverity Severity
Warning) = AnsiStyle
PP_Term.bold forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
PP_Term.colorDull Color
PP_Term.Red
termStyle (AnnSeverity Severity
Info)    = forall a. Monoid a => a
mempty
termStyle (AnnSeverity Severity
Debug)   = Color -> AnsiStyle
PP_Term.color Color
PP_Term.Blue
termStyle PrettyLogAnn
AnnTime       = forall a. Monoid a => a
mempty
termStyle PrettyLogAnn
AnnTimeMinSec = Color -> AnsiStyle
PP_Term.color Color
PP_Term.White forall a. Semigroup a => a -> a -> a
<> AnsiStyle
PP_Term.bold
termStyle PrettyLogAnn
AnnTag    = Color -> AnsiStyle
PP_Term.color Color
PP_Term.Black forall a. Semigroup a => a -> a -> a
<> AnsiStyle
PP_Term.bold
termStyle PrettyLogAnn
AnnTagVal = Color -> AnsiStyle
PP_Term.color Color
PP_Term.Black 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                              forall ann ann'.
(ann -> ann') -> SimpleDocStream ann -> SimpleDocStream ann'
PP.reAnnotateS PrettyLogAnn -> AnsiStyle
termStyle forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                              forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutSmart LayoutOptions
PP.defaultLayoutOptions 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 = forall ann. SimpleDocStream ann -> Text
PP_Text.renderStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                           forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutSmart LayoutOptions
PP.defaultLayoutOptions 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 :: forall (m :: * -> *) a.
MonadIO m =>
LogAction m LogMessage -> Text -> m a -> m a
logFunctionCall = forall (m :: * -> *) a.
MonadIO m =>
(LogMessage -> m ()) -> Text -> m a -> m a
logFunctionCallWith forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (m :: * -> *) a.
(MonadIO m, WithLog LogMessage m) =>
Text -> m a -> m a
logFunctionCallM = forall (m :: * -> *) a.
MonadIO m =>
(LogMessage -> m ()) -> Text -> m a -> m a
logFunctionCallWith 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 :: forall (m :: * -> *) a.
MonadIO m =>
(LogMessage -> m ()) -> Text -> m a -> m a
logFunctionCallWith LogMessage -> m ()
logger Text
fName m a
f =
  do LogMessage -> m ()
logger forall a b. (a -> b) -> a -> b
$ LogMessage
msgWith { logType :: LogType
logType = LogType
FuncEntry, logText :: Text
logText = Text
fName }
     UTCTime
t <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
     a
r <- m a
f
     UTCTime
t' <- 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 forall a b. (a -> b) -> a -> b
$ LogMessage
msgWith { logType :: LogType
logType = LogType
FuncExit, logLevel :: Severity
logLevel = Severity
Info
                      , logText :: Text
logText = Text
fName forall a. Semigroup a => a -> a -> a
<> Text
", executed for " forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show NominalDiffTime
dt) }
     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 :: forall (m :: * -> *).
MonadIO m =>
LogAction m LogMessage -> Text -> m ()
logProgress LogAction m LogMessage
action Text
txt = forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
writeLog LogAction m LogMessage
action 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 :: forall (m :: * -> *).
(MonadIO m, WithLog LogMessage m) =>
Text -> m ()
logProgressM Text
txt = forall msg (m :: * -> *). HasLog msg m => msg -> m ()
writeLogM 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 :: forall a. Show a => a -> Text
tshow = String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (m :: * -> *). MonadIO m => LogAction m Text
defaultGetIOLogAction = forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr