-- | Provides 'Log' formatting functionality.
module Shrun.Logging.Formatting
  ( -- * High-level
    formatConsoleLog,
    formatFileLog,

    -- * Low-level
    logToColor,
    logToPrefix,
    levelToColor,
    levelToPrefix,

    -- ** Utils
    formatCommand,
    concatWithLineTrunc,
    displayCmd,
    stripChars,
    brackets,
    formatCommandText,
  )
where

import Data.Text qualified as T
import Effects.Time (getSystemTimeString)
import Shrun.Configuration.Data.CommonLogging.KeyHideSwitch
  ( KeyHideSwitch (KeyHideOff),
  )
import Shrun.Configuration.Data.ConsoleLogging (ConsoleLoggingEnv)
import Shrun.Configuration.Data.FileLogging (FileLoggingEnv)
import Shrun.Configuration.Data.StripControl
  ( StripControl (StripControlAll, StripControlNone, StripControlSmart),
  )
import Shrun.Configuration.Data.Truncation
  ( TruncRegion
      ( TruncCommandName,
        TruncLine
      ),
    Truncation (MkTruncation),
  )
import Shrun.Data.Command (CommandP (MkCommandP), CommandP1)
import Shrun.Data.Text (UnlinedText)
import Shrun.Data.Text qualified as ShrunText
import Shrun.Logging.Types
  ( Log,
    LogLevel
      ( LevelCommand,
        LevelError,
        LevelFatal,
        LevelFinished,
        LevelSuccess,
        LevelTimer,
        LevelWarn
      ),
  )
import Shrun.Logging.Types.Internal
  ( ConsoleLog (UnsafeConsoleLog),
    FileLog (UnsafeFileLog),
  )
import Shrun.Prelude
import Shrun.Utils ((∸))
import Shrun.Utils qualified as Utils
import System.Console.Pretty (Color (Blue, Cyan, Green, Red, White, Yellow))
import System.Console.Pretty qualified as P

-- | Formats a log to be printed to the console.
formatConsoleLog ::
  KeyHideSwitch ->
  ConsoleLoggingEnv ->
  Log ->
  ConsoleLog
formatConsoleLog :: KeyHideSwitch -> ConsoleLoggingEnv -> Log -> ConsoleLog
formatConsoleLog KeyHideSwitch
keyHide ConsoleLoggingEnv
consoleLogging Log
log = Text -> ConsoleLog
UnsafeConsoleLog (Text -> Text
colorize Text
line)
  where
    -- NOTE: We want colorize on the outside for two reasons:
    --
    -- 1. Truncation calculation should not take colorization into account,
    --    as chars are invisible.
    -- 2. Having colorization _inside_ can accidentally cause the "end color"
    --    chars to be stripped, leading to bugs where colorizing bleeds.
    --
    -- This 2nd point is likely the cause for some "color bleeding" that was
    -- occasionally noticed.
    colorize :: Text -> Text
colorize = Color -> Text -> Text
forall a. Pretty a => Color -> a -> a
P.color (Color -> Text -> Text) -> Color -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Log -> Color
logToColor Log
log

    line :: Text
line =
      Maybe (Truncation 'TruncLine, Maybe Natural)
-> Maybe (Truncation 'TruncCommandName)
-> StripControl 'StripControlConsoleLog
-> KeyHideSwitch
-> Log
-> Text
forall (t :: StripControlType).
Maybe (Truncation 'TruncLine, Maybe Natural)
-> Maybe (Truncation 'TruncCommandName)
-> StripControl t
-> KeyHideSwitch
-> Log
-> Text
coreFormatting
        ((,Maybe Natural
forall a. Maybe a
Nothing) (Truncation 'TruncLine -> (Truncation 'TruncLine, Maybe Natural))
-> Maybe (Truncation 'TruncLine)
-> Maybe (Truncation 'TruncLine, Maybe Natural)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ConsoleLoggingEnv
consoleLogging ConsoleLoggingEnv
-> Optic'
     A_Lens NoIx ConsoleLoggingEnv (Maybe (Truncation 'TruncLine))
-> Maybe (Truncation 'TruncLine)
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic'
  A_Lens NoIx ConsoleLoggingEnv (Maybe (Truncation 'TruncLine))
#lineTrunc)
        (ConsoleLoggingEnv
consoleLogging ConsoleLoggingEnv
-> Optic'
     A_Lens
     NoIx
     ConsoleLoggingEnv
     (Maybe (Truncation 'TruncCommandName))
-> Maybe (Truncation 'TruncCommandName)
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic'
  A_Lens
  NoIx
  ConsoleLoggingEnv
  (Maybe (Truncation 'TruncCommandName))
#commandNameTrunc)
        (ConsoleLoggingEnv
consoleLogging ConsoleLoggingEnv
-> Optic'
     A_Lens
     NoIx
     ConsoleLoggingEnv
     (StripControl 'StripControlConsoleLog)
-> StripControl 'StripControlConsoleLog
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic'
  A_Lens
  NoIx
  ConsoleLoggingEnv
  (StripControl 'StripControlConsoleLog)
#stripControl)
        KeyHideSwitch
keyHide
        Log
log

maybeApply :: (a -> b -> b) -> Maybe a -> b -> b
maybeApply :: forall a b. (a -> b -> b) -> Maybe a -> b -> b
maybeApply = (b -> b) -> (a -> b -> b) -> Maybe a -> b -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b -> b
forall a. a -> a
id

-- | Formats a 'Log' into a 'FileLog'. Applies prefix and timestamp.
formatFileLog ::
  ( HasCallStack,
    MonadTime m
  ) =>
  KeyHideSwitch ->
  FileLoggingEnv ->
  Log ->
  m FileLog
formatFileLog :: forall (m :: Type -> Type).
(HasCallStack, MonadTime m) =>
KeyHideSwitch -> FileLoggingEnv -> Log -> m FileLog
formatFileLog KeyHideSwitch
keyHide FileLoggingEnv
fileLogging Log
log = do
  String
currTime <- m String
forall (m :: Type -> Type). (HasCallStack, MonadTime m) => m String
getSystemTimeString
  let timestamp :: Text
timestamp = Bool -> Text -> Text
brackets Bool
False (String -> Text
pack String
currTime)
      timestampLen :: Natural
timestampLen = Int -> Natural
forall a b.
(Bits a, Bits b, HasCallStack, Integral a, Integral b, Show a,
 Typeable a, Typeable b) =>
a -> b
unsafeConvertIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ Text -> Int
T.length Text
timestamp

      line :: Text
line =
        Maybe (Truncation 'TruncLine, Maybe Natural)
-> Maybe (Truncation 'TruncCommandName)
-> StripControl 'StripControlFileLog
-> KeyHideSwitch
-> Log
-> Text
forall (t :: StripControlType).
Maybe (Truncation 'TruncLine, Maybe Natural)
-> Maybe (Truncation 'TruncCommandName)
-> StripControl t
-> KeyHideSwitch
-> Log
-> Text
coreFormatting
          ((,Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
timestampLen) (Truncation 'TruncLine -> (Truncation 'TruncLine, Maybe Natural))
-> Maybe (Truncation 'TruncLine)
-> Maybe (Truncation 'TruncLine, Maybe Natural)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> FileLoggingEnv
fileLogging FileLoggingEnv
-> Optic'
     A_Lens NoIx FileLoggingEnv (Maybe (Truncation 'TruncLine))
-> Maybe (Truncation 'TruncLine)
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx FileLoggingEnv (Maybe (Truncation 'TruncLine))
#lineTrunc)
          (FileLoggingEnv
fileLogging FileLoggingEnv
-> Optic'
     A_Lens NoIx FileLoggingEnv (Maybe (Truncation 'TruncCommandName))
-> Maybe (Truncation 'TruncCommandName)
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic'
  A_Lens NoIx FileLoggingEnv (Maybe (Truncation 'TruncCommandName))
#commandNameTrunc)
          (FileLoggingEnv
fileLogging FileLoggingEnv
-> Optic'
     A_Lens NoIx FileLoggingEnv (StripControl 'StripControlFileLog)
-> StripControl 'StripControlFileLog
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic'
  A_Lens NoIx FileLoggingEnv (StripControl 'StripControlFileLog)
#stripControl)
          KeyHideSwitch
keyHide
          Log
log

      withTimestamp :: Text
withTimestamp =
        [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
          [ Text
timestamp,
            Text
line,
            Text
"\n"
          ]
  FileLog -> m FileLog
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (FileLog -> m FileLog) -> FileLog -> m FileLog
forall a b. (a -> b) -> a -> b
$ Text -> FileLog
UnsafeFileLog Text
withTimestamp

-- | Core formatting, shared by console and file logs. Basic idea:
--
-- 1. If the log contains a command, it is formatted according to
--    'formatCommand' and command name truncation.
--
-- 2. The message is stripped of control chars according to strip control.
--
-- 3. Line truncation is applied if applicable. Note this applies only to
--    the stripped message. The prefix (e.g. level label, timestamp, command
--    name) are always present, though they __do__ count towards the
--    truncation count. I.e. if the prefixes add up to 10 chars, and the
--    line truncation is 15, then we only have 5 chars for the message before
--    truncation kicks in.
coreFormatting ::
  -- | Optional line truncation. If we have some line truncation then there
  -- is a further optional "prefix length". This is so that file logging
  -- can pass in the timestamp length so it is taken into account
  -- (command logging has no special prefix besides ANSI codes, which is
  -- ignored).
  Maybe (Truncation TruncLine, Maybe Natural) ->
  -- | Optional cmd name truncation
  Maybe (Truncation TruncCommandName) ->
  -- | Strip control
  StripControl t ->
  -- | Key hide
  KeyHideSwitch ->
  -- | Log to format
  Log ->
  Text
coreFormatting :: forall (t :: StripControlType).
Maybe (Truncation 'TruncLine, Maybe Natural)
-> Maybe (Truncation 'TruncCommandName)
-> StripControl t
-> KeyHideSwitch
-> Log
-> Text
coreFormatting Maybe (Truncation 'TruncLine, Maybe Natural)
mLineTrunc Maybe (Truncation 'TruncCommandName)
mCommandNameTrunc StripControl t
stripControl KeyHideSwitch
keyHide Log
log =
  Maybe (Truncation 'TruncLine, Maybe Natural)
-> Text -> Text -> Text
concatWithLineTrunc Maybe (Truncation 'TruncLine, Maybe Natural)
mLineTrunc Text
prefix (UnlinedText
msgStripped UnlinedText -> Optic' A_Getter NoIx UnlinedText Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Getter NoIx UnlinedText Text
#unUnlinedText)
  where
    -- prefix is something like "[Success] " or "[Command][some cmd] ".
    -- Notice this does not include ANSI codes or a timestamp.
    prefix :: Text
prefix = case Log
log Log -> Optic' A_Lens NoIx Log (Maybe CommandP1) -> Maybe CommandP1
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Log (Maybe CommandP1)
#cmd of
      Maybe CommandP1
Nothing -> Bool -> Text -> Text
brackets Bool
True Text
logPrefix
      Just CommandP1
cmd ->
        let cmd' :: UnlinedText
cmd' =
              KeyHideSwitch
-> Maybe (Truncation 'TruncCommandName) -> CommandP1 -> UnlinedText
formatCommand
                KeyHideSwitch
keyHide
                Maybe (Truncation 'TruncCommandName)
mCommandNameTrunc
                CommandP1
cmd
         in [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
              [ Bool -> Text -> Text
brackets Bool
False Text
logPrefix,
                UnlinedText
cmd' UnlinedText -> Optic' A_Getter NoIx UnlinedText Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Getter NoIx UnlinedText Text
#unUnlinedText
              ]

    msgStripped :: UnlinedText
msgStripped = UnlinedText -> StripControl t -> UnlinedText
forall (t :: StripControlType).
UnlinedText -> StripControl t -> UnlinedText
stripChars (Log
log Log -> Optic' A_Lens NoIx Log UnlinedText -> UnlinedText
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Log UnlinedText
#msg) StripControl t
stripControl
    logPrefix :: Text
logPrefix = Log -> Text
logToPrefix Log
log

formatCommand ::
  KeyHideSwitch ->
  Maybe (Truncation TruncCommandName) ->
  CommandP1 ->
  UnlinedText
formatCommand :: KeyHideSwitch
-> Maybe (Truncation 'TruncCommandName) -> CommandP1 -> UnlinedText
formatCommand KeyHideSwitch
keyHide Maybe (Truncation 'TruncCommandName)
commandNameTrunc CommandP1
com =
  (Text -> Text) -> UnlinedText -> UnlinedText
ShrunText.reallyUnsafeLiftUnlined (Bool -> Text -> Text
brackets Bool
True (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
truncateNameFn) UnlinedText
cmdName
  where
    -- Get cmd name to display. Always strip control sequences. Futhermore,
    -- strip leading/trailing whitespace.
    cmdName :: UnlinedText
cmdName = CommandP1 -> KeyHideSwitch -> UnlinedText
displayCmd CommandP1
com KeyHideSwitch
keyHide

    -- truncate cmd/name if necessary
    truncateNameFn :: Text -> Text
truncateNameFn =
      (Natural -> Text -> Text) -> Maybe Natural -> Text -> Text
forall a b. (a -> b -> b) -> Maybe a -> b -> b
maybeApply
        Natural -> Text -> Text
Utils.truncateIfNeeded
        (Maybe (Truncation 'TruncCommandName)
commandNameTrunc Maybe (Truncation 'TruncCommandName)
-> Optic'
     A_Prism NoIx (Maybe (Truncation 'TruncCommandName)) Natural
-> Maybe Natural
forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? (Prism
  (Maybe (Truncation 'TruncCommandName))
  (Maybe (Truncation 'TruncCommandName))
  (Truncation 'TruncCommandName)
  (Truncation 'TruncCommandName)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just Prism
  (Maybe (Truncation 'TruncCommandName))
  (Maybe (Truncation 'TruncCommandName))
  (Truncation 'TruncCommandName)
  (Truncation 'TruncCommandName)
-> Optic
     An_Iso
     NoIx
     (Truncation 'TruncCommandName)
     (Truncation 'TruncCommandName)
     Natural
     Natural
-> Optic'
     A_Prism NoIx (Maybe (Truncation 'TruncCommandName)) Natural
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  An_Iso
  NoIx
  (Truncation 'TruncCommandName)
  (Truncation 'TruncCommandName)
  Natural
  Natural
#unTruncation))

-- | Replace newlines with whitespace before stripping, so any strings
-- separated by newlines do not get smashed together.
formatCommandText :: Text -> UnlinedText
formatCommandText :: Text -> UnlinedText
formatCommandText =
  (Text -> Text) -> UnlinedText -> UnlinedText
ShrunText.reallyUnsafeLiftUnlined Text -> Text
T.strip
    (UnlinedText -> UnlinedText)
-> (Text -> UnlinedText) -> Text -> UnlinedText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnlinedText -> UnlinedText
Utils.stripControlAll
    (UnlinedText -> UnlinedText)
-> (Text -> UnlinedText) -> Text -> UnlinedText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> UnlinedText
ShrunText.fromTextReplace

-- | Combines a prefix @p@ and msg @m@ with possible line truncation. If no
-- truncation is given then concatWithLineTrunc is equivalent to @p <> m@.
-- If we are given some line truncation @l@, then we derive
--
-- @
--    k := l - prefix_len -- k is clamped to zero
-- @
--
-- and return
--
-- @
--    prefix <> t'
-- @
--
-- where @t'@ is @t@ truncated to @k@ chars. Notice the prefix is always
-- included untarnished.
concatWithLineTrunc ::
  Maybe (Truncation TruncLine, Maybe Natural) ->
  Text ->
  Text ->
  Text
concatWithLineTrunc :: Maybe (Truncation 'TruncLine, Maybe Natural)
-> Text -> Text -> Text
concatWithLineTrunc Maybe (Truncation 'TruncLine, Maybe Natural)
Nothing Text
prefix Text
msg = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
concatWithLineTrunc (Just (MkTruncation Natural
lineTrunc, Maybe Natural
mPrefixLen)) Text
prefix Text
msg =
  Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Natural -> Text -> Text
Utils.truncateIfNeeded Natural
lineTrunc' Text
msg
  where
    lineTrunc' :: Natural
lineTrunc' =
      Natural
lineTrunc Natural -> Natural -> Natural
forall a. (Ord a, Num a) => a -> a -> a
∸ (Natural
prefixLen Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Int -> Natural
forall a b.
(Bits a, Bits b, HasCallStack, Integral a, Integral b, Show a,
 Typeable a, Typeable b) =>
a -> b
unsafeConvertIntegral (Text -> Int
T.length Text
prefix))

    prefixLen :: Natural
prefixLen = Natural -> Maybe Natural -> Natural
forall a. a -> Maybe a -> a
fromMaybe Natural
0 Maybe Natural
mPrefixLen

-- | Pretty show for 'Command'. If the command has a key, and 'KeyHideSwitch' is
-- 'KeyHideOff' then we return the key. Otherwise we return the command itself.
--
-- >>> displayCmd (MkCommandP Nothing "some long command") KeyHideOn
-- "some long command"
--
-- >>> displayCmd (MkCommandP Nothing "some long command") KeyHideOff
-- "some long command"
--
-- >>> displayCmd (MkCommandP (Just "long") "some long command") KeyHideOn
-- "some long command"
--
-- >>> displayCmd (MkCommandP (Just "long") "some long command") KeyHideOff
-- "long"
displayCmd :: CommandP1 -> KeyHideSwitch -> UnlinedText
displayCmd :: CommandP1 -> KeyHideSwitch -> UnlinedText
displayCmd (MkCommandP (Just Text
key) Text
_) KeyHideSwitch
KeyHideOff = Text -> UnlinedText
formatCommandText Text
key
displayCmd (MkCommandP Maybe Text
_ Text
cmd) KeyHideSwitch
_ = Text -> UnlinedText
formatCommandText Text
cmd

-- | Applies the given 'StripControl' to the 'Text'.
--
-- * 'StripControlAll': Strips whitespace + all control chars.
-- * 'StripControlSmart': Strips whitespace + 'ansi control' chars.
-- * 'StripControlNone': Strips whitespace.
stripChars :: UnlinedText -> StripControl t -> UnlinedText
stripChars :: forall (t :: StripControlType).
UnlinedText -> StripControl t -> UnlinedText
stripChars UnlinedText
txt = \case
  StripControl t
StripControlAll -> UnlinedText -> UnlinedText
Utils.stripControlAll UnlinedText
txt
  -- whitespace
  StripControl t
StripControlNone -> (Text -> Text) -> UnlinedText -> UnlinedText
ShrunText.reallyUnsafeLiftUnlined Text -> Text
T.strip UnlinedText
txt
  StripControl t
StripControlSmart -> UnlinedText -> UnlinedText
Utils.stripControlSmart UnlinedText
txt
{-# INLINE stripChars #-}

-- | Surrounds text with brackets, appending a space if the boolean is 'True'.
--
-- ==== __Examples__
--
-- >>> brackets False "text"
-- "[text]"
--
-- >>> brackets True "text"
-- "[text] "
brackets :: Bool -> Text -> Text
brackets :: Bool -> Text -> Text
brackets Bool
False Text
s = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
brackets Bool
True Text
s = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"] "

-- | Transforms log to a color based on its 'LogLevel'.
logToColor :: Log -> Color
logToColor :: Log -> Color
logToColor = LogLevel -> Color
levelToColor (LogLevel -> Color) -> (Log -> LogLevel) -> Log -> Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' A_Lens NoIx Log LogLevel -> Log -> LogLevel
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx Log LogLevel
#lvl

-- | Transforms log to a prefix based on its 'LogLevel'.
logToPrefix :: Log -> Text
logToPrefix :: Log -> Text
logToPrefix = LogLevel -> Text
levelToPrefix (LogLevel -> Text) -> (Log -> LogLevel) -> Log -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' A_Lens NoIx Log LogLevel -> Log -> LogLevel
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx Log LogLevel
#lvl

-- | Maps 'LogLevel' to 'Color'.
levelToColor :: LogLevel -> Color
levelToColor :: LogLevel -> Color
levelToColor LogLevel
LevelCommand = Color
White
levelToColor LogLevel
LevelFinished = Color
Blue
levelToColor LogLevel
LevelTimer = Color
Cyan
levelToColor LogLevel
LevelSuccess = Color
Green
levelToColor LogLevel
LevelWarn = Color
Yellow
levelToColor LogLevel
LevelError = Color
Red
levelToColor LogLevel
LevelFatal = Color
Red

-- | Maps 'LogLevel' to \'Prefix\'.
levelToPrefix :: LogLevel -> Text
levelToPrefix :: LogLevel -> Text
levelToPrefix LogLevel
LevelCommand = Text
"Command"
levelToPrefix LogLevel
LevelFinished = Text
"Finished"
levelToPrefix LogLevel
LevelTimer = Text
"Timer"
levelToPrefix LogLevel
LevelSuccess = Text
"Success"
levelToPrefix LogLevel
LevelWarn = Text
"Warn"
levelToPrefix LogLevel
LevelError = Text
"Error"
levelToPrefix LogLevel
LevelFatal = Text
"Fatal"