-- | 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.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 qualified Data.ByteString.Lazy as BSL
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 :: Int -> Bool -> LogLevel -> ByteString -> ByteString
reformatTerminal :: Int -> Bool -> LogLevel -> ByteString -> ByteString
reformatTerminal Int
breakpoint Bool
useColor LogLevel
logLevel ByteString
bytes = forall a. a -> Maybe a -> a
fromMaybe ByteString
bytes forall a b. (a -> b) -> a -> b
$ do
  LoggedMessage {Maybe Text
Maybe Loc
UTCTime
Text
KeyMap Value
LogLevel
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
loggedMessageMeta :: KeyMap Value
loggedMessageText :: Text
loggedMessageThreadContext :: KeyMap Value
loggedMessageLogSource :: Maybe Text
loggedMessageLoc :: Maybe Loc
loggedMessageLevel :: LogLevel
loggedMessageTimestamp :: UTCTime
..} <- forall a. FromJSON a => ByteString -> Maybe a
decode forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict ByteString
bytes

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

    logTimestampPiece :: LogPiece
logTimestampPiece = (Text -> Text) -> Text -> LogPiece
logPiece Text -> Text
dim forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ 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 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 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 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 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 forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
padTo Int
9 Text
x

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

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

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

    logAttrsPiece :: LogPiece
logAttrsPiece = 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 = forall a. Monoid a => [a] -> a
mconcat [LogPiece
logPrefixPiece, LogPiece
logMessagePiece, LogPiece
logAttrsPiece]

    multiLineLogPiece :: LogPiece
multiLineLogPiece =
      let
        shift :: LogPiece
shift = LogPiece
"\n" forall a. Semigroup a => a -> a -> a
<> Int -> LogPiece
LogPiece.offset (LogPiece -> Int
LogPiece.visibleLength LogPiece
logPrefixPiece)
      in
        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
          ]

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ LogPiece -> ByteString
LogPiece.bytestring
    forall a b. (a -> b) -> a -> b
$ if LogPiece -> Int
LogPiece.visibleLength LogPiece
oneLineLogPiece forall a. Ord a => a -> a -> Bool
<= Int
breakpoint
        then LogPiece
oneLineLogPiece
        else LogPiece
multiLineLogPiece

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

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

dropSuffix :: Text -> Text -> Text
dropSuffix :: Text -> Text -> Text
dropSuffix Text
suffix Text
t = forall a. a -> Maybe a -> a
fromMaybe Text
t 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 forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate Int
pad Text
" " where pad :: Int
pad = forall a. Ord a => a -> a -> a
max Int
0 forall a b. (a -> b) -> a -> b
$ Int
n forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
t