-- | 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 = 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 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
..} <- 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 {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
..} = Bool -> Colors
getColors Bool
useColor

    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
            ]

  ByteString -> Maybe ByteString
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$
    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

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