{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-|
Module      : Colog.Polysemy.Formatting.Render
Description : Render log messages.
-}
module Colog.Polysemy.Formatting.Render
  ( renderThreadTimeMessage
  , renderThreadTimeMessageShort
  , fIso8601Tz
  , fSeverity
  , fThread
  , fCallerFromStack
  , fCaller
  , fCallerLong'
  , fCallerLong
  , fCallerShort'
  , fCallerShort
  ) where

import Colog (Msg(..), Severity(..))
import Control.Concurrent (ThreadId)
import Data.Char (isUpper)
import Data.Function ((&))
import qualified Data.Text as T
import Data.Text.Lazy.Builder (Builder)
import Data.Time (FormatTime, utcToZonedTime)
import Formatting
import Formatting.Time
import GHC.Stack (CallStack, SrcLoc(..), getCallStack)

import Colog.Polysemy.Formatting.Color (Color(..), UseColor, getWithFG)
import Colog.Polysemy.Formatting.LogEnv (LogEnv(..))
import Colog.Polysemy.Formatting.ThreadTimeMessage (ThreadTimeMessage(..))

-- | Render the message, optionally in color, with green " | " separating fields, and these fields:
--
--     * Severity (e.g. "INFO", see 'fSeverity'),
--     * Timestamp (e.g. "2020-10-13T16:58:43.982720690+1100", see 'fIso8601Tz'),
--     * Thread Id (e.g. "Thread     8", see 'fThread'),
--     * Caller (e.g. "MyApp.CLI.cliMain#43", see 'fCallerLong'), and
--     * The log message itself.
--
-- E.g: @"INFO | 2020-10-13T17:06:52.408921221+1100 | Thread     8 | MyApp.CLI.cliMain#43 | MyApp version 0.1.0.0"@
--
-- The first three columns are fixed-width, which makes visual scanning of the log easier.
renderThreadTimeMessage :: LogEnv -> ThreadTimeMessage -> T.Text
renderThreadTimeMessage :: LogEnv -> ThreadTimeMessage -> Text
renderThreadTimeMessage = ((Color -> Builder -> Builder)
 -> Format Builder (CallStack -> Builder))
-> LogEnv -> ThreadTimeMessage -> Text
renderThreadTimeMessage' (Color -> Builder -> Builder)
-> Format Builder (CallStack -> Builder)
forall r.
(Color -> Builder -> Builder) -> Format r (CallStack -> r)
fCallerLong

-- | Like 'renderThreadTimeMessage', but abbreviate the caller by removing lowercase letters from the module name.
renderThreadTimeMessageShort :: LogEnv -> ThreadTimeMessage -> T.Text
renderThreadTimeMessageShort :: LogEnv -> ThreadTimeMessage -> Text
renderThreadTimeMessageShort = ((Color -> Builder -> Builder)
 -> Format Builder (CallStack -> Builder))
-> LogEnv -> ThreadTimeMessage -> Text
renderThreadTimeMessage' (Color -> Builder -> Builder)
-> Format Builder (CallStack -> Builder)
forall r.
(Color -> Builder -> Builder) -> Format r (CallStack -> r)
fCallerShort

renderThreadTimeMessage' :: ((Color -> Builder -> Builder) -> Format Builder (CallStack -> Builder)) -> LogEnv -> ThreadTimeMessage -> T.Text
renderThreadTimeMessage' :: ((Color -> Builder -> Builder)
 -> Format Builder (CallStack -> Builder))
-> LogEnv -> ThreadTimeMessage -> Text
renderThreadTimeMessage' (Color -> Builder -> Builder)
-> Format Builder (CallStack -> Builder)
renderCaller (LogEnv UseColor
useColor TimeZone
zone) (ThreadTimeMessage ThreadId
threadId UTCTime
time (Msg Severity
severity CallStack
stack Text
message)) =
  let withFG :: Color -> Builder -> Builder
withFG = UseColor -> Color -> Builder -> Builder
getWithFG UseColor
useColor
  in Format Text ([Builder] -> Text) -> [Builder] -> Text
forall a. Format Text a -> a
sformat (UseColor -> Format Text ([Builder] -> Text)
forall r. UseColor -> Format r ([Builder] -> r)
fFieldsGreenBarSep UseColor
useColor)
    [ Format Builder (Severity -> Builder) -> Severity -> Builder
forall a. Format Builder a -> a
bformat ((Color -> Builder -> Builder)
-> Format Builder (Severity -> Builder)
forall r. (Color -> Builder -> Builder) -> Format r (Severity -> r)
fSeverity Color -> Builder -> Builder
withFG) Severity
severity
    , Format Builder (ZonedTime -> Builder) -> ZonedTime -> Builder
forall a. Format Builder a -> a
bformat ((Color -> Builder -> Builder)
-> Format Builder (ZonedTime -> Builder)
forall a r.
FormatTime a =>
(Color -> Builder -> Builder) -> Format r (a -> r)
fIso8601Tz Color -> Builder -> Builder
withFG) (TimeZone -> UTCTime -> ZonedTime
utcToZonedTime TimeZone
zone UTCTime
time)
    , Format Builder (ThreadId -> Builder) -> ThreadId -> Builder
forall a. Format Builder a -> a
bformat Format Builder (ThreadId -> Builder)
forall r. Format r (ThreadId -> r)
fThread ThreadId
threadId
    , Format Builder (CallStack -> Builder) -> CallStack -> Builder
forall a. Format Builder a -> a
bformat ((Color -> Builder -> Builder)
-> Format Builder (CallStack -> Builder)
renderCaller Color -> Builder -> Builder
withFG) CallStack
stack
    , Format Builder (Text -> Builder) -> Text -> Builder
forall a. Format Builder a -> a
bformat Format Builder (Text -> Builder)
forall r. Format r (Text -> r)
stext Text
message
    ]

fFieldsGreenBarSep :: UseColor -> Format r ([Builder] -> r)
fFieldsGreenBarSep :: UseColor -> Format r ([Builder] -> r)
fFieldsGreenBarSep UseColor
useColor = ([Builder] -> Builder) -> Format r ([Builder] -> r)
forall a r. (a -> Builder) -> Format r (a -> r)
later (([Builder] -> Builder) -> Format r ([Builder] -> r))
-> ([Builder] -> Builder) -> Format r ([Builder] -> r)
forall a b. (a -> b) -> a -> b
$ \[Builder]
fields ->
  let withFG :: Color -> Builder -> Builder
withFG = UseColor -> Color -> Builder -> Builder
getWithFG UseColor
useColor
      sep :: Text
sep = Format Text (Builder -> Text) -> Builder -> Text
forall a. Format Text a -> a
format Format Text (Builder -> Text)
forall r. Format r (Builder -> r)
builder (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Color -> Builder -> Builder
withFG Color
Green Builder
" | "
  in Format Builder ([Builder] -> Builder) -> [Builder] -> Builder
forall a. Format Builder a -> a
bformat (Text
-> Format Builder (Builder -> Builder)
-> Format Builder ([Builder] -> Builder)
forall (t :: * -> *) a r.
Foldable t =>
Text -> Format Builder (a -> Builder) -> Format r (t a -> r)
intercalated Text
sep Format Builder (Builder -> Builder)
forall r. Format r (Builder -> r)
builder) [Builder]
fields

-- | Render a timestamp in ISO-8601 format, in color, to 9 decimal places,
-- e.g.: "2020-10-13T16:58:43.982720690+1100"
--
-- The "T" is rendered in green, the time in yellow, the rest without color.
fIso8601Tz :: FormatTime a => (Color -> Builder -> Builder) -> Format r (a -> r)
fIso8601Tz :: (Color -> Builder -> Builder) -> Format r (a -> r)
fIso8601Tz Color -> Builder -> Builder
withFG = (a -> Builder) -> Format r (a -> r)
forall a r. (a -> Builder) -> Format r (a -> r)
later ((a -> Builder) -> Format r (a -> r))
-> (a -> Builder) -> Format r (a -> r)
forall a b. (a -> b) -> a -> b
$ \a
time -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
  [ Format Builder (a -> Builder) -> a -> Builder
forall a. Format Builder a -> a
bformat Format Builder (a -> Builder)
forall a r. FormatTime a => Format r (a -> r)
dateDash a
time
  , Color -> Builder -> Builder
withFG Color
Green Builder
"T"
  , Color -> Builder -> Builder
withFG Color
Yellow (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Format Builder (a -> Builder) -> a -> Builder
forall a. Format Builder a -> a
bformat Format Builder (a -> Builder)
forall a r. FormatTime a => Format r (a -> r)
hmsL a
time
  , Color -> Builder -> Builder
withFG Color
Yellow (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Format Builder (Builder -> Builder) -> Builder -> Builder
forall a. Format Builder a -> a
bformat (Int -> Char -> Format Builder (Builder -> Builder)
forall a r. Buildable a => Int -> Char -> Format r (a -> r)
right Int
10 Char
'0') (Format Builder (a -> Builder) -> a -> Builder
forall a. Format Builder a -> a
bformat Format Builder (a -> Builder)
forall a r. FormatTime a => Format r (a -> r)
decimals a
time)
  , Format Builder (a -> Builder) -> a -> Builder
forall a. Format Builder a -> a
bformat Format Builder (a -> Builder)
forall a r. FormatTime a => Format r (a -> r)
tz a
time
  ]

-- | Render the 'Severity' of the message, with color, using 4 characters to maintain alignment:
--
--     * DBUG in green,
--     * INFO in blue,
--     * WARN in yellow, or
--     * ERR in red.
fSeverity :: (Color -> Builder -> Builder) -> Format r (Severity -> r)
fSeverity :: (Color -> Builder -> Builder) -> Format r (Severity -> r)
fSeverity Color -> Builder -> Builder
withFG = (Severity -> Builder) -> Format r (Severity -> r)
forall a r. (a -> Builder) -> Format r (a -> r)
later ((Severity -> Builder) -> Format r (Severity -> r))
-> (Severity -> Builder) -> Format r (Severity -> r)
forall a b. (a -> b) -> a -> b
$ \case
  Severity
Debug   -> Color -> Builder -> Builder
withFG Color
Green  Builder
"DBUG"
  Severity
Info    -> Color -> Builder -> Builder
withFG Color
Blue   Builder
"INFO"
  Severity
Warning -> Color -> Builder -> Builder
withFG Color
Yellow Builder
"WARN"
  Severity
Error   -> Color -> Builder -> Builder
withFG Color
Red    Builder
"ERR "

-- | Render the Id of the thread that the log message was generated in,
-- with a fixed width, at least until the thread Ids exceed 100,000,
-- e.g. "Thread    97".
fThread :: Format r (ThreadId -> r)
fThread :: Format r (ThreadId -> r)
fThread = (ThreadId -> Builder) -> Format r (ThreadId -> r)
forall a r. (a -> Builder) -> Format r (a -> r)
later ((ThreadId -> Builder) -> Format r (ThreadId -> r))
-> (ThreadId -> Builder) -> Format r (ThreadId -> r)
forall a b. (a -> b) -> a -> b
$ \ThreadId
tid ->
  let s :: String
s = ThreadId -> String
forall a. Show a => a -> String
show ThreadId
tid
  in Format Builder (String -> Builder) -> String -> Builder
forall a. Format Builder a -> a
bformat (Format (String -> Builder) (String -> Builder)
"Thread " Format (String -> Builder) (String -> Builder)
-> Format Builder (String -> Builder)
-> Format Builder (String -> Builder)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Int -> Char -> Format Builder (String -> Builder)
forall a r. Buildable a => Int -> Char -> Format r (a -> r)
left Int
5 Char
' ') (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
9 String
s)

fCallerFromStack :: Format r (Maybe (String, SrcLoc) -> r) -> Format r (CallStack -> r)
fCallerFromStack :: Format r (Maybe (String, SrcLoc) -> r) -> Format r (CallStack -> r)
fCallerFromStack = (CallStack -> Maybe (String, SrcLoc))
-> Format r (Maybe (String, SrcLoc) -> r)
-> Format r (CallStack -> r)
forall a b r t. (a -> b) -> Format r (b -> t) -> Format r (a -> t)
mapf CallStack -> Maybe (String, SrcLoc)
callStackLoc
  where
    callStackLoc :: CallStack -> Maybe (String, SrcLoc)
    callStackLoc :: CallStack -> Maybe (String, SrcLoc)
callStackLoc CallStack
cs =
      case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of
        []                             -> Maybe (String, SrcLoc)
forall a. Maybe a
Nothing
        [(String
name, SrcLoc
loc)]                  -> (String, SrcLoc) -> Maybe (String, SrcLoc)
forall a. a -> Maybe a
Just (String
name, SrcLoc
loc)
        (String
_, SrcLoc
loc) : (String
callerName, SrcLoc
_) : [(String, SrcLoc)]
_ -> (String, SrcLoc) -> Maybe (String, SrcLoc)
forall a. a -> Maybe a
Just (String
callerName, SrcLoc
loc)

fCaller :: (Color -> Builder -> Builder) -> Format r (String -> String -> Int -> r)
fCaller :: (Color -> Builder -> Builder)
-> Format r (String -> String -> Int -> r)
fCaller Color -> Builder -> Builder
withFG =
  Format (String -> Int -> r) (String -> String -> Int -> r)
forall r. Format r (String -> r)
string Format (String -> Int -> r) (String -> String -> Int -> r)
-> Format r (String -> Int -> r)
-> Format r (String -> String -> Int -> r)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (String -> Int -> r) (String -> Int -> r)
"." Format (String -> Int -> r) (String -> Int -> r)
-> Format r (String -> Int -> r) -> Format r (String -> Int -> r)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Color
-> Format Builder (String -> Builder)
-> Format (Int -> r) (String -> Int -> r)
forall t r.
Color -> Format Builder (t -> Builder) -> Format r (t -> r)
colored Color
Cyan Format Builder (String -> Builder)
forall r. Format r (String -> r)
string Format (Int -> r) (String -> Int -> r)
-> Format r (Int -> r) -> Format r (String -> Int -> r)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Int -> r) (Int -> r)
"#" Format (Int -> r) (Int -> r)
-> Format r (Int -> r) -> Format r (Int -> r)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Color -> Format Builder (Int -> Builder) -> Format r (Int -> r)
forall t r.
Color -> Format Builder (t -> Builder) -> Format r (t -> r)
colored Color
Red Format Builder (Int -> Builder)
forall a r. Integral a => Format r (a -> r)
int
  where
    colored :: Color -> Format Builder (t -> Builder) -> Format r (t -> r)
colored Color
c Format Builder (t -> Builder)
f = (t -> Builder) -> Format r (t -> r)
forall a r. (a -> Builder) -> Format r (a -> r)
later ((t -> Builder) -> Format r (t -> r))
-> (t -> Builder) -> Format r (t -> r)
forall a b. (a -> b) -> a -> b
$ \t
input ->
      Format Builder (t -> Builder) -> t -> Builder
forall a. Format Builder a -> a
bformat Format Builder (t -> Builder)
f t
input Builder -> (Builder -> Builder) -> Builder
forall a b. a -> (a -> b) -> b
& Color -> Builder -> Builder
withFG Color
c

fCallerLong' :: (Color -> Builder -> Builder) -> Format r (Maybe (String, SrcLoc) -> r)
fCallerLong' :: (Color -> Builder -> Builder)
-> Format r (Maybe (String, SrcLoc) -> r)
fCallerLong' Color -> Builder -> Builder
withFG = Builder
-> Format Builder ((String, SrcLoc) -> Builder)
-> Format r (Maybe (String, SrcLoc) -> r)
forall a r.
Builder -> Format Builder (a -> Builder) -> Format r (Maybe a -> r)
maybed Builder
"<unknown loc>" (Format Builder ((String, SrcLoc) -> Builder)
 -> Format r (Maybe (String, SrcLoc) -> r))
-> Format Builder ((String, SrcLoc) -> Builder)
-> Format r (Maybe (String, SrcLoc) -> r)
forall a b. (a -> b) -> a -> b
$
  ((String, SrcLoc) -> Builder)
-> Format Builder ((String, SrcLoc) -> Builder)
forall a r. (a -> Builder) -> Format r (a -> r)
later (((String, SrcLoc) -> Builder)
 -> Format Builder ((String, SrcLoc) -> Builder))
-> ((String, SrcLoc) -> Builder)
-> Format Builder ((String, SrcLoc) -> Builder)
forall a b. (a -> b) -> a -> b
$ \(String
name, SrcLoc{Int
String
srcLocPackage :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocFile :: SrcLoc -> String
srcLocStartLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocEndCol :: SrcLoc -> Int
srcLocEndCol :: Int
srcLocEndLine :: Int
srcLocStartCol :: Int
srcLocStartLine :: Int
srcLocFile :: String
srcLocModule :: String
srcLocPackage :: String
..}) ->
    Format Builder (String -> String -> Int -> Builder)
-> String -> String -> Int -> Builder
forall a. Format Builder a -> a
bformat ((Color -> Builder -> Builder)
-> Format Builder (String -> String -> Int -> Builder)
forall r.
(Color -> Builder -> Builder)
-> Format r (String -> String -> Int -> r)
fCaller Color -> Builder -> Builder
withFG)
      String
srcLocModule
      String
name
      Int
srcLocStartLine

-- | Render the fully qualified function that called the log function,
-- and line number in the source file, e.g. "MyApp.CLI.cliMain#43",
-- with the function name in cyan and line number in red.
fCallerLong :: (Color -> Builder -> Builder) -> Format r (CallStack -> r)
fCallerLong :: (Color -> Builder -> Builder) -> Format r (CallStack -> r)
fCallerLong Color -> Builder -> Builder
withFG = Format r (Maybe (String, SrcLoc) -> r) -> Format r (CallStack -> r)
forall r.
Format r (Maybe (String, SrcLoc) -> r) -> Format r (CallStack -> r)
fCallerFromStack ((Color -> Builder -> Builder)
-> Format r (Maybe (String, SrcLoc) -> r)
forall r.
(Color -> Builder -> Builder)
-> Format r (Maybe (String, SrcLoc) -> r)
fCallerLong' Color -> Builder -> Builder
withFG)

fCallerShort' :: (Color -> Builder -> Builder) -> Format r (Maybe (String, SrcLoc) -> r)
fCallerShort' :: (Color -> Builder -> Builder)
-> Format r (Maybe (String, SrcLoc) -> r)
fCallerShort' Color -> Builder -> Builder
withFG = Builder
-> Format Builder ((String, SrcLoc) -> Builder)
-> Format r (Maybe (String, SrcLoc) -> r)
forall a r.
Builder -> Format Builder (a -> Builder) -> Format r (Maybe a -> r)
maybed Builder
"?" (Format Builder ((String, SrcLoc) -> Builder)
 -> Format r (Maybe (String, SrcLoc) -> r))
-> Format Builder ((String, SrcLoc) -> Builder)
-> Format r (Maybe (String, SrcLoc) -> r)
forall a b. (a -> b) -> a -> b
$
  ((String, SrcLoc) -> Builder)
-> Format Builder ((String, SrcLoc) -> Builder)
forall a r. (a -> Builder) -> Format r (a -> r)
later (((String, SrcLoc) -> Builder)
 -> Format Builder ((String, SrcLoc) -> Builder))
-> ((String, SrcLoc) -> Builder)
-> Format Builder ((String, SrcLoc) -> Builder)
forall a b. (a -> b) -> a -> b
$ \(String
name, SrcLoc{Int
String
srcLocEndCol :: Int
srcLocEndLine :: Int
srcLocStartCol :: Int
srcLocStartLine :: Int
srcLocFile :: String
srcLocModule :: String
srcLocPackage :: String
srcLocPackage :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocFile :: SrcLoc -> String
srcLocStartLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocEndCol :: SrcLoc -> Int
..}) ->
    Format Builder (String -> String -> Int -> Builder)
-> String -> String -> Int -> Builder
forall a. Format Builder a -> a
bformat ((Color -> Builder -> Builder)
-> Format Builder (String -> String -> Int -> Builder)
forall r.
(Color -> Builder -> Builder)
-> Format r (String -> String -> Int -> r)
fCaller Color -> Builder -> Builder
withFG)
      (String -> String
abbreviateModule String
srcLocModule)
      String
name
      Int
srcLocStartLine
  where
    abbreviateModule :: String -> String
abbreviateModule =
      (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (\Char
c -> Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.')

-- | Render the fully qualified function that called the log function,
-- and line number in the source file, abbreviating the module path by
-- removing lower-case letters, e.g. "MA.CLI.cliMain#43",
-- with the function name in cyan and line number in red.
fCallerShort :: (Color -> Builder -> Builder) -> Format r (CallStack -> r)
fCallerShort :: (Color -> Builder -> Builder) -> Format r (CallStack -> r)
fCallerShort Color -> Builder -> Builder
withFG = Format r (Maybe (String, SrcLoc) -> r) -> Format r (CallStack -> r)
forall r.
Format r (Maybe (String, SrcLoc) -> r) -> Format r (CallStack -> r)
fCallerFromStack ((Color -> Builder -> Builder)
-> Format r (Maybe (String, SrcLoc) -> r)
forall r.
(Color -> Builder -> Builder)
-> Format r (Maybe (String, SrcLoc) -> r)
fCallerShort' Color -> Builder -> Builder
withFG)