Message.hs

{-|
The workhorse module of this library. Here you will find types for working with
this logging library along with functions for issuing log messages of various
severities. Also in this module are log output formatters for different parts
of a log message.

The time* formatters use the local time and time zone as reported by the
system. To change this to UTC or some other zone, use the TZ environment
variable, timedatectl or similar and that zone will be used in logging.
Example:

@TZ=UTC my-app-with-logging@
-}
module Colog.Simple.Message
  (
    -- * Types
    Formatter
  , Message
  , RichMessage

    -- * Functions for logging with a specific severity
  , logDebug, logInfo, logNotice, logWarning, logError

    -- * Functions for composing formatters
  , (%), (%+)
  , str

    -- * Message formatting functions
  , msg, msgc
  , sev, sevc
  , time, timec, timecf, timef
  , stack, stackc

    -- * Other functions
  , colorize
  , setSeverity

    -- * Re-exported from ansi-terminal
  , Color

    -- * Deprecated message formatting functions
  , basicFmt, colorFmt, colorSevFmt, colorSevStackFmt
  )
  where

import Colog (LogAction, cfilter)
import Colog.Message (Msg (..), RichMsg (..), fmtRichMessageCustomDefault, log,
  showSourceLoc)
import Colog.Monad (WithLog)
import Control.Monad.Trans (MonadIO, liftIO)
import Data.Text (Text, pack)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Time.LocalTime (getCurrentTimeZone, utcToZonedTime)
import GHC.Stack (withFrozenCallStack)
import Prelude hiding (log)
import System.Console.ANSI (Color (..), ColorIntensity (Vivid),
  ConsoleLayer (Foreground), SGR (..), setSGRCode)

import Colog.Simple.Severity (Severity (..))


-- | The type of a Msg parameterized with the custom severity type in this
--   library
type Message = Msg Severity
type RichMessage m = RichMsg m Message


-- | Log a message with 'Debug' severity
logDebug :: WithLog env Message m => Text -> m ()
logDebug = withFrozenCallStack (log Debug)


-- | Log a message with 'Info' severity
logInfo :: WithLog env Message m => Text -> m ()
logInfo = withFrozenCallStack (log Info)


-- | Log a message with 'Notice' severity
logNotice :: WithLog env Message m => Text -> m ()
logNotice = withFrozenCallStack (log Notice)


-- | Log a message with 'Warning' severity
logWarning :: WithLog env Message m => Text -> m ()
logWarning = withFrozenCallStack (log Warning)


-- | Log a message with 'Error' severity
logError :: WithLog env Message m => Text -> m ()
logError = withFrozenCallStack (log Error)


-- | Wrap some 'Text' in the ANSI codes to color it in a terminal
colorize :: Color -> Text -> Text
colorize c txt =
  pack (setSGRCode [SetColor Foreground Vivid c])
  <> txt
  <> pack (setSGRCode [Reset])


showSeverity :: Severity -> Text
showSeverity Debug    = "[Debug]  "
showSeverity Info     = "[Info]   "
showSeverity Notice   = "[Notice] "
showSeverity Warning  = "[Warning]"
showSeverity Error    = "[Error]  "


colorForSeverity :: Severity -> Color
colorForSeverity Debug = Green
colorForSeverity Info = Blue
colorForSeverity Notice = White
colorForSeverity Warning = Yellow
colorForSeverity Error = Red


-- | The type of functions which format 'Message's into 'Text'
type Formatter m = RichMessage m -> m Text


-- | Apply two formatters to a 'Message' and combine the resulting 'Text's.
--   With apologies to the formatting library for stealing their operator!
(%) :: MonadIO m => Formatter m -> Formatter m -> Formatter m
f % g = \msg' -> (<>) <$> f msg' <*> g msg'


-- | Apply two formatters to a 'Message' and combine the resulting 'Text'
--   output with a space between.
--   Again, with apologies to the formatting library for stealing their operator!
(%+) :: MonadIO m => Formatter m -> Formatter m -> Formatter m
f %+ g = f % (const $ pure " ") % g


-- | "Format" some text. Used to send some text to the logger. An example could
--   be spacing between other formatters.
str :: MonadIO m => Text -> RichMessage m -> m Text
str = const . pure


-- | Format the time the log message was generated
time :: MonadIO m => RichMessage m -> m Text
time = timef "%Y-%m-%dT%H:%M:%S%z"


-- | Format the time the log message was generated with the supplied format
--   string
--
--   For formatting docs see the Data.Time.Format module in the base time
--   library.
timef :: MonadIO m => String -> RichMessage m -> m Text
timef timeFmt rm = do
  zone <- liftIO $ getCurrentTimeZone
  fmtRichMessageCustomDefault rm ( \_ mbTime _ ->
    pack . maybe ""
      (formatTime defaultTimeLocale timeFmt . utcToZonedTime zone)
      $ mbTime )


-- | Format the time the log message was generated with color based on the
--   'Severity'
timec :: MonadIO m => RichMessage m -> m Text
timec rm@(RichMsg (Msg s _ _) _) = colorize (colorForSeverity s) <$> time rm


-- | Format the time the log message was generated with color based on the
--   'Severity' and with the supplied format string
--
--   For formatting docs see the Data.Time.Format module in the base time
--   library.
timecf :: MonadIO m => String -> RichMessage m -> m Text
timecf timeFmt rm@(RichMsg (Msg s _ _) _) = colorize (colorForSeverity s)
  <$> timef timeFmt rm


-- | Format 'Severity'
sev :: MonadIO m => RichMessage m -> m Text
sev (RichMsg (Msg s _ _) _) = pure $ showSeverity s


-- | Format 'Severity' with color based on the value
sevc :: MonadIO m => RichMessage m -> m Text
sevc rm@(RichMsg (Msg s _ _) _) = colorize (colorForSeverity s) <$> sev rm


-- | Format call stack info
stack :: MonadIO m => RichMessage m -> m Text
stack (RichMsg (Msg _ cs _) _) = pure $ showSourceLoc cs


-- | Format call stack info with color based on the 'Severity'
stackc :: MonadIO m => RichMessage m -> m Text
stackc rm@(RichMsg (Msg s _ _) _) = colorize (colorForSeverity s) <$> stack rm


-- | Format the log message
msg :: MonadIO m => RichMessage m -> m Text
msg (RichMsg (Msg _ _ m) _) = pure m


-- | Format the log message with color based on the 'Severity'
msgc :: MonadIO m => RichMessage m -> m Text
msgc rm@(RichMsg (Msg s _ _) _)  = colorize (colorForSeverity s) <$> msg rm


-- | Filter log messages for greater than or equal to the given 'Severity'
setSeverity :: Applicative m => Severity -> LogAction m Message -> LogAction m Message
setSeverity targetSev = cfilter (\(Msg msgSev _ _) -> msgSev >= targetSev)


-- | No color formatting. Just the message, no severity label
basicFmt :: MonadIO m => RichMessage m -> m Text
basicFmt = msg
{-# DEPRECATED basicFmt "Use msg instead" #-}


-- | Format with no severity labels but message colors for each severity
colorFmt :: MonadIO m => RichMessage m -> m Text
colorFmt = msgc
{-# DEPRECATED colorFmt "Use msgc instead" #-}


-- | Format with colored severity labels and no color for the message
colorSevFmt :: MonadIO m => RichMessage m -> m Text
colorSevFmt = sevc % msg
{-# DEPRECATED colorSevFmt "Use (sevc % msg) instead" #-}


-- | Format with colored severity labels, call stack info, and no color for the
--   message
colorSevStackFmt :: MonadIO m => RichMessage m -> m Text
colorSevStackFmt = sevc % stack %+ msg
{-# DEPRECATED colorSevStackFmt "Use (sevc % stack %+ msg) instead" #-}