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

    -- ** Final logs
    formatConsoleMultiLineLogs,
    formatFileMultiLineLogs,

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

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

import Data.Foldable qualified as F
import Data.List.NonEmpty qualified as NE
import Data.Monoid (Sum, getSum)
import Data.Text qualified as T
import Effects.Time (getSystemTimeString)
import Shrun.Command.Types
  ( CommandP1,
    CommandStatus
      ( CommandFailure,
        CommandRunning,
        CommandSuccess,
        CommandWaiting
      ),
  )
import Shrun.Configuration.Data.CommonLogging.KeyHideSwitch
  ( KeyHideSwitch (MkKeyHideSwitch),
  )
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.Configuration.Env.Types (HasCommands, getReadCommandStatus)
import Shrun.Data.Text (UnlinedText)
import Shrun.Data.Text qualified as ShrunText
import Shrun.Logging.Types
  ( Log,
    LogLevel
      ( LevelCommand,
        LevelDebug,
        LevelError,
        LevelFatal,
        LevelFinished,
        LevelKilled,
        LevelSuccess,
        LevelTimer,
        LevelWarn
      ),
    LogMessage,
  )
import Shrun.Logging.Types qualified as Types
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 ::
  ( HasCallStack,
    HasCommands env,
    MonadAtomic m,
    MonadReader env m
  ) =>
  KeyHideSwitch ->
  ConsoleLoggingEnv ->
  Log ->
  m ConsoleLog
formatConsoleLog :: forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
KeyHideSwitch -> ConsoleLoggingEnv -> Log -> m ConsoleLog
formatConsoleLog KeyHideSwitch
keyHide ConsoleLoggingEnv
consoleLogging Log
log = do
  Text
line <-
    Bool
-> Maybe (Truncation 'TruncLine, Maybe Int)
-> Maybe (Truncation 'TruncCommandName)
-> Bool
-> StripControl 'StripControlConsoleLog
-> KeyHideSwitch
-> Log
-> m Text
forall env (m :: Type -> Type) (t :: StripControlType).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
Bool
-> Maybe (Truncation 'TruncLine, Maybe Int)
-> Maybe (Truncation 'TruncCommandName)
-> Bool
-> StripControl t
-> KeyHideSwitch
-> Log
-> m Text
coreFormatting
      Bool
False
      ((,Maybe Int
forall a. Maybe a
Nothing) (Truncation 'TruncLine -> (Truncation 'TruncLine, Maybe Int))
-> Maybe (Truncation 'TruncLine)
-> Maybe (Truncation 'TruncLine, Maybe Int)
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)
      Bool
True
      (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

  pure $ 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

-- | Like 'formatConsoleLog', but for multiple logs. Concatenates all
-- together with a newline.
formatConsoleMultiLineLogs ::
  ( HasCallStack,
    HasCommands env,
    MonadAtomic m,
    MonadReader env m
  ) =>
  KeyHideSwitch ->
  ConsoleLoggingEnv ->
  NonEmpty Log ->
  m ConsoleLog
formatConsoleMultiLineLogs :: forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
KeyHideSwitch -> ConsoleLoggingEnv -> NonEmpty Log -> m ConsoleLog
formatConsoleMultiLineLogs KeyHideSwitch
keyHide ConsoleLoggingEnv
consoleLogging logs :: NonEmpty Log
logs@(Log
l :| [Log]
_) =
  (NonEmpty Text -> ConsoleLog) -> m (NonEmpty Text) -> m ConsoleLog
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ( Text -> ConsoleLog
UnsafeConsoleLog
        -- No need to color each line individually: we can just do it once.
        (Text -> ConsoleLog)
-> (NonEmpty Text -> Text) -> NonEmpty Text -> ConsoleLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Text
color
        (Text -> Text) -> (NonEmpty Text -> Text) -> NonEmpty Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> [Text] -> Text
T.intercalate Text
"\n"
        ([Text] -> Text)
-> (NonEmpty Text -> [Text]) -> NonEmpty Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
F.toList
    )
    (m (NonEmpty Text) -> m ConsoleLog)
-> (NonEmpty Log -> m (NonEmpty Text))
-> NonEmpty Log
-> m ConsoleLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((Bool, Log) -> m Text)
-> NonEmpty (Bool, Log) -> m (NonEmpty Text)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse (Bool, Log) -> m Text
mkLine
    (NonEmpty (Bool, Log) -> m (NonEmpty Text))
-> (NonEmpty Log -> NonEmpty (Bool, Log))
-> NonEmpty Log
-> m (NonEmpty Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NonEmpty Log -> NonEmpty (Bool, Log)
forall a. NonEmpty a -> NonEmpty (Bool, a)
zipMultilineSpacePrefix
    (NonEmpty Log -> m ConsoleLog) -> NonEmpty Log -> m ConsoleLog
forall a b. (a -> b) -> a -> b
$ NonEmpty Log
logs
  where
    mkLine :: (Bool, Log) -> m Text
mkLine (Bool
prefixSpace, Log
log) =
      Bool
-> Maybe (Truncation 'TruncLine, Maybe Int)
-> Maybe (Truncation 'TruncCommandName)
-> Bool
-> StripControl 'StripControlConsoleLog
-> KeyHideSwitch
-> Log
-> m Text
forall env (m :: Type -> Type) (t :: StripControlType).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
Bool
-> Maybe (Truncation 'TruncLine, Maybe Int)
-> Maybe (Truncation 'TruncCommandName)
-> Bool
-> StripControl t
-> KeyHideSwitch
-> Log
-> m Text
coreFormatting
        Bool
prefixSpace
        ((,Maybe Int
forall a. Maybe a
Nothing) (Truncation 'TruncLine -> (Truncation 'TruncLine, Maybe Int))
-> Maybe (Truncation 'TruncLine)
-> Maybe (Truncation 'TruncLine, Maybe Int)
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)
        Bool
False
        (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

    color :: Text -> Text
color = Color -> Text -> Text
forall a. Pretty a => Color -> a -> a
P.color (Log -> Color
logToColor Log
l)

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,
    HasCommands env,
    MonadAtomic m,
    MonadReader env m,
    MonadTime m
  ) =>
  KeyHideSwitch ->
  FileLoggingEnv ->
  Log ->
  m FileLog
formatFileLog :: forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m, MonadReader env m,
 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 = Text -> Text
brackets (String -> Text
pack String
currTime)
      timestampLen :: Int
timestampLen = Text -> Int
T.length Text
timestamp

  Text
line <-
    Bool
-> Maybe (Truncation 'TruncLine, Maybe Int)
-> Maybe (Truncation 'TruncCommandName)
-> Bool
-> StripControl 'StripControlFileLog
-> KeyHideSwitch
-> Log
-> m Text
forall env (m :: Type -> Type) (t :: StripControlType).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
Bool
-> Maybe (Truncation 'TruncLine, Maybe Int)
-> Maybe (Truncation 'TruncCommandName)
-> Bool
-> StripControl t
-> KeyHideSwitch
-> Log
-> m Text
coreFormatting
      Bool
False
      ((,Int -> Maybe Int
forall a. a -> Maybe a
Just Int
timestampLen) (Truncation 'TruncLine -> (Truncation 'TruncLine, Maybe Int))
-> Maybe (Truncation 'TruncLine)
-> Maybe (Truncation 'TruncLine, Maybe Int)
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)
      Bool
False
      (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

  let 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
{-# INLINEABLE formatFileLog #-}

zipMultilineSpacePrefix :: NonEmpty a -> NonEmpty (Bool, a)
zipMultilineSpacePrefix :: forall a. NonEmpty a -> NonEmpty (Bool, a)
zipMultilineSpacePrefix = NonEmpty Bool -> NonEmpty a -> NonEmpty (Bool, a)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip (Bool
False Bool -> [Bool] -> NonEmpty Bool
forall a. a -> [a] -> NonEmpty a
:| [Bool
True, Bool
True ..])

-- | Like 'formatFileLog', but for multiple logs. Concatenates all
-- together.
formatFileMultiLineLogs ::
  ( HasCallStack,
    HasCommands env,
    MonadAtomic m,
    MonadReader env m,
    MonadTime m
  ) =>
  KeyHideSwitch ->
  FileLoggingEnv ->
  NonEmpty Log ->
  m FileLog
formatFileMultiLineLogs :: forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m, MonadReader env m,
 MonadTime m) =>
KeyHideSwitch -> FileLoggingEnv -> NonEmpty Log -> m FileLog
formatFileMultiLineLogs KeyHideSwitch
keyHide FileLoggingEnv
fileLogging NonEmpty Log
logs = do
  String
currTime <- m String
forall (m :: Type -> Type). (HasCallStack, MonadTime m) => m String
getSystemTimeString
  let timestamp :: Text
timestamp = Text -> Text
brackets (String -> Text
pack String
currTime)
      timestampLen :: Int
timestampLen = Text -> Int
T.length Text
timestamp

      mkLine :: (Bool, Log) -> m Text
mkLine (Bool
prefixSpace, Log
log) = do
        let withTs :: Text -> Text
withTs =
              if Bool
prefixSpace
                then Text -> Text
forall {a}. (Monoid a, IsString a) => a -> a
withNoTimestamp
                else Text -> Text
withTimestamp
        Text -> Text
withTs
          (Text -> Text) -> m Text -> m Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Maybe (Truncation 'TruncLine, Maybe Int)
-> Maybe (Truncation 'TruncCommandName)
-> Bool
-> StripControl 'StripControlFileLog
-> KeyHideSwitch
-> Log
-> m Text
forall env (m :: Type -> Type) (t :: StripControlType).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
Bool
-> Maybe (Truncation 'TruncLine, Maybe Int)
-> Maybe (Truncation 'TruncCommandName)
-> Bool
-> StripControl t
-> KeyHideSwitch
-> Log
-> m Text
coreFormatting
            Bool
prefixSpace
            ((,Int -> Maybe Int
forall a. a -> Maybe a
Just Int
timestampLen) (Truncation 'TruncLine -> (Truncation 'TruncLine, Maybe Int))
-> Maybe (Truncation 'TruncLine)
-> Maybe (Truncation 'TruncLine, Maybe Int)
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)
            Bool
False
            (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 -> Text
withTimestamp Text
line =
        [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
          [ Text
timestamp,
            Text
line,
            Text
"\n"
          ]

      withNoTimestamp :: a -> a
withNoTimestamp a
line =
        [a] -> a
forall a. Monoid a => [a] -> a
mconcat
          [ a
line,
            a
"\n"
          ]

  (NonEmpty Text -> FileLog) -> m (NonEmpty Text) -> m FileLog
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ( Text -> FileLog
UnsafeFileLog
        (Text -> FileLog)
-> (NonEmpty Text -> Text) -> NonEmpty Text -> FileLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        ([Text] -> Text)
-> (NonEmpty Text -> [Text]) -> NonEmpty Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
F.toList
    )
    (m (NonEmpty Text) -> m FileLog)
-> (NonEmpty Log -> m (NonEmpty Text)) -> NonEmpty Log -> m FileLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((Bool, Log) -> m Text)
-> NonEmpty (Bool, Log) -> m (NonEmpty Text)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse (Bool, Log) -> m Text
mkLine
    (NonEmpty (Bool, Log) -> m (NonEmpty Text))
-> (NonEmpty Log -> NonEmpty (Bool, Log))
-> NonEmpty Log
-> m (NonEmpty Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NonEmpty Log -> NonEmpty (Bool, Log)
forall a. NonEmpty a -> NonEmpty (Bool, a)
zipMultilineSpacePrefix
    (NonEmpty Log -> m FileLog) -> NonEmpty Log -> m FileLog
forall a b. (a -> b) -> a -> b
$ NonEmpty Log
logs
{-# INLINEABLE formatFileMultiLineLogs #-}

-- | 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 ::
  ( HasCallStack,
    HasCommands env,
    MonadAtomic m,
    MonadReader env m
  ) =>
  -- | If true, the prefix is replaced with whitespace. This is for multiline,
  -- final logs, where we only want the prefix on the first line. Normal usage
  -- includes the prefix.
  Bool ->
  -- | 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 Int) ->
  -- | Optional cmd name truncation
  Maybe (Truncation TruncCommandName) ->
  -- | If true, strips leading whitespace. This is so that file logging
  -- can preserve leading whitespace (so that the file output retains
  -- potential alignment; alignment is irrelevant to console logs).
  --
  -- This is for leading only, not trailing, as the latter is irrelevant to
  -- formatting, and we may want trailing whitespace if we ever concat two
  -- logs together.
  Bool ->
  -- | Strip control
  StripControl t ->
  -- | Key hide
  KeyHideSwitch ->
  -- | Log to format
  Log ->
  m Text
coreFormatting :: forall env (m :: Type -> Type) (t :: StripControlType).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
Bool
-> Maybe (Truncation 'TruncLine, Maybe Int)
-> Maybe (Truncation 'TruncCommandName)
-> Bool
-> StripControl t
-> KeyHideSwitch
-> Log
-> m Text
coreFormatting
  Bool
spacePrefix
  Maybe (Truncation 'TruncLine, Maybe Int)
mLineTrunc
  Maybe (Truncation 'TruncCommandName)
mCommandNameTrunc
  Bool
stripLeading
  StripControl t
stripControl
  KeyHideSwitch
keyHide
  Log
log = do
    Text
statusPrefix <- case Log
log Log -> Optic' A_Lens NoIx Log LogLevel -> LogLevel
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Log LogLevel
#lvl of
      LogLevel
LevelFinished -> m Text
mkStatus
      LogLevel
LevelKilled -> m Text
mkStatus
      LogLevel
LevelTimer -> m Text
mkStatus
      LogLevel
_ -> Text -> m Text
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Text
""

    let -- prefix is something like "[Success] " or "[Command][some cmd] ".
        -- Notice this does not include ANSI codes or a timestamp.
        prefix :: Text
prefix =
          [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text -> Text
brackets Text
logPrefix,
              Text
statusPrefix,
              Text
cmdPrefix,
              Text
" "
            ]

        finalPrefix :: Text
finalPrefix =
          if Bool
spacePrefix
            then Text
"  "
            else Text
prefix

        msgStripControlled :: LogMessage
msgStripControlled = LogMessage -> StripControl t -> LogMessage
forall (t :: StripControlType).
LogMessage -> StripControl t -> LogMessage
stripChars (Log
log Log -> Optic' A_Lens NoIx Log LogMessage -> LogMessage
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Log LogMessage
#msg) StripControl t
stripControl
        msgStripped :: LogMessage
msgStripped =
          if Bool
stripLeading
            then (Text -> Text) -> LogMessage -> LogMessage
Types.unsafeMapLogMessage Text -> Text
T.stripStart LogMessage
msgStripControlled
            else LogMessage
msgStripControlled

        logPrefix :: Text
logPrefix = Log -> Text
logToPrefix Log
log

        cmdPrefix :: Text
cmdPrefix = 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 -> Text
""
          Just CommandP1
cmd ->
            KeyHideSwitch
-> Maybe (Truncation 'TruncCommandName) -> CommandP1 -> UnlinedText
formatCommand KeyHideSwitch
keyHide Maybe (Truncation 'TruncCommandName)
mCommandNameTrunc CommandP1
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

    Text -> m Text
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ Maybe (Truncation 'TruncLine, Maybe Int) -> Text -> Text -> Text
concatWithLineTrunc Maybe (Truncation 'TruncLine, Maybe Int)
mLineTrunc Text
finalPrefix (LogMessage
msgStripped LogMessage -> Optic' A_Getter NoIx LogMessage Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Getter NoIx LogMessage Text
#unLogMessage)
    where
      mkStatus :: m Text
mkStatus = do
        HashMap CommandIndex (CommandP1, CommandStatus)
statusMap <- m CommandStatusMap
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
m CommandStatusMap
getReadCommandStatus m CommandStatusMap
-> (CommandStatusMap
    -> HashMap CommandIndex (CommandP1, CommandStatus))
-> m (HashMap CommandIndex (CommandP1, CommandStatus))
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> Optic'
  An_Iso
  NoIx
  CommandStatusMap
  (HashMap CommandIndex (CommandP1, CommandStatus))
-> CommandStatusMap
-> HashMap CommandIndex (CommandP1, CommandStatus)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic'
  An_Iso
  NoIx
  CommandStatusMap
  (HashMap CommandIndex (CommandP1, CommandStatus))
#unCommandStatusMap
        let countStatuses :: (a, CommandStatus) -> (a, b, c, d)
countStatuses (a
_, CommandStatus
status) = case CommandStatus
status of
              CommandStatus
CommandWaiting -> (a
1, b
0, c
0, d
0)
              CommandRunning (Maybe Pid, [Pid])
_ -> (a
0, b
1, c
0, d
0)
              CommandStatus
CommandFailure -> (a
0, b
0, c
1, d
0)
              CommandStatus
CommandSuccess -> (a
0, b
0, c
0, d
1)

            (Sum Int
w, Sum Int
r, Sum Int
f, Sum Int
s) = ((CommandP1, CommandStatus)
 -> (Sum Int, Sum Int, Sum Int, Sum Int))
-> HashMap CommandIndex (CommandP1, CommandStatus)
-> (Sum Int, Sum Int, Sum Int, Sum Int)
forall m a. Monoid m => (a -> m) -> HashMap CommandIndex a -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (CommandP1, CommandStatus) -> (Sum Int, Sum Int, Sum Int, Sum Int)
forall {a} {b} {c} {d} {a}.
(Num a, Num b, Num c, Num d) =>
(a, CommandStatus) -> (a, b, c, d)
countStatuses HashMap CommandIndex (CommandP1, CommandStatus)
statusMap

        Text -> m Text
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
          (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
brackets
          (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Sum Int -> Text
tos Sum Int
w,
              Text
"|",
              Sum Int -> Text
tos Sum Int
r,
              Text
"|",
              Sum Int -> Text
tos Sum Int
f,
              Text
"|",
              Sum Int -> Text
tos Sum Int
s
            ]

      tos :: Sum Int -> Text
      tos :: Sum Int -> Text
tos = Int -> Text
forall a. Show a => a -> Text
showt (Int -> Text) -> (Sum Int -> Int) -> Sum Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sum Int -> Int
forall a. Sum a -> a
getSum

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.reallyUnsafeMap (Text -> Text
brackets (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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 =
      (Int -> Text -> Text) -> Maybe Int -> Text -> Text
forall a b. (a -> b -> b) -> Maybe a -> b -> b
maybeApply
        Int -> Text -> Text
Utils.truncateIfNeeded
        (Maybe (Truncation 'TruncCommandName)
commandNameTrunc Maybe (Truncation 'TruncCommandName)
-> Optic' A_Prism NoIx (Maybe (Truncation 'TruncCommandName)) Int
-> Maybe Int
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)
     Int
     Int
-> Optic' A_Prism NoIx (Maybe (Truncation 'TruncCommandName)) Int
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)
  Int
  Int
#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.reallyUnsafeMap (Text -> Text
T.strip (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Text
Utils.stripControlAll)
    (UnlinedText -> UnlinedText)
-> (Text -> UnlinedText) -> Text -> UnlinedText
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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 Int) ->
  Text ->
  Text ->
  Text
concatWithLineTrunc :: Maybe (Truncation 'TruncLine, Maybe Int) -> Text -> Text -> Text
concatWithLineTrunc Maybe (Truncation 'TruncLine, Maybe Int)
Nothing Text
prefix Text
msg = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
concatWithLineTrunc (Just (MkTruncation Int
lineTrunc, Maybe Int
mPrefixLen)) Text
prefix Text
msg =
  Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Utils.truncateIfNeeded Int
lineTrunc' Text
msg
  where
    lineTrunc' :: Int
lineTrunc' =
      Int
lineTrunc Int -> Int -> Int
forall a. (Ord a, Num a) => a -> a -> a
∸ (Int
prefixLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
prefix)

    prefixLen :: Int
prefixLen = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
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.
--
-- >>> import Shrun.Command.Types (CommandP (MkCommandP), unsafeFromInt)
-- >>> import Shrun.Configuration.Data.CommonLogging.KeyHideSwitch (KeyHideSwitch (MkKeyHideSwitch))
--
-- >>> let idx = unsafeFromInt 1
-- >>> let mkCmd = MkCommandP idx
-- >>> let fmt k cmd kh = view #unUnlinedText $ displayCmd (mkCmd k cmd) kh
--
-- >>> fmt Nothing "some long command" (MkKeyHideSwitch true)
-- "some long command"
--
-- >>> fmt Nothing "some long command" (MkKeyHideSwitch false)
-- "some long command"
--
-- >>> fmt (Just "long") "some long command" (MkKeyHideSwitch true)
-- "some long command"
--
-- >>> fmt (Just "long") "some long command" (MkKeyHideSwitch false)
-- "long"
displayCmd :: CommandP1 -> KeyHideSwitch -> UnlinedText
displayCmd :: CommandP1 -> KeyHideSwitch -> UnlinedText
displayCmd CommandP1
cmd KeyHideSwitch
kh = case (CommandP1
cmd CommandP1
-> Optic' A_Lens NoIx CommandP1 (Maybe Text) -> Maybe Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandP1 (Maybe Text)
#key, KeyHideSwitch
kh) of
  (Just Text
key, MkKeyHideSwitch Bool
False) -> Text -> UnlinedText
formatCommandText Text
key
  (Maybe Text, KeyHideSwitch)
_ -> Text -> UnlinedText
formatCommandText (CommandP1
cmd CommandP1 -> Optic' A_Lens NoIx CommandP1 Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandP1 Text
#command)

-- | Applies the given 'StripControl' to the 'Text'.
--
-- * 'StripControlAll': All control chars.
-- * 'StripControlSmart': Ansi control chars.
-- * 'StripControlNone': Nothing.
stripChars :: LogMessage -> StripControl t -> LogMessage
stripChars :: forall (t :: StripControlType).
LogMessage -> StripControl t -> LogMessage
stripChars LogMessage
txt =
  \case
    -- Coerce is needed as stripControl operators on UnlinedText. Originally
    -- this was convenient as our log was UnlinedText, but now it is
    -- LogMessage.
    StripControl t
StripControlAll -> (Text -> Text) -> LogMessage -> LogMessage
forall a b. Coercible a b => a -> b
coerce Text -> Text
Utils.stripControlAll LogMessage
txt
    StripControl t
StripControlNone -> LogMessage
txt
    StripControl t
StripControlSmart -> (Text -> Text) -> LogMessage -> LogMessage
forall a b. Coercible a b => a -> b
coerce Text -> Text
Utils.stripControlSmart LogMessage
txt
{-# INLINE stripChars #-}

-- | Surrounds text with brackets, appending a space if the boolean is 'True'.
--
-- ==== __Examples__
--
-- >>> brackets "text"
-- "[text]"
brackets :: Text -> Text
brackets :: Text -> Text
brackets 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
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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
LevelDebug = Color
White
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
levelToColor LogLevel
LevelKilled = Color
Red

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