-- | Colorful logging for humans
--
-- Lines are formatted as
--
-- @
-- {timestamp} [{level}] {message} {details}
-- @
--
-- @level@ is padded to 9 characters and @message@ is padded to 31. This means
-- things will align as long as values are shorter than that. Longer values will
-- overflow (not be truncated).
--
-- This format was designed to match Python's
-- [structlog](https://www.structlog.org/en/stable/) package in its default
-- configuration.
module Blammo.Logging.Terminal
  ( reformatTerminal
  ) where

import Prelude

import Blammo.Logging.Colors
import Blammo.Logging.LogSettings (LogSettings, getLogSettingsBreakpoint)
import Blammo.Logging.Terminal.LogPiece (LogPiece, logPiece)
import qualified Blammo.Logging.Terminal.LogPiece as LogPiece
import Control.Monad.Logger.Aeson
import Data.Aeson
import Data.Aeson.Compat (KeyMap)
import qualified Data.Aeson.Compat as Key
import qualified Data.Aeson.Compat as KeyMap
import Data.ByteString (ByteString)
import Data.List (sortOn)
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack)
import qualified Data.Text as T
import Data.Time (defaultTimeLocale, formatTime)
import qualified Data.Vector as V

reformatTerminal
  :: LogSettings -> Colors -> LogLevel -> LoggedMessage -> ByteString
reformatTerminal :: LogSettings -> Colors -> LogLevel -> LoggedMessage -> ByteString
reformatTerminal LogSettings
settings colors :: Colors
colors@Colors {Text -> Text
gray :: Text -> Text
black :: Text -> Text
cyan :: Text -> Text
magenta :: Text -> Text
blue :: Text -> Text
yellow :: Text -> Text
green :: Text -> Text
red :: Text -> Text
bold :: Text -> Text
dim :: Text -> Text
gray :: Colors -> Text -> Text
black :: Colors -> Text -> Text
cyan :: Colors -> Text -> Text
magenta :: Colors -> Text -> Text
blue :: Colors -> Text -> Text
yellow :: Colors -> Text -> Text
green :: Colors -> Text -> Text
red :: Colors -> Text -> Text
bold :: Colors -> Text -> Text
dim :: Colors -> Text -> Text
..} LogLevel
logLevel LoggedMessage {Maybe Text
Maybe Loc
KeyMap Value
Text
UTCTime
LogLevel
loggedMessageTimestamp :: UTCTime
loggedMessageLevel :: LogLevel
loggedMessageLoc :: Maybe Loc
loggedMessageLogSource :: Maybe Text
loggedMessageThreadContext :: KeyMap Value
loggedMessageText :: Text
loggedMessageMeta :: KeyMap Value
loggedMessageTimestamp :: LoggedMessage -> UTCTime
loggedMessageLevel :: LoggedMessage -> LogLevel
loggedMessageLoc :: LoggedMessage -> Maybe Loc
loggedMessageLogSource :: LoggedMessage -> Maybe Text
loggedMessageThreadContext :: LoggedMessage -> KeyMap Value
loggedMessageText :: LoggedMessage -> Text
loggedMessageMeta :: LoggedMessage -> KeyMap Value
..} = do
  LogPiece -> ByteString
LogPiece.bytestring (LogPiece -> ByteString) -> LogPiece -> ByteString
forall a b. (a -> b) -> a -> b
$
    if LogPiece -> Int
LogPiece.visibleLength LogPiece
oneLineLogPiece Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
breakpoint
      then LogPiece
oneLineLogPiece
      else LogPiece
multiLineLogPiece
 where
  breakpoint :: Int
breakpoint = LogSettings -> Int
getLogSettingsBreakpoint LogSettings
settings

  logTimestampPiece :: LogPiece
logTimestampPiece =
    (Text -> Text) -> Text -> LogPiece
logPiece Text -> Text
dim (Text -> LogPiece) -> Text -> LogPiece
forall a b. (a -> b) -> a -> b
$
      String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
        TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime
          TimeLocale
defaultTimeLocale
          String
"%F %X"
          UTCTime
loggedMessageTimestamp

  logLevelPiece :: LogPiece
logLevelPiece = case LogLevel
logLevel of
    LogLevel
LevelDebug -> (Text -> Text) -> Text -> LogPiece
logPiece Text -> Text
gray (Text -> LogPiece) -> Text -> LogPiece
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
padTo Int
9 Text
"debug"
    LogLevel
LevelInfo -> (Text -> Text) -> Text -> LogPiece
logPiece Text -> Text
green (Text -> LogPiece) -> Text -> LogPiece
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
padTo Int
9 Text
"info"
    LogLevel
LevelWarn -> (Text -> Text) -> Text -> LogPiece
logPiece Text -> Text
yellow (Text -> LogPiece) -> Text -> LogPiece
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
padTo Int
9 Text
"warn"
    LogLevel
LevelError -> (Text -> Text) -> Text -> LogPiece
logPiece Text -> Text
red (Text -> LogPiece) -> Text -> LogPiece
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
padTo Int
9 Text
"error"
    LevelOther Text
x -> (Text -> Text) -> Text -> LogPiece
logPiece Text -> Text
blue (Text -> LogPiece) -> Text -> LogPiece
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
padTo Int
9 Text
x

  loggedSourceAsMap :: KeyMap Value
loggedSourceAsMap =
    (Text -> KeyMap Value) -> Maybe Text -> KeyMap Value
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Key -> Value -> KeyMap Value
forall v. Key -> v -> KeyMap v
KeyMap.singleton Key
"source" (Value -> KeyMap Value) -> (Text -> Value) -> Text -> KeyMap Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String) Maybe Text
loggedMessageLogSource

  logPrefixPiece :: LogPiece
logPrefixPiece =
    LogPiece
logTimestampPiece LogPiece -> LogPiece -> LogPiece
forall a. Semigroup a => a -> a -> a
<> LogPiece
" [" LogPiece -> LogPiece -> LogPiece
forall a. Semigroup a => a -> a -> a
<> LogPiece
logLevelPiece LogPiece -> LogPiece -> LogPiece
forall a. Semigroup a => a -> a -> a
<> LogPiece
"] "

  logMessagePiece :: LogPiece
logMessagePiece = (Text -> Text) -> Text -> LogPiece
logPiece Text -> Text
bold (Text -> LogPiece) -> Text -> LogPiece
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
padTo Int
31 Text
loggedMessageText

  logAttrsPiece :: LogPiece
logAttrsPiece =
    [LogPiece] -> LogPiece
forall a. Monoid a => [a] -> a
mconcat
      [ LogPiece -> Colors -> KeyMap Value -> LogPiece
colorizeKeyMap LogPiece
" " Colors
colors KeyMap Value
loggedSourceAsMap
      , LogPiece -> Colors -> KeyMap Value -> LogPiece
colorizeKeyMap LogPiece
" " Colors
colors KeyMap Value
loggedMessageThreadContext
      , LogPiece -> Colors -> KeyMap Value -> LogPiece
colorizeKeyMap LogPiece
" " Colors
colors KeyMap Value
loggedMessageMeta
      ]

  oneLineLogPiece :: LogPiece
oneLineLogPiece = [LogPiece] -> LogPiece
forall a. Monoid a => [a] -> a
mconcat [LogPiece
logPrefixPiece, LogPiece
logMessagePiece, LogPiece
logAttrsPiece]

  multiLineLogPiece :: LogPiece
multiLineLogPiece =
    let shift :: LogPiece
shift = LogPiece
"\n" LogPiece -> LogPiece -> LogPiece
forall a. Semigroup a => a -> a -> a
<> Int -> LogPiece
LogPiece.offset (LogPiece -> Int
LogPiece.visibleLength LogPiece
logPrefixPiece)
    in  [LogPiece] -> LogPiece
forall a. Monoid a => [a] -> a
mconcat
          [ LogPiece
logPrefixPiece
          , LogPiece
logMessagePiece
          , LogPiece -> Colors -> KeyMap Value -> LogPiece
colorizeKeyMap LogPiece
shift Colors
colors KeyMap Value
loggedSourceAsMap
          , LogPiece -> Colors -> KeyMap Value -> LogPiece
colorizeKeyMap LogPiece
shift Colors
colors KeyMap Value
loggedMessageThreadContext
          , LogPiece -> Colors -> KeyMap Value -> LogPiece
colorizeKeyMap LogPiece
shift Colors
colors KeyMap Value
loggedMessageMeta
          ]

colorizeKeyMap :: LogPiece -> Colors -> KeyMap Value -> LogPiece
colorizeKeyMap :: LogPiece -> Colors -> KeyMap Value -> LogPiece
colorizeKeyMap LogPiece
sep Colors {Text -> Text
gray :: Colors -> Text -> Text
black :: Colors -> Text -> Text
cyan :: Colors -> Text -> Text
magenta :: Colors -> Text -> Text
blue :: Colors -> Text -> Text
yellow :: Colors -> Text -> Text
green :: Colors -> Text -> Text
red :: Colors -> Text -> Text
bold :: Colors -> Text -> Text
dim :: Colors -> Text -> Text
gray :: Text -> Text
black :: Text -> Text
cyan :: Text -> Text
magenta :: Text -> Text
blue :: Text -> Text
yellow :: Text -> Text
green :: Text -> Text
red :: Text -> Text
bold :: Text -> Text
dim :: Text -> Text
..} KeyMap Value
km
  | KeyMap Value -> Bool
forall v. KeyMap v -> Bool
KeyMap.null KeyMap Value
km = LogPiece
forall a. Monoid a => a
mempty
  | Bool
otherwise = ((Key, Value) -> LogPiece) -> [(Key, Value)] -> LogPiece
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Key -> Value -> LogPiece) -> (Key, Value) -> LogPiece
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> Value -> LogPiece
fromPair) ([(Key, Value)] -> LogPiece) -> [(Key, Value)] -> LogPiece
forall a b. (a -> b) -> a -> b
$ ((Key, Value) -> Key) -> [(Key, Value)] -> [(Key, Value)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Key, Value) -> Key
forall a b. (a, b) -> a
fst ([(Key, Value)] -> [(Key, Value)])
-> [(Key, Value)] -> [(Key, Value)]
forall a b. (a -> b) -> a -> b
$ KeyMap Value -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList KeyMap Value
km
 where
  fromPair :: Key -> Value -> LogPiece
fromPair Key
k Value
v =
    LogPiece
sep LogPiece -> LogPiece -> LogPiece
forall a. Semigroup a => a -> a -> a
<> (Text -> Text) -> Text -> LogPiece
logPiece Text -> Text
cyan (Key -> Text
Key.toText Key
k) LogPiece -> LogPiece -> LogPiece
forall a. Semigroup a => a -> a -> a
<> LogPiece
"=" LogPiece -> LogPiece -> LogPiece
forall a. Semigroup a => a -> a -> a
<> (Text -> Text) -> Text -> LogPiece
logPiece Text -> Text
magenta (Value -> Text
fromValue Value
v)

  fromValue :: Value -> Text
fromValue = \case
    Object KeyMap Value
m -> [Text] -> Text
obj ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((Key, Value) -> Text) -> [(Key, Value)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> Value -> Text) -> (Key, Value) -> Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> Value -> Text
renderPairNested) ([(Key, Value)] -> [Text]) -> [(Key, Value)] -> [Text]
forall a b. (a -> b) -> a -> b
$ KeyMap Value -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList KeyMap Value
m
    Array Array
a -> [Text] -> Text
list ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Value -> Text) -> [Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Text
fromValue ([Value] -> [Text]) -> [Value] -> [Text]
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
a
    String Text
x -> Text
x
    Number Scientific
n -> Scientific -> Text
sci Scientific
n
    Bool Bool
b -> String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> String
forall a. Show a => a -> String
show Bool
b
    Value
Null -> Text
"null"

  renderPairNested :: Key -> Value -> Text
renderPairNested Key
k Value
v = Key -> Text
Key.toText Key
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
fromValue Value
v

  obj :: [Text] -> Text
obj [Text]
xs = Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
xs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
  list :: [Text] -> Text
list [Text]
xs = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
xs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
  sci :: Scientific -> Text
sci = Text -> Text -> Text
dropSuffix Text
".0" (Text -> Text) -> (Scientific -> Text) -> Scientific -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (Scientific -> String) -> Scientific -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> String
forall a. Show a => a -> String
show

dropSuffix :: Text -> Text -> Text
dropSuffix :: Text -> Text -> Text
dropSuffix Text
suffix Text
t = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
t (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripSuffix Text
suffix Text
t

padTo :: Int -> Text -> Text
padTo :: Int -> Text -> Text
padTo Int
n Text
t = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate Int
pad Text
" " where pad :: Int
pad = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
t