-- | Provides logging functionality. This is a high-level picture of how
-- logging works:
--
-- 1. "Shrun.IO" sends logs per command based on the environment (i.e. is file
--    logging on and/or do we log commands). If any logs are produced, they
--    are formatted and sent directly to a queue.
--
-- 2. "Shrun" also produces logs. These are "higher-level" e.g. success/failure
--    status of a given command, fatal errors, etc. "Shrun" uses the functions
--    here (e.g. putRegionLog) that handles deciding if a given log
--    should be written to either/both of the console/file log queues.
--
-- 3. "Shrun" has two threads -- one for each queue -- that poll their
--    respective queues and writes logs as they are found. These do no
--    environment checking; any logs that make it to the queue are eventually
--    written.
module Shrun.Logging
  ( -- * Writing logs
    putRegionLog,
    putRegionMultiLineLog,
    regionLogToConsoleQueue,
    logToFileQueue,

    -- * Direct logs
    putRegionLogDirect,
    putRegionMultiLineLogDirect,

    -- * Debug
    putDebugLog,
    putDebugLogDirect,

    -- * Misc
    mkUnfinishedCmdLogs,
    logDebug,
    logFile,
  )
where

import Data.HashSet qualified as Set
import Data.List qualified as L
import Data.List.NonEmpty qualified as NE
import Shrun.Command.Types
  ( CommandOrd (MkCommandOrd),
    CommandPhase (CommandPhase1),
    CommandStatus
      ( CommandFailure,
        CommandRunning,
        CommandSuccess,
        CommandWaiting
      ),
  )
import Shrun.Configuration.Data.FileLogging (FileLoggingEnv)
import Shrun.Configuration.Env.Types
  ( HasCommands,
    HasCommonLogging (getCommonLogging),
    HasConsoleLogging (getConsoleLogging),
    HasFileLogging (getFileLogging),
    HasLogging,
    getReadCommandStatus,
  )
import Shrun.Data.Text (UnlinedText)
import Shrun.Logging.Formatting qualified as Formatting
import Shrun.Logging.MonadRegionLogger (MonadRegionLogger (Region))
import Shrun.Logging.MonadRegionLogger qualified as MRL
import Shrun.Logging.Types
  ( FileLog,
    Log (MkLog, cmd, lvl, mode, msg),
    LogLevel (LevelDebug, LevelWarn),
    LogMessage (UnsafeLogMessage),
    LogMode (LogModeFinish),
    LogRegion (LogRegion),
  )
import Shrun.Prelude

-- | Unconditionally writes a log to the console queue. Conditionally
-- writes the log to the file queue, if 'Logging'\'s @fileLogging@ is
-- present.
putRegionLog ::
  forall m env.
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadReader env m,
    MonadTime m
  ) =>
  -- | Region.
  Region m ->
  -- | Log to send.
  Log ->
  m ()
putRegionLog :: forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadReader env m, MonadTime m) =>
Region m -> Log -> m ()
putRegionLog Region m
region Log
lg = do
  CommonLoggingEnv
commonLogging <- (env -> CommonLoggingEnv) -> m CommonLoggingEnv
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> CommonLoggingEnv
forall env. HasCommonLogging env => env -> CommonLoggingEnv
getCommonLogging
  Maybe FileLoggingEnv
mFileLogging <- (env -> Maybe FileLoggingEnv) -> m (Maybe FileLoggingEnv)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> Maybe FileLoggingEnv
forall env. HasFileLogging env => env -> Maybe FileLoggingEnv
getFileLogging

  let keyHide :: KeyHideSwitch
keyHide = CommonLoggingEnv
commonLogging CommonLoggingEnv
-> Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
-> KeyHideSwitch
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
#keyHide

  (ConsoleLoggingEnv
consoleLogging, TBQueue (LogRegion (Region m))
queue, IORef (Maybe (Region m))
_) <- (env
 -> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
     IORef (Maybe (Region m))))
-> m (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
      IORef (Maybe (Region m)))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (forall env r.
HasConsoleLogging env r =>
env -> (ConsoleLoggingEnv, TBQueue (LogRegion r), IORef (Maybe r))
getConsoleLogging @_ @(Region m))

  ConsoleLog
formatted <- KeyHideSwitch -> ConsoleLoggingEnv -> Log -> m ConsoleLog
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
KeyHideSwitch -> ConsoleLoggingEnv -> Log -> m ConsoleLog
Formatting.formatConsoleLog KeyHideSwitch
keyHide ConsoleLoggingEnv
consoleLogging Log
lg
  let regionLog :: LogRegion (Region m)
regionLog = LogMode -> Region m -> ConsoleLog -> LogRegion (Region m)
forall r. LogMode -> r -> ConsoleLog -> LogRegion r
LogRegion (Log
lg Log -> Optic' A_Lens NoIx Log LogMode -> LogMode
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Log LogMode
#mode) Region m
region ConsoleLog
formatted

  TBQueue (LogRegion (Region m)) -> LogRegion (Region m) -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadAtomic m) =>
TBQueue (LogRegion (Region m)) -> LogRegion (Region m) -> m ()
regionLogToConsoleQueue TBQueue (LogRegion (Region m))
queue LogRegion (Region m)
regionLog
  Maybe FileLoggingEnv -> (FileLoggingEnv -> m ()) -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe FileLoggingEnv
mFileLogging ((FileLoggingEnv -> m ()) -> m ())
-> (FileLoggingEnv -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \FileLoggingEnv
fl -> do
    FileLog
fileLog <- KeyHideSwitch -> FileLoggingEnv -> Log -> m FileLog
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m, MonadReader env m,
 MonadTime m) =>
KeyHideSwitch -> FileLoggingEnv -> Log -> m FileLog
Formatting.formatFileLog KeyHideSwitch
keyHide FileLoggingEnv
fl Log
lg
    FileLoggingEnv -> FileLog -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadAtomic m) =>
FileLoggingEnv -> FileLog -> m ()
logToFileQueue FileLoggingEnv
fl FileLog
fileLog
{-# INLINEABLE putRegionLog #-}

-- | Unconditionally writes a log to the console queue. Conditionally
-- writes the log to the file queue, if 'Logging'\'s @fileLogging@ is
-- present.
putRegionMultiLineLog ::
  forall m env.
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadReader env m,
    MonadTime m
  ) =>
  -- | Region.
  Region m ->
  -- | Log to send.
  NonEmpty Log ->
  m ()
putRegionMultiLineLog :: forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadReader env m, MonadTime m) =>
Region m -> NonEmpty Log -> m ()
putRegionMultiLineLog Region m
region NonEmpty Log
logs = do
  CommonLoggingEnv
commonLogging <- (env -> CommonLoggingEnv) -> m CommonLoggingEnv
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> CommonLoggingEnv
forall env. HasCommonLogging env => env -> CommonLoggingEnv
getCommonLogging
  Maybe FileLoggingEnv
mFileLogging <- (env -> Maybe FileLoggingEnv) -> m (Maybe FileLoggingEnv)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> Maybe FileLoggingEnv
forall env. HasFileLogging env => env -> Maybe FileLoggingEnv
getFileLogging

  let keyHide :: KeyHideSwitch
keyHide = CommonLoggingEnv
commonLogging CommonLoggingEnv
-> Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
-> KeyHideSwitch
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
#keyHide

  (ConsoleLoggingEnv
consoleLogging, TBQueue (LogRegion (Region m))
queue, IORef (Maybe (Region m))
_) <- (env
 -> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
     IORef (Maybe (Region m))))
-> m (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
      IORef (Maybe (Region m)))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (forall env r.
HasConsoleLogging env r =>
env -> (ConsoleLoggingEnv, TBQueue (LogRegion r), IORef (Maybe r))
getConsoleLogging @_ @(Region m))

  ConsoleLog
formatted <- KeyHideSwitch -> ConsoleLoggingEnv -> NonEmpty Log -> m ConsoleLog
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
KeyHideSwitch -> ConsoleLoggingEnv -> NonEmpty Log -> m ConsoleLog
Formatting.formatConsoleMultiLineLogs KeyHideSwitch
keyHide ConsoleLoggingEnv
consoleLogging NonEmpty Log
logs
  let regionLog :: LogRegion (Region m)
regionLog = LogMode -> Region m -> ConsoleLog -> LogRegion (Region m)
forall r. LogMode -> r -> ConsoleLog -> LogRegion r
LogRegion LogMode
mode Region m
region ConsoleLog
formatted

  TBQueue (LogRegion (Region m)) -> LogRegion (Region m) -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadAtomic m) =>
TBQueue (LogRegion (Region m)) -> LogRegion (Region m) -> m ()
regionLogToConsoleQueue TBQueue (LogRegion (Region m))
queue LogRegion (Region m)
regionLog
  Maybe FileLoggingEnv -> (FileLoggingEnv -> m ()) -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe FileLoggingEnv
mFileLogging ((FileLoggingEnv -> m ()) -> m ())
-> (FileLoggingEnv -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \FileLoggingEnv
fl -> do
    FileLog
fileLog <- KeyHideSwitch -> FileLoggingEnv -> NonEmpty Log -> m FileLog
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m, MonadReader env m,
 MonadTime m) =>
KeyHideSwitch -> FileLoggingEnv -> NonEmpty Log -> m FileLog
Formatting.formatFileMultiLineLogs KeyHideSwitch
keyHide FileLoggingEnv
fl NonEmpty Log
logs
    FileLoggingEnv -> FileLog -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadAtomic m) =>
FileLoggingEnv -> FileLog -> m ()
logToFileQueue FileLoggingEnv
fl FileLog
fileLog
  where
    mode :: LogMode
mode = NonEmpty Log -> Log
forall a. NonEmpty a -> a
NE.head NonEmpty Log
logs Log -> Optic' A_Lens NoIx Log LogMode -> LogMode
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Log LogMode
#mode
{-# INLINEABLE putRegionMultiLineLog #-}

-- | Writes the log to the console queue.
regionLogToConsoleQueue ::
  ( HasCallStack,
    MonadAtomic m
  ) =>
  -- | Region.
  TBQueue (LogRegion (Region m)) ->
  -- | Log to send.
  LogRegion (Region m) ->
  m ()
regionLogToConsoleQueue :: forall (m :: Type -> Type).
(HasCallStack, MonadAtomic m) =>
TBQueue (LogRegion (Region m)) -> LogRegion (Region m) -> m ()
regionLogToConsoleQueue = TBQueue (LogRegion (Region m)) -> LogRegion (Region m) -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> a -> m ()
writeTBQueueA'
{-# INLINEABLE regionLogToConsoleQueue #-}

-- | Writes the log to the file queue.
logToFileQueue ::
  ( HasCallStack,
    MonadAtomic m
  ) =>
  -- | FileLogging config.
  FileLoggingEnv ->
  -- | Log to send.
  FileLog ->
  m ()
logToFileQueue :: forall (m :: Type -> Type).
(HasCallStack, MonadAtomic m) =>
FileLoggingEnv -> FileLog -> m ()
logToFileQueue FileLoggingEnv
fileLogging = TBQueue FileLog -> FileLog -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> a -> m ()
writeTBQueueA' (FileLoggingEnv
fileLogging FileLoggingEnv
-> Optic' A_Lens NoIx FileLoggingEnv (TBQueue FileLog)
-> TBQueue FileLog
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic
  A_Lens
  NoIx
  FileLoggingEnv
  FileLoggingEnv
  FileLogOpened
  FileLogOpened
#file Optic
  A_Lens
  NoIx
  FileLoggingEnv
  FileLoggingEnv
  FileLogOpened
  FileLogOpened
-> Optic
     A_Lens
     NoIx
     FileLogOpened
     FileLogOpened
     (TBQueue FileLog)
     (TBQueue FileLog)
-> Optic' A_Lens NoIx FileLoggingEnv (TBQueue FileLog)
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
  A_Lens
  NoIx
  FileLogOpened
  FileLogOpened
  (TBQueue FileLog)
  (TBQueue FileLog)
#queue)
{-# INLINEABLE logToFileQueue #-}

-- | Returns formatted log for unfinished commands (waiting and running).
-- Does not actually cancel any commands itself; that is handled by
-- async (race_).
--
-- Returns "multi logs", as each command is rendered on a newline.
-- Hence this should be used with the multi-line log options.
mkUnfinishedCmdLogs ::
  forall m env.
  ( HasCallStack,
    HasCommands env,
    HasCommonLogging env,
    MonadAtomic m,
    MonadReader env m
  ) =>
  m (Tuple2 (Maybe (NonEmpty Log)) (Maybe (NonEmpty Log)))
mkUnfinishedCmdLogs :: forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasCommonLogging env,
 MonadAtomic m, MonadReader env m) =>
m (Maybe (NonEmpty Log), Maybe (NonEmpty Log))
mkUnfinishedCmdLogs = do
  KeyHideSwitch
keyHide <- (env -> KeyHideSwitch) -> m KeyHideSwitch
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
-> CommonLoggingEnv -> KeyHideSwitch
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
#keyHide (CommonLoggingEnv -> KeyHideSwitch)
-> (env -> CommonLoggingEnv) -> env -> KeyHideSwitch
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
. env -> CommonLoggingEnv
forall env. HasCommonLogging env => env -> CommonLoggingEnv
getCommonLogging)

  -- Statuses receive no updates at this point (command threads have finished
  -- or been killed), so this should be safe.
  HashMap CommandIndex (CommandP 'CommandPhase1, CommandStatus)
commandsStatus <- m CommandStatusMap
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
m CommandStatusMap
getReadCommandStatus m CommandStatusMap
-> (CommandStatusMap
    -> HashMap CommandIndex (CommandP 'CommandPhase1, CommandStatus))
-> m (HashMap
        CommandIndex (CommandP 'CommandPhase1, CommandStatus))
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> Optic'
  An_Iso
  NoIx
  CommandStatusMap
  (HashMap CommandIndex (CommandP 'CommandPhase1, CommandStatus))
-> CommandStatusMap
-> HashMap CommandIndex (CommandP 'CommandPhase1, 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 (CommandP 'CommandPhase1, CommandStatus))
#unCommandStatusMap

  let (HashSet (CommandOrd 'CommandPhase1)
waiting, HashSet (CommandOrd 'CommandPhase1)
running) = ((HashSet (CommandOrd 'CommandPhase1),
  HashSet (CommandOrd 'CommandPhase1))
 -> (CommandP 'CommandPhase1, CommandStatus)
 -> (HashSet (CommandOrd 'CommandPhase1),
     HashSet (CommandOrd 'CommandPhase1)))
-> (HashSet (CommandOrd 'CommandPhase1),
    HashSet (CommandOrd 'CommandPhase1))
-> HashMap CommandIndex (CommandP 'CommandPhase1, CommandStatus)
-> (HashSet (CommandOrd 'CommandPhase1),
    HashSet (CommandOrd 'CommandPhase1))
forall b a. (b -> a -> b) -> b -> HashMap CommandIndex a -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (HashSet (CommandOrd 'CommandPhase1),
 HashSet (CommandOrd 'CommandPhase1))
-> (CommandP 'CommandPhase1, CommandStatus)
-> (HashSet (CommandOrd 'CommandPhase1),
    HashSet (CommandOrd 'CommandPhase1))
forall {p :: CommandPhase}.
(HashSet (CommandOrd p), HashSet (CommandOrd p))
-> (CommandP p, CommandStatus)
-> (HashSet (CommandOrd p), HashSet (CommandOrd p))
go (HashSet (CommandOrd 'CommandPhase1)
forall a. HashSet a
Set.empty, HashSet (CommandOrd 'CommandPhase1)
forall a. HashSet a
Set.empty) HashMap CommandIndex (CommandP 'CommandPhase1, CommandStatus)
commandsStatus
      go :: (HashSet (CommandOrd p), HashSet (CommandOrd p))
-> (CommandP p, CommandStatus)
-> (HashSet (CommandOrd p), HashSet (CommandOrd p))
go acc :: (HashSet (CommandOrd p), HashSet (CommandOrd p))
acc@(HashSet (CommandOrd p)
ws, HashSet (CommandOrd p)
rs) (CommandP p
cmd, CommandStatus
status) = case CommandStatus
status of
        CommandStatus
CommandSuccess -> (HashSet (CommandOrd p), HashSet (CommandOrd p))
acc
        CommandStatus
CommandFailure -> (HashSet (CommandOrd p), HashSet (CommandOrd p))
acc
        CommandRunning (Maybe Pid, [Pid])
_ -> (HashSet (CommandOrd p)
ws, CommandOrd p -> HashSet (CommandOrd p) -> HashSet (CommandOrd p)
forall a. Hashable a => a -> HashSet a -> HashSet a
Set.insert (CommandP p -> CommandOrd p
forall (p :: CommandPhase). CommandP p -> CommandOrd p
MkCommandOrd CommandP p
cmd) HashSet (CommandOrd p)
rs)
        CommandStatus
CommandWaiting -> (CommandOrd p -> HashSet (CommandOrd p) -> HashSet (CommandOrd p)
forall a. Hashable a => a -> HashSet a -> HashSet a
Set.insert (CommandP p -> CommandOrd p
forall (p :: CommandPhase). CommandP p -> CommandOrd p
MkCommandOrd CommandP p
cmd) HashSet (CommandOrd p)
ws, HashSet (CommandOrd p)
rs)

      cmdToTxt :: CommandOrd CommandPhase1 -> Text
      cmdToTxt :: CommandOrd 'CommandPhase1 -> Text
cmdToTxt CommandOrd 'CommandPhase1
cmd =
        Text
"- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CommandP 'CommandPhase1 -> KeyHideSwitch -> UnlinedText
Formatting.displayCmd (CommandOrd 'CommandPhase1
cmd CommandOrd 'CommandPhase1
-> Optic'
     An_Iso NoIx (CommandOrd 'CommandPhase1) (CommandP 'CommandPhase1)
-> CommandP 'CommandPhase1
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic'
  An_Iso NoIx (CommandOrd 'CommandPhase1) (CommandP 'CommandPhase1)
#unCommandOrd) KeyHideSwitch
keyHide 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

      mkLog :: Text -> Log
      mkLog :: Text -> Log
mkLog Text
txt =
        MkLog
          { cmd :: Maybe (CommandP 'CommandPhase1)
cmd = Maybe (CommandP 'CommandPhase1)
forall a. Maybe a
Nothing,
            msg :: LogMessage
msg = Text -> LogMessage
UnsafeLogMessage Text
txt,
            lvl :: LogLevel
lvl = LogLevel
LevelWarn,
            mode :: LogMode
mode = LogMode
LogModeFinish
          }

      mkLogs :: UnlinedText -> HashSet (CommandOrd CommandPhase1) -> Maybe (NonEmpty Log)
      mkLogs :: UnlinedText
-> HashSet (CommandOrd 'CommandPhase1) -> Maybe (NonEmpty Log)
mkLogs UnlinedText
pfx HashSet (CommandOrd 'CommandPhase1)
st =
        if HashSet (CommandOrd 'CommandPhase1) -> Bool
forall a. HashSet a -> Bool
Set.null HashSet (CommandOrd 'CommandPhase1)
st
          then Maybe (NonEmpty Log)
forall a. Maybe a
Nothing
          else
            NonEmpty Log -> Maybe (NonEmpty Log)
forall a. a -> Maybe a
Just
              (NonEmpty Log -> Maybe (NonEmpty Log))
-> NonEmpty Log -> Maybe (NonEmpty Log)
forall a b. (a -> b) -> a -> b
$ Text -> Log
mkLog (UnlinedText
pfx 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)
              -- Final sort by CommandOrd since our intermediate structure is
              -- a HashSet.
              Log -> [Log] -> NonEmpty Log
forall a. a -> [a] -> NonEmpty a
:| (Text -> Log
mkLog (Text -> Log)
-> (CommandOrd 'CommandPhase1 -> Text)
-> CommandOrd 'CommandPhase1
-> Log
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
. CommandOrd 'CommandPhase1 -> Text
cmdToTxt (CommandOrd 'CommandPhase1 -> Log)
-> [CommandOrd 'CommandPhase1] -> [Log]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [CommandOrd 'CommandPhase1] -> [CommandOrd 'CommandPhase1]
forall a. Ord a => [a] -> [a]
L.sort (HashSet (CommandOrd 'CommandPhase1) -> [CommandOrd 'CommandPhase1]
forall a. HashSet a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList HashSet (CommandOrd 'CommandPhase1)
st))

  (Maybe (NonEmpty Log), Maybe (NonEmpty Log))
-> m (Maybe (NonEmpty Log), Maybe (NonEmpty Log))
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (UnlinedText
-> HashSet (CommandOrd 'CommandPhase1) -> Maybe (NonEmpty Log)
mkLogs UnlinedText
waitingPrefix HashSet (CommandOrd 'CommandPhase1)
waiting, UnlinedText
-> HashSet (CommandOrd 'CommandPhase1) -> Maybe (NonEmpty Log)
mkLogs UnlinedText
runningPrefix HashSet (CommandOrd 'CommandPhase1)
running)
  where
    waitingPrefix :: UnlinedText
waitingPrefix = UnlinedText
"Commands not started:"
    runningPrefix :: UnlinedText
runningPrefix = UnlinedText
"Attempting to cancel:"
{-# INLINEABLE mkUnfinishedCmdLogs #-}

-- | Logs to a file. This function is /not/ thread-safe! Hence care must be
-- taken to avoid it being called by multiple threads.
logFile ::
  ( CanWrite p,
    HasCallStack,
    MonadHandleWriter m
  ) =>
  LockedHandle p ->
  FileLog ->
  m ()
logFile :: forall (p :: HandleMode) (m :: Type -> Type).
(CanWrite p, HasCallStack, MonadHandleWriter m) =>
LockedHandle p -> FileLog -> m ()
logFile LockedHandle p
lh = (HasCallStack => Handle p -> Text -> m ())
-> LockedHandle p -> Text -> m ()
forall (p :: HandleMode) a.
HasCallStack =>
(HasCallStack => Handle p -> a) -> LockedHandle p -> a
liftLocked (\Handle p
h Text
t -> Handle p -> Text -> m ()
forall (p :: HandleMode) (m :: Type -> Type).
(CanWrite p, HasCallStack, MonadHandleWriter m) =>
Handle p -> Text -> m ()
hPutUtf8 Handle p
h Text
t m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> Handle p -> m ()
forall (p :: HandleMode).
(CanWrite p, HasCallStack) =>
Handle p -> m ()
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleWriter m, CanWrite p, HasCallStack) =>
Handle p -> m ()
hFlush Handle p
h) LockedHandle p
lh (Text -> m ()) -> (FileLog -> Text) -> FileLog -> m ()
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_Getter NoIx FileLog Text -> FileLog -> Text
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Getter NoIx FileLog Text
#unFileLog
{-# INLINEABLE logFile #-}

-- | Like 'putRegionLog', except this logs directly to the console / file,
-- rather than placing the log in a queue. This is for when log queues are
-- shutdown (e.g. terminated). This should only be called from a single thread.
putRegionLogDirect ::
  forall env m.
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadHandleWriter m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadTime m
  ) =>
  Log ->
  m ()
putRegionLogDirect :: forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadHandleWriter m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
Log -> m ()
putRegionLogDirect Log
log = do
  CommonLoggingEnv
commonLogging <- (env -> CommonLoggingEnv) -> m CommonLoggingEnv
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> CommonLoggingEnv
forall env. HasCommonLogging env => env -> CommonLoggingEnv
getCommonLogging
  (ConsoleLoggingEnv
consoleLogging, TBQueue (LogRegion (Region m))
_, IORef (Maybe (Region m))
_) <- (env
 -> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
     IORef (Maybe (Region m))))
-> m (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
      IORef (Maybe (Region m)))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (forall env r.
HasConsoleLogging env r =>
env -> (ConsoleLoggingEnv, TBQueue (LogRegion r), IORef (Maybe r))
getConsoleLogging @env @(Region m))
  Maybe FileLoggingEnv
mFileLogging <- (env -> Maybe FileLoggingEnv) -> m (Maybe FileLoggingEnv)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> Maybe FileLoggingEnv
forall env. HasFileLogging env => env -> Maybe FileLoggingEnv
getFileLogging

  let keyHide :: KeyHideSwitch
keyHide = Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
-> CommonLoggingEnv -> KeyHideSwitch
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
#keyHide CommonLoggingEnv
commonLogging
  ConsoleLog
consoleLog <- KeyHideSwitch -> ConsoleLoggingEnv -> Log -> m ConsoleLog
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
KeyHideSwitch -> ConsoleLoggingEnv -> Log -> m ConsoleLog
Formatting.formatConsoleLog KeyHideSwitch
keyHide ConsoleLoggingEnv
consoleLogging Log
log

  RegionLayout -> (Region m -> m ()) -> m ()
forall a. HasCallStack => RegionLayout -> (Region m -> m a) -> m a
forall (m :: Type -> Type) a.
(MonadRegionLogger m, HasCallStack) =>
RegionLayout -> (Region m -> m a) -> m a
MRL.withRegion RegionLayout
Linear ((Region m -> m ()) -> m ()) -> (Region m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Region m
r -> LogMode -> Region m -> Text -> m ()
forall (m :: Type -> Type).
(MonadRegionLogger m, HasCallStack) =>
LogMode -> Region m -> Text -> m ()
MRL.logRegion (Log
log Log -> Optic' A_Lens NoIx Log LogMode -> LogMode
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Log LogMode
#mode) Region m
r (ConsoleLog
consoleLog ConsoleLog -> Optic' A_Getter NoIx ConsoleLog Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Getter NoIx ConsoleLog Text
#unConsoleLog)

  Maybe FileLoggingEnv -> (FileLoggingEnv -> m ()) -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe FileLoggingEnv
mFileLogging ((FileLoggingEnv -> m ()) -> m ())
-> (FileLoggingEnv -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \FileLoggingEnv
fl -> do
    FileLog
fileLog <- KeyHideSwitch -> FileLoggingEnv -> Log -> m FileLog
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m, MonadReader env m,
 MonadTime m) =>
KeyHideSwitch -> FileLoggingEnv -> Log -> m FileLog
Formatting.formatFileLog KeyHideSwitch
keyHide FileLoggingEnv
fl Log
log
    LockedHandle 'HandleModeWrite -> FileLog -> m ()
forall (p :: HandleMode) (m :: Type -> Type).
(CanWrite p, HasCallStack, MonadHandleWriter m) =>
LockedHandle p -> FileLog -> m ()
logFile (FileLoggingEnv
fl FileLoggingEnv
-> Optic'
     A_Lens NoIx FileLoggingEnv (LockedHandle 'HandleModeWrite)
-> LockedHandle 'HandleModeWrite
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic
  A_Lens
  NoIx
  FileLoggingEnv
  FileLoggingEnv
  FileLogOpened
  FileLogOpened
#file Optic
  A_Lens
  NoIx
  FileLoggingEnv
  FileLoggingEnv
  FileLogOpened
  FileLogOpened
-> Optic
     A_Lens
     NoIx
     FileLogOpened
     FileLogOpened
     (LockedHandle 'HandleModeWrite)
     (LockedHandle 'HandleModeWrite)
-> Optic'
     A_Lens NoIx FileLoggingEnv (LockedHandle 'HandleModeWrite)
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
  A_Lens
  NoIx
  FileLogOpened
  FileLogOpened
  (LockedHandle 'HandleModeWrite)
  (LockedHandle 'HandleModeWrite)
#handle) FileLog
fileLog
{-# INLINEABLE putRegionLogDirect #-}

-- | Like 'putRegionMultiLineLog', except this logs directly to the
-- console / file, rather than placing the log in a queue. This is for when
-- log queues are shutdown (e.g. terminated). This should only be called from
-- a single thread.
putRegionMultiLineLogDirect ::
  forall env m.
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadHandleWriter m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadTime m
  ) =>
  NonEmpty Log ->
  m ()
putRegionMultiLineLogDirect :: forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadHandleWriter m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
NonEmpty Log -> m ()
putRegionMultiLineLogDirect logs :: NonEmpty Log
logs@(Log
log :| [Log]
_) = do
  CommonLoggingEnv
commonLogging <- (env -> CommonLoggingEnv) -> m CommonLoggingEnv
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> CommonLoggingEnv
forall env. HasCommonLogging env => env -> CommonLoggingEnv
getCommonLogging
  (ConsoleLoggingEnv
consoleLogging, TBQueue (LogRegion (Region m))
_, IORef (Maybe (Region m))
_) <- (env
 -> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
     IORef (Maybe (Region m))))
-> m (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)),
      IORef (Maybe (Region m)))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (forall env r.
HasConsoleLogging env r =>
env -> (ConsoleLoggingEnv, TBQueue (LogRegion r), IORef (Maybe r))
getConsoleLogging @env @(Region m))
  Maybe FileLoggingEnv
mFileLogging <- (env -> Maybe FileLoggingEnv) -> m (Maybe FileLoggingEnv)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> Maybe FileLoggingEnv
forall env. HasFileLogging env => env -> Maybe FileLoggingEnv
getFileLogging

  let keyHide :: KeyHideSwitch
keyHide = Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
-> CommonLoggingEnv -> KeyHideSwitch
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx CommonLoggingEnv KeyHideSwitch
#keyHide CommonLoggingEnv
commonLogging
  ConsoleLog
consoleLog <- KeyHideSwitch -> ConsoleLoggingEnv -> NonEmpty Log -> m ConsoleLog
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m,
 MonadReader env m) =>
KeyHideSwitch -> ConsoleLoggingEnv -> NonEmpty Log -> m ConsoleLog
Formatting.formatConsoleMultiLineLogs KeyHideSwitch
keyHide ConsoleLoggingEnv
consoleLogging NonEmpty Log
logs

  RegionLayout -> (Region m -> m ()) -> m ()
forall a. HasCallStack => RegionLayout -> (Region m -> m a) -> m a
forall (m :: Type -> Type) a.
(MonadRegionLogger m, HasCallStack) =>
RegionLayout -> (Region m -> m a) -> m a
MRL.withRegion RegionLayout
Linear ((Region m -> m ()) -> m ()) -> (Region m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Region m
r -> LogMode -> Region m -> Text -> m ()
forall (m :: Type -> Type).
(MonadRegionLogger m, HasCallStack) =>
LogMode -> Region m -> Text -> m ()
MRL.logRegion (Log
log Log -> Optic' A_Lens NoIx Log LogMode -> LogMode
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Log LogMode
#mode) Region m
r (ConsoleLog
consoleLog ConsoleLog -> Optic' A_Getter NoIx ConsoleLog Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Getter NoIx ConsoleLog Text
#unConsoleLog)

  Maybe FileLoggingEnv -> (FileLoggingEnv -> m ()) -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe FileLoggingEnv
mFileLogging ((FileLoggingEnv -> m ()) -> m ())
-> (FileLoggingEnv -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \FileLoggingEnv
fl -> do
    FileLog
fileLog <- KeyHideSwitch -> FileLoggingEnv -> NonEmpty Log -> m FileLog
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, MonadAtomic m, MonadReader env m,
 MonadTime m) =>
KeyHideSwitch -> FileLoggingEnv -> NonEmpty Log -> m FileLog
Formatting.formatFileMultiLineLogs KeyHideSwitch
keyHide FileLoggingEnv
fl NonEmpty Log
logs
    LockedHandle 'HandleModeWrite -> FileLog -> m ()
forall (p :: HandleMode) (m :: Type -> Type).
(CanWrite p, HasCallStack, MonadHandleWriter m) =>
LockedHandle p -> FileLog -> m ()
logFile (FileLoggingEnv
fl FileLoggingEnv
-> Optic'
     A_Lens NoIx FileLoggingEnv (LockedHandle 'HandleModeWrite)
-> LockedHandle 'HandleModeWrite
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic
  A_Lens
  NoIx
  FileLoggingEnv
  FileLoggingEnv
  FileLogOpened
  FileLogOpened
#file Optic
  A_Lens
  NoIx
  FileLoggingEnv
  FileLoggingEnv
  FileLogOpened
  FileLogOpened
-> Optic
     A_Lens
     NoIx
     FileLogOpened
     FileLogOpened
     (LockedHandle 'HandleModeWrite)
     (LockedHandle 'HandleModeWrite)
-> Optic'
     A_Lens NoIx FileLoggingEnv (LockedHandle 'HandleModeWrite)
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
  A_Lens
  NoIx
  FileLogOpened
  FileLogOpened
  (LockedHandle 'HandleModeWrite)
  (LockedHandle 'HandleModeWrite)
#handle) FileLog
fileLog
{-# INLINEABLE putRegionMultiLineLogDirect #-}

putDebugLogDirect ::
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadHandleWriter m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadTime m
  ) =>
  LogMessage ->
  m ()
putDebugLogDirect :: forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadHandleWriter m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
LogMessage -> m ()
putDebugLogDirect = (Log -> m ()) -> LogMessage -> m ()
forall env (m :: Type -> Type).
(HasCommonLogging env, MonadReader env m) =>
(Log -> m ()) -> LogMessage -> m ()
putDebugLogHelper Log -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadHandleWriter m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
Log -> m ()
putRegionLogDirect
{-# INLINEABLE putDebugLogDirect #-}

putDebugLog ::
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadTime m
  ) =>
  LogMessage ->
  m ()
putDebugLog :: forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadReader env m, MonadRegionLogger m, MonadTime m) =>
LogMessage -> m ()
putDebugLog = (Log -> m ()) -> LogMessage -> m ()
forall env (m :: Type -> Type).
(HasCommonLogging env, MonadReader env m) =>
(Log -> m ()) -> LogMessage -> m ()
putDebugLogHelper (\Log
log -> RegionLayout -> (Region m -> m ()) -> m ()
forall a. HasCallStack => RegionLayout -> (Region m -> m a) -> m a
forall (m :: Type -> Type) a.
(MonadRegionLogger m, HasCallStack) =>
RegionLayout -> (Region m -> m a) -> m a
MRL.withRegion RegionLayout
Linear ((Region m -> m ()) -> m ()) -> (Region m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Region m
r -> Region m -> Log -> m ()
forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadReader env m, MonadTime m) =>
Region m -> Log -> m ()
putRegionLog Region m
r Log
log)
{-# INLINEABLE putDebugLog #-}

putDebugLogHelper ::
  ( HasCommonLogging env,
    MonadReader env m
  ) =>
  (Log -> m ()) ->
  LogMessage ->
  m ()
putDebugLogHelper :: forall env (m :: Type -> Type).
(HasCommonLogging env, MonadReader env m) =>
(Log -> m ()) -> LogMessage -> m ()
putDebugLogHelper Log -> m ()
logFn LogMessage
msg = do
  (LogLevel -> m ()) -> m ()
forall env (m :: Type -> Type).
(HasCommonLogging env, MonadReader env m) =>
(LogLevel -> m ()) -> m ()
logDebug ((LogLevel -> m ()) -> m ()) -> (LogLevel -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \LogLevel
lvl -> do
    let log :: Log
log =
          MkLog
            { cmd :: Maybe (CommandP 'CommandPhase1)
cmd = Maybe (CommandP 'CommandPhase1)
forall a. Maybe a
Nothing,
              LogMessage
msg :: LogMessage
msg :: LogMessage
msg,
              LogLevel
lvl :: LogLevel
lvl :: LogLevel
lvl,
              mode :: LogMode
mode = LogMode
LogModeFinish
            }
    Log -> m ()
logFn Log
log
{-# INLINEABLE putDebugLogHelper #-}

-- | Rungs the action when debug is on.
logDebug ::
  ( HasCommonLogging env,
    MonadReader env m
  ) =>
  (LogLevel -> m ()) ->
  m ()
logDebug :: forall env (m :: Type -> Type).
(HasCommonLogging env, MonadReader env m) =>
(LogLevel -> m ()) -> m ()
logDebug LogLevel -> m ()
logFn = do
  Bool
debug <- (env -> Bool) -> m Bool
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (Optic' A_Lens NoIx CommonLoggingEnv Bool
-> CommonLoggingEnv -> Bool
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Optic A_Lens NoIx CommonLoggingEnv CommonLoggingEnv Debug Debug
#debug Optic A_Lens NoIx CommonLoggingEnv CommonLoggingEnv Debug Debug
-> Optic An_Iso NoIx Debug Debug Bool Bool
-> Optic' A_Lens NoIx CommonLoggingEnv Bool
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 Debug Debug Bool Bool
#unDebug) (CommonLoggingEnv -> Bool)
-> (env -> CommonLoggingEnv) -> env -> Bool
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
. env -> CommonLoggingEnv
forall env. HasCommonLogging env => env -> CommonLoggingEnv
getCommonLogging)
  Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
debug (LogLevel -> m ()
logFn LogLevel
LevelDebug)
{-# INLINEABLE logDebug #-}