-- | 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 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 qualified Data.ByteString.Lazy as BSL
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Time (defaultTimeLocale, formatTime)
import qualified Data.Vector as V

reformatTerminal :: Bool -> LogLevel -> ByteString -> ByteString
reformatTerminal :: Bool -> LogLevel -> ByteString -> ByteString
reformatTerminal Bool
useColor LogLevel
logLevel ByteString
bytes = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
bytes (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ do
  LoggedMessage {Maybe LogSource
Maybe Loc
UTCTime
LogSource
KeyMap Value
LogLevel
loggedMessageTimestamp :: LoggedMessage -> UTCTime
loggedMessageLevel :: LoggedMessage -> LogLevel
loggedMessageLoc :: LoggedMessage -> Maybe Loc
loggedMessageLogSource :: LoggedMessage -> Maybe LogSource
loggedMessageThreadContext :: LoggedMessage -> KeyMap Value
loggedMessageText :: LoggedMessage -> LogSource
loggedMessageMeta :: LoggedMessage -> KeyMap Value
loggedMessageMeta :: KeyMap Value
loggedMessageText :: LogSource
loggedMessageThreadContext :: KeyMap Value
loggedMessageLogSource :: Maybe LogSource
loggedMessageLoc :: Maybe Loc
loggedMessageLevel :: LogLevel
loggedMessageTimestamp :: UTCTime
..} <- ByteString -> Maybe LoggedMessage
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> Maybe LoggedMessage)
-> ByteString -> Maybe LoggedMessage
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict ByteString
bytes

  let
    colors :: Colors
colors@Colors {LogSource -> LogSource
dim :: Colors -> LogSource -> LogSource
bold :: Colors -> LogSource -> LogSource
red :: Colors -> LogSource -> LogSource
green :: Colors -> LogSource -> LogSource
yellow :: Colors -> LogSource -> LogSource
blue :: Colors -> LogSource -> LogSource
magenta :: Colors -> LogSource -> LogSource
cyan :: Colors -> LogSource -> LogSource
black :: Colors -> LogSource -> LogSource
gray :: Colors -> LogSource -> LogSource
dim :: LogSource -> LogSource
bold :: LogSource -> LogSource
red :: LogSource -> LogSource
green :: LogSource -> LogSource
yellow :: LogSource -> LogSource
blue :: LogSource -> LogSource
magenta :: LogSource -> LogSource
cyan :: LogSource -> LogSource
black :: LogSource -> LogSource
gray :: LogSource -> LogSource
..} = Bool -> Colors
getColors Bool
useColor

    logTimestampText :: LogSource
logTimestampText =
      LogSource -> LogSource
dim (LogSource -> LogSource) -> LogSource -> LogSource
forall a b. (a -> b) -> a -> b
$ String -> LogSource
pack (String -> LogSource) -> String -> LogSource
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

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

    loggedSourceAsMap :: KeyMap Value
loggedSourceAsMap =
      (LogSource -> KeyMap Value) -> Maybe LogSource -> KeyMap Value
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)
-> (LogSource -> Value) -> LogSource -> KeyMap Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSource -> Value
String) Maybe LogSource
loggedMessageLogSource

  ByteString -> Maybe ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ LogSource -> ByteString
encodeUtf8 (LogSource -> ByteString) -> LogSource -> ByteString
forall a b. (a -> b) -> a -> b
$ [LogSource] -> LogSource
forall a. Monoid a => [a] -> a
mconcat
    [ LogSource
logTimestampText LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
" "
    , LogSource
"[" LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
logLevelText LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
"] "
    , LogSource -> LogSource
bold (LogSource -> LogSource) -> LogSource -> LogSource
forall a b. (a -> b) -> a -> b
$ Int -> LogSource -> LogSource
padTo Int
31 LogSource
loggedMessageText
    , Colors -> KeyMap Value -> LogSource
colorizeKeyMap Colors
colors KeyMap Value
loggedSourceAsMap
    , Colors -> KeyMap Value -> LogSource
colorizeKeyMap Colors
colors KeyMap Value
loggedMessageThreadContext
    , Colors -> KeyMap Value -> LogSource
colorizeKeyMap Colors
colors KeyMap Value
loggedMessageMeta
    ]

colorizeKeyMap :: Colors -> KeyMap Value -> Text
colorizeKeyMap :: Colors -> KeyMap Value -> LogSource
colorizeKeyMap Colors {LogSource -> LogSource
dim :: LogSource -> LogSource
bold :: LogSource -> LogSource
red :: LogSource -> LogSource
green :: LogSource -> LogSource
yellow :: LogSource -> LogSource
blue :: LogSource -> LogSource
magenta :: LogSource -> LogSource
cyan :: LogSource -> LogSource
black :: LogSource -> LogSource
gray :: LogSource -> LogSource
dim :: Colors -> LogSource -> LogSource
bold :: Colors -> LogSource -> LogSource
red :: Colors -> LogSource -> LogSource
green :: Colors -> LogSource -> LogSource
yellow :: Colors -> LogSource -> LogSource
blue :: Colors -> LogSource -> LogSource
magenta :: Colors -> LogSource -> LogSource
cyan :: Colors -> LogSource -> LogSource
black :: Colors -> LogSource -> LogSource
gray :: Colors -> LogSource -> LogSource
..} KeyMap Value
km
  | KeyMap Value -> Bool
forall v. KeyMap v -> Bool
KeyMap.null KeyMap Value
km = LogSource
""
  | Bool
otherwise = LogSource
" " LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource -> [LogSource] -> LogSource
T.intercalate LogSource
" " [LogSource]
keyValues
 where
  keyValues :: [LogSource]
keyValues = ((Key, Value) -> LogSource) -> [(Key, Value)] -> [LogSource]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> Value -> LogSource) -> (Key, Value) -> LogSource
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> Value -> LogSource
renderPair) ([(Key, Value)] -> [LogSource]) -> [(Key, Value)] -> [LogSource]
forall a b. (a -> b) -> a -> b
$ KeyMap Value -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList KeyMap Value
km

  renderPair :: Key -> Value -> LogSource
renderPair Key
k Value
v = LogSource -> LogSource
cyan (Key -> LogSource
Key.toText Key
k) LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource
"=" LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> LogSource -> LogSource
magenta (Value -> LogSource
fromValue Value
v)

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

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

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

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

padTo :: Int -> Text -> Text
padTo :: Int -> LogSource -> LogSource
padTo Int
n LogSource
t = LogSource
t LogSource -> LogSource -> LogSource
forall a. Semigroup a => a -> a -> a
<> Int -> LogSource -> LogSource
T.replicate Int
pad LogSource
" " 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
- LogSource -> Int
T.length LogSource
t