-- | This module is the entry point to the @Shrun@ library used by
-- the @Shrun@ executable.
module Shrun
  ( ShellT,
    runShellT,
    shrun,
  )
where

import DBus.Notify (UrgencyLevel (Critical, Normal))
import Data.HashSet qualified as Set
import Effects.Concurrent.Async qualified as Async
import Effects.Concurrent.Thread as X (microsleep, sleep)
import Effects.Time (TimeSpec, withTiming)
import Shrun.Configuration.Data.ConsoleLogging.TimerFormat qualified as TimerFormat
import Shrun.Configuration.Data.Core.Timeout (Timeout (MkTimeout))
import Shrun.Configuration.Data.FileLogging
  ( FileLogOpened (MkFileLogOpened),
    FileLoggingEnv,
  )
import Shrun.Configuration.Env.Types
  ( HasAnyError (getAnyError),
    HasCommandLogging,
    HasCommands (getCommands, getCompletedCommands),
    HasCommonLogging (getCommonLogging),
    HasConsoleLogging (getConsoleLogging),
    HasFileLogging (getFileLogging),
    HasInit,
    HasNotifyConfig (getNotifyConfig),
    HasTimeout (getTimeout),
    setAnyErrorTrue,
  )
import Shrun.Data.Command (CommandP1)
import Shrun.Data.Text qualified as ShrunText
import Shrun.IO (Stderr (MkStderr), tryCommandLogging)
import Shrun.IO.Types (CommandResult (CommandFailure, CommandSuccess))
import Shrun.Logging qualified as Logging
import Shrun.Logging.Formatting qualified as LogFmt
import Shrun.Logging.MonadRegionLogger
  ( MonadRegionLogger
      ( Region,
        displayRegions,
        logGlobal,
        logRegion,
        withRegion
      ),
  )
import Shrun.Logging.Types
  ( FileLog,
    Log (MkLog, cmd, lvl, mode, msg),
    LogLevel
      ( LevelError,
        LevelFatal,
        LevelFinished,
        LevelSuccess,
        LevelTimer,
        LevelWarn
      ),
    LogMode (LogModeFinish, LogModeSet),
    LogRegion (LogNoRegion, LogRegion),
  )
import Shrun.Notify qualified as Notify
import Shrun.Notify.MonadNotify (MonadNotify)
import Shrun.Notify.Types
  ( NotifyAction
      ( NotifyAll,
        NotifyCommand,
        NotifyFinal
      ),
  )
import Shrun.Prelude
import Shrun.ShellT (ShellT, runShellT)
import Shrun.Utils qualified as Utils

-- | Entry point
shrun ::
  forall m env.
  ( HasAnyError env,
    HasCallStack,
    HasCommands env,
    HasInit env,
    HasCommandLogging env,
    HasCommonLogging env,
    HasConsoleLogging env (Region m),
    HasFileLogging env,
    HasNotifyConfig env,
    HasTimeout env,
    MonadAsync m,
    MonadHandleReader m,
    MonadHandleWriter m,
    MonadIORef m,
    MonadNotify m,
    MonadTypedProcess m,
    MonadMask m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadSTM m,
    MonadThread m,
    MonadTime m
  ) =>
  -- | .
  m ()
shrun :: forall (m :: Type -> Type) env.
(HasAnyError env, HasCallStack, HasCommands env, HasInit env,
 HasCommandLogging env, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 HasNotifyConfig env, HasTimeout env, MonadAsync m,
 MonadHandleReader m, MonadHandleWriter m, MonadIORef m,
 MonadNotify m, MonadTypedProcess m, MonadMask m, MonadReader env m,
 MonadRegionLogger m, MonadSTM m, MonadThread m, MonadTime m) =>
m ()
shrun = m () -> m ()
forall a. HasCallStack => m a -> m a
forall (m :: Type -> Type) a.
(MonadRegionLogger m, HasCallStack) =>
m a -> m a
displayRegions (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  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
  (ConsoleLoggingEnv
_, TBQueue (LogRegion (Region m))
consoleQueue) <- (env -> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m))))
-> m (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)))
forall env r.
HasConsoleLogging env r =>
env -> Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion r))
getConsoleLogging

  -- always start console logger
  m Any -> (Async Any -> m ()) -> m ()
forall a b. HasCallStack => m a -> (Async a -> m b) -> m b
forall (m :: Type -> Type) a b.
(MonadAsync m, HasCallStack) =>
m a -> (Async a -> m b) -> m b
Async.withAsync (TBQueue (LogRegion (Region m)) -> m Any
forall (m :: Type -> Type) env void.
(HasCallStack, MonadMask m, MonadReader env m, MonadRegionLogger m,
 MonadSTM m) =>
TBQueue (LogRegion (Region m)) -> m void
pollQueueToConsole TBQueue (LogRegion (Region m))
consoleQueue) ((Async Any -> m ()) -> m ()) -> (Async Any -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Async Any
consoleLogger -> do
    -- run commands, running file logger if requested
    m () -> (FileLoggingEnv -> m ()) -> Maybe FileLoggingEnv -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      m ()
HasCallStack => m ()
runCommands
      HasCallStack => FileLoggingEnv -> m ()
FileLoggingEnv -> m ()
runWithFileLogging
      Maybe FileLoggingEnv
mFileLogging

    -- cancel consoleLogger, print remaining logs
    Async Any -> m ()
forall a. HasCallStack => Async a -> m ()
forall (m :: Type -> Type) a.
(MonadAsync m, HasCallStack) =>
Async a -> m ()
Async.cancel Async Any
consoleLogger
    TBQueue (LogRegion (Region m)) -> m [LogRegion (Region m)]
forall (m :: Type -> Type) a.
(HasCallStack, MonadSTM m) =>
TBQueue a -> m [a]
flushTBQueueA TBQueue (LogRegion (Region m))
consoleQueue m [LogRegion (Region m)]
-> ([LogRegion (Region m)] -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LogRegion (Region m) -> m ()) -> [LogRegion (Region m)] -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ LogRegion (Region m) -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadRegionLogger m) =>
LogRegion (Region m) -> m ()
printConsoleLog

    -- if any processes have failed, exit with an error
    Bool
anyError <- TVar Bool -> m Bool
forall (m :: Type -> Type) a.
(HasCallStack, MonadSTM m) =>
TVar a -> m a
readTVarA (TVar Bool -> m Bool) -> m (TVar Bool) -> m Bool
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< (env -> TVar Bool) -> m (TVar Bool)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> TVar Bool
forall env. HasAnyError env => env -> TVar Bool
getAnyError
    Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
anyError m ()
forall (m :: Type -> Type) a. (HasCallStack, MonadThrow m) => m a
exitFailure
  where
    runWithFileLogging :: (HasCallStack) => FileLoggingEnv -> m ()
    runWithFileLogging :: HasCallStack => FileLoggingEnv -> m ()
runWithFileLogging FileLoggingEnv
fileLogging =
      m Any -> (Async Any -> m ()) -> m ()
forall a b. HasCallStack => m a -> (Async a -> m b) -> m b
forall (m :: Type -> Type) a b.
(MonadAsync m, HasCallStack) =>
m a -> (Async a -> m b) -> m b
Async.withAsync (FileLoggingEnv -> m Any
forall (m :: Type -> Type) void.
(HasCallStack, MonadHandleWriter m, MonadMask m, MonadSTM m) =>
FileLoggingEnv -> m void
pollQueueToFile FileLoggingEnv
fileLogging) ((Async Any -> m ()) -> m ()) -> (Async Any -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Async Any
fileLoggerThread -> do
        m ()
HasCallStack => m ()
runCommands

        Async Any -> m ()
forall a. HasCallStack => Async a -> m ()
forall (m :: Type -> Type) a.
(MonadAsync m, HasCallStack) =>
Async a -> m ()
Async.cancel Async Any
fileLoggerThread

        -- handle any remaining file logs
        TBQueue FileLog -> m [FileLog]
forall (m :: Type -> Type) a.
(HasCallStack, MonadSTM m) =>
TBQueue a -> m [a]
flushTBQueueA TBQueue FileLog
fileQueue m [FileLog] -> ([FileLog] -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FileLog -> m ()) -> [FileLog] -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Handle -> FileLog -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadHandleWriter m) =>
Handle -> FileLog -> m ()
logFile Handle
h)
        Handle -> m ()
forall (m :: Type -> Type).
(MonadHandleWriter m, HasCallStack) =>
Handle -> m ()
hFlush Handle
h
      where
        MkFileLogOpened Handle
h TBQueue FileLog
fileQueue = FileLoggingEnv
fileLogging FileLoggingEnv
-> Optic' A_Lens NoIx FileLoggingEnv FileLogOpened -> FileLogOpened
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx FileLoggingEnv FileLogOpened
#file

    runCommands :: (HasCallStack) => m ()
    runCommands :: HasCallStack => m ()
runCommands = do
      NESeq CommandP1
cmds <- (env -> NESeq CommandP1) -> m (NESeq CommandP1)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> NESeq CommandP1
forall env. HasCommands env => env -> NESeq CommandP1
getCommands
      let actions :: m ()
actions = (CommandP1 -> m ()) -> NESeq CommandP1 -> m ()
forall (m :: Type -> Type) (f :: Type -> Type) a b.
(MonadAsync m, Foldable f) =>
(a -> m b) -> f a -> m ()
Async.mapConcurrently_ CommandP1 -> m ()
forall (m :: Type -> Type) env.
(HasAnyError env, HasCallStack, HasCommands env, HasInit env,
 HasCommandLogging env, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 HasNotifyConfig env, MonadHandleReader m, MonadIORef m,
 MonadMask m, MonadNotify m, MonadTypedProcess m, MonadReader env m,
 MonadRegionLogger m, MonadSTM m, MonadThread m, MonadTime m) =>
CommandP1 -> m ()
runCommand NESeq CommandP1
cmds
          actionsWithTimer :: m ()
actionsWithTimer = m () -> m () -> m ()
forall (m :: Type -> Type) a b.
(HasCallStack, MonadAsync m) =>
m a -> m b -> m ()
Async.race_ m ()
actions m ()
forall env (m :: Type -> Type).
(HasAnyError env, HasCallStack, HasCommands env,
 HasCommonLogging env, HasConsoleLogging env (Region m),
 HasFileLogging env, HasTimeout env, MonadIORef m,
 MonadReader env m, MonadRegionLogger m, MonadSTM m, MonadThread m,
 MonadTime m) =>
m ()
counter

      (TimeSpec
totalTime, Either SomeException ()
result) <- m (Either SomeException ())
-> m (TimeSpec, Either SomeException ())
forall (m :: Type -> Type) a.
(HasCallStack, MonadTime m) =>
m a -> m (TimeSpec, a)
withTiming (m (Either SomeException ())
 -> m (TimeSpec, Either SomeException ()))
-> m (Either SomeException ())
-> m (TimeSpec, Either SomeException ())
forall a b. (a -> b) -> a -> b
$ m () -> m (Either SomeException ())
forall (m :: Type -> Type) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
tryAny m ()
actionsWithTimer
      TimeSpec -> Either SomeException () -> m ()
forall (m :: Type -> Type) env e b.
(Exception e, HasAnyError env, HasCallStack, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 HasNotifyConfig env, MonadNotify m, MonadReader env m,
 MonadRegionLogger m, MonadSTM m, MonadTime m) =>
TimeSpec -> Either e b -> m ()
printFinalResult TimeSpec
totalTime Either SomeException ()
result

runCommand ::
  forall m env.
  ( HasAnyError env,
    HasCallStack,
    HasCommands env,
    HasInit env,
    HasCommandLogging env,
    HasCommonLogging env,
    HasConsoleLogging env (Region m),
    HasFileLogging env,
    HasNotifyConfig env,
    MonadHandleReader m,
    MonadIORef m,
    MonadMask m,
    MonadNotify m,
    MonadTypedProcess m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadSTM m,
    MonadThread m,
    MonadTime m
  ) =>
  CommandP1 ->
  m ()
runCommand :: forall (m :: Type -> Type) env.
(HasAnyError env, HasCallStack, HasCommands env, HasInit env,
 HasCommandLogging env, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 HasNotifyConfig env, MonadHandleReader m, MonadIORef m,
 MonadMask m, MonadNotify m, MonadTypedProcess m, MonadReader env m,
 MonadRegionLogger m, MonadSTM m, MonadThread m, MonadTime m) =>
CommandP1 -> m ()
runCommand CommandP1
cmd = do
  CommandResult
cmdResult <- CommandP1 -> m CommandResult
forall (m :: Type -> Type) env.
(HasAnyError env, HasCallStack, HasCommands env, HasInit env,
 HasCommandLogging env, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 MonadHandleReader m, MonadIORef m, MonadMask m, MonadReader env m,
 MonadRegionLogger m, MonadSTM m, MonadThread m, MonadTime m,
 MonadTypedProcess m) =>
CommandP1 -> m CommandResult
tryCommandLogging CommandP1
cmd
  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))
_) <- (env -> (ConsoleLoggingEnv, TBQueue (LogRegion (Region m))))
-> m (ConsoleLoggingEnv, TBQueue (LogRegion (Region m)))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (forall env r.
HasConsoleLogging env r =>
env -> Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion r))
getConsoleLogging @env @(Region m))

  let timerFormat :: TimerFormat
timerFormat = ConsoleLoggingEnv
consoleLogging ConsoleLoggingEnv
-> Optic' A_Lens NoIx ConsoleLoggingEnv TimerFormat -> TimerFormat
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx ConsoleLoggingEnv TimerFormat
#timerFormat
      (UrgencyLevel
urgency, UnlinedText
msg', LogLevel
lvl, RelativeTime
timeElapsed) = case CommandResult
cmdResult of
        -- see NOTE: [Text Line Concatentation] for how we combine the
        -- multiple texts back into a single err.
        CommandFailure RelativeTime
t (MkStderr List UnlinedText
errs) ->
          let errMsg :: UnlinedText
errMsg = List UnlinedText -> UnlinedText
ShrunText.concat List UnlinedText
errs
           in (UrgencyLevel
Critical, UnlinedText
": " UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
errMsg, LogLevel
LevelError, RelativeTime
t)
        CommandSuccess RelativeTime
t -> (UrgencyLevel
Normal, UnlinedText
"", LogLevel
LevelSuccess, RelativeTime
t)
      timeMsg :: UnlinedText
timeMsg = TimerFormat -> RelativeTime -> UnlinedText
TimerFormat.formatRelativeTime TimerFormat
timerFormat RelativeTime
timeElapsed UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
msg'

  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
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 env (m :: Type -> Type).
(HasCallStack, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 MonadReader env m, MonadSTM m, MonadTime m) =>
Region m -> Log -> m ()
Logging.putRegionLog Region m
r
      (Log -> m ()) -> Log -> m ()
forall a b. (a -> b) -> a -> b
$ MkLog
        { cmd :: Maybe CommandP1
cmd = CommandP1 -> Maybe CommandP1
forall a. a -> Maybe a
Just CommandP1
cmd,
          msg :: UnlinedText
msg = UnlinedText
timeMsg,
          LogLevel
lvl :: LogLevel
lvl :: LogLevel
lvl,
          mode :: LogMode
mode = LogMode
LogModeFinish
        }

  let commandNameTrunc :: Maybe (Truncation 'TruncCommandName)
commandNameTrunc = 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
      keyHide :: KeyHideSwitch
keyHide = CommonLoggingEnv
commonLogging CommonLoggingEnv
-> Optic' An_Iso NoIx CommonLoggingEnv KeyHideSwitch
-> KeyHideSwitch
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx CommonLoggingEnv KeyHideSwitch
#keyHide
      formattedCmd :: UnlinedText
formattedCmd = KeyHideSwitch
-> Maybe (Truncation 'TruncCommandName) -> CommandP1 -> UnlinedText
LogFmt.formatCommand KeyHideSwitch
keyHide Maybe (Truncation 'TruncCommandName)
commandNameTrunc CommandP1
cmd

  -- Sent off notif if NotifyAll or NotifyCommand is set
  Maybe NotifyEnv
cfg <- (env -> Maybe NotifyEnv) -> m (Maybe NotifyEnv)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> Maybe NotifyEnv
forall env. HasNotifyConfig env => env -> Maybe NotifyEnv
getNotifyConfig
  case Maybe NotifyEnv
cfg Maybe NotifyEnv
-> Optic' An_AffineTraversal NoIx (Maybe NotifyEnv) NotifyAction
-> Maybe NotifyAction
forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? (Prism (Maybe NotifyEnv) (Maybe NotifyEnv) NotifyEnv NotifyEnv
forall a b. Prism (Maybe a) (Maybe b) a b
_Just Prism (Maybe NotifyEnv) (Maybe NotifyEnv) NotifyEnv NotifyEnv
-> Optic A_Lens NoIx NotifyEnv NotifyEnv NotifyAction NotifyAction
-> Optic' An_AffineTraversal NoIx (Maybe NotifyEnv) NotifyAction
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 NotifyEnv NotifyEnv NotifyAction NotifyAction
#action) of
    Just NotifyAction
NotifyAll -> UnlinedText -> UnlinedText -> UrgencyLevel -> m ()
forall env (m :: Type -> Type).
(HasAnyError env, HasCallStack, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 HasNotifyConfig env, MonadNotify m, MonadReader env m,
 MonadRegionLogger m, MonadSTM m, MonadTime m) =>
UnlinedText -> UnlinedText -> UrgencyLevel -> m ()
Notify.sendNotif (UnlinedText
formattedCmd UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
" Finished") UnlinedText
timeMsg UrgencyLevel
urgency
    Just NotifyAction
NotifyCommand -> UnlinedText -> UnlinedText -> UrgencyLevel -> m ()
forall env (m :: Type -> Type).
(HasAnyError env, HasCallStack, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 HasNotifyConfig env, MonadNotify m, MonadReader env m,
 MonadRegionLogger m, MonadSTM m, MonadTime m) =>
UnlinedText -> UnlinedText -> UrgencyLevel -> m ()
Notify.sendNotif (UnlinedText
formattedCmd UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
" Finished") UnlinedText
timeMsg UrgencyLevel
urgency
    Maybe NotifyAction
_ -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()

printFinalResult ::
  forall m env e b.
  ( Exception e,
    HasAnyError env,
    HasCallStack,
    HasCommonLogging env,
    HasConsoleLogging env (Region m),
    HasFileLogging env,
    HasNotifyConfig env,
    MonadNotify m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadSTM m,
    MonadTime m
  ) =>
  TimeSpec ->
  Either e b ->
  m ()
printFinalResult :: forall (m :: Type -> Type) env e b.
(Exception e, HasAnyError env, HasCallStack, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 HasNotifyConfig env, MonadNotify m, MonadReader env m,
 MonadRegionLogger m, MonadSTM m, MonadTime m) =>
TimeSpec -> Either e b -> m ()
printFinalResult TimeSpec
totalTime Either e b
result = 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
withRegion RegionLayout
Linear ((Region m -> m ()) -> m ()) -> (Region m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Region m
r -> do
  Either e b -> (e -> m ()) -> m ()
forall (f :: Type -> Type) a b.
Applicative f =>
Either a b -> (a -> f ()) -> f ()
Utils.whenLeft Either e b
result ((e -> m ()) -> m ()) -> (e -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \e
ex -> do
    let errMsg :: UnlinedText
errMsg =
          List UnlinedText -> UnlinedText
forall a. Monoid a => [a] -> a
mconcat
            [ UnlinedText
"Encountered an exception. This is likely not an error in any ",
              UnlinedText
"of the commands run but rather an error in Shrun itself: ",
              Text -> UnlinedText
ShrunText.fromTextReplace (Text -> UnlinedText) -> Text -> UnlinedText
forall a b. (a -> b) -> a -> b
$ e -> Text
forall e. Exception e => e -> Text
displayExceptiont e
ex
            ]
        fatalLog :: Log
fatalLog =
          MkLog
            { cmd :: Maybe CommandP1
cmd = Maybe CommandP1
forall a. Maybe a
Nothing,
              msg :: UnlinedText
msg = UnlinedText
errMsg,
              lvl :: LogLevel
lvl = LogLevel
LevelFatal,
              mode :: LogMode
mode = LogMode
LogModeFinish
            }
    Region m -> Log -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 MonadReader env m, MonadSTM m, MonadTime m) =>
Region m -> Log -> m ()
Logging.putRegionLog Region m
r Log
fatalLog

    -- update anyError
    m ()
forall env (m :: Type -> Type).
(HasAnyError env, HasCallStack, MonadReader env m, MonadSTM m) =>
m ()
setAnyErrorTrue

  TimerFormat
timerFormat <- (env -> TimerFormat) -> m TimerFormat
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (Optic'
  A_Lens
  NoIx
  (Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m))))
  TimerFormat
-> Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m)))
-> TimerFormat
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens
  (Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m))))
  (Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m))))
  ConsoleLoggingEnv
  ConsoleLoggingEnv
forall s t a b. Field1 s t a b => Lens s t a b
_1 Lens
  (Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m))))
  (Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m))))
  ConsoleLoggingEnv
  ConsoleLoggingEnv
-> Optic' A_Lens NoIx ConsoleLoggingEnv TimerFormat
-> Optic'
     A_Lens
     NoIx
     (Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m))))
     TimerFormat
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 ConsoleLoggingEnv TimerFormat
#timerFormat) (Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m)))
 -> TimerFormat)
-> (env
    -> Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m))))
-> env
-> TimerFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env r.
HasConsoleLogging env r =>
env -> Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion r))
getConsoleLogging @_ @(Region m))
  let totalTimeTxt :: UnlinedText
totalTimeTxt =
        TimerFormat -> RelativeTime -> UnlinedText
TimerFormat.formatRelativeTime
          TimerFormat
timerFormat
          (TimeSpec -> RelativeTime
Utils.timeSpecToRelTime TimeSpec
totalTime)
      finalLog :: Log
finalLog =
        MkLog
          { cmd :: Maybe CommandP1
cmd = Maybe CommandP1
forall a. Maybe a
Nothing,
            msg :: UnlinedText
msg = UnlinedText
totalTimeTxt,
            lvl :: LogLevel
lvl = LogLevel
LevelFinished,
            mode :: LogMode
mode = LogMode
LogModeFinish
          }

  -- Send off a 'finished' notification
  Bool
anyError <- TVar Bool -> m Bool
forall (m :: Type -> Type) a.
(HasCallStack, MonadSTM m) =>
TVar a -> m a
readTVarA (TVar Bool -> m Bool) -> m (TVar Bool) -> m Bool
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< (env -> TVar Bool) -> m (TVar Bool)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> TVar Bool
forall env. HasAnyError env => env -> TVar Bool
getAnyError
  let urgency :: UrgencyLevel
urgency = if Bool
anyError then UrgencyLevel
Critical else UrgencyLevel
Normal

  -- Sent off notif if NotifyAll or NotifyFinal is set
  Maybe NotifyEnv
cfg <- (env -> Maybe NotifyEnv) -> m (Maybe NotifyEnv)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> Maybe NotifyEnv
forall env. HasNotifyConfig env => env -> Maybe NotifyEnv
getNotifyConfig
  case Maybe NotifyEnv
cfg Maybe NotifyEnv
-> Optic' An_AffineTraversal NoIx (Maybe NotifyEnv) NotifyAction
-> Maybe NotifyAction
forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? (Prism (Maybe NotifyEnv) (Maybe NotifyEnv) NotifyEnv NotifyEnv
forall a b. Prism (Maybe a) (Maybe b) a b
_Just Prism (Maybe NotifyEnv) (Maybe NotifyEnv) NotifyEnv NotifyEnv
-> Optic A_Lens NoIx NotifyEnv NotifyEnv NotifyAction NotifyAction
-> Optic' An_AffineTraversal NoIx (Maybe NotifyEnv) NotifyAction
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 NotifyEnv NotifyEnv NotifyAction NotifyAction
#action) of
    Just NotifyAction
NotifyAll -> UnlinedText -> UnlinedText -> UrgencyLevel -> m ()
forall env (m :: Type -> Type).
(HasAnyError env, HasCallStack, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 HasNotifyConfig env, MonadNotify m, MonadReader env m,
 MonadRegionLogger m, MonadSTM m, MonadTime m) =>
UnlinedText -> UnlinedText -> UrgencyLevel -> m ()
Notify.sendNotif UnlinedText
"Shrun Finished" UnlinedText
totalTimeTxt UrgencyLevel
urgency
    Just NotifyAction
NotifyFinal -> UnlinedText -> UnlinedText -> UrgencyLevel -> m ()
forall env (m :: Type -> Type).
(HasAnyError env, HasCallStack, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 HasNotifyConfig env, MonadNotify m, MonadReader env m,
 MonadRegionLogger m, MonadSTM m, MonadTime m) =>
UnlinedText -> UnlinedText -> UrgencyLevel -> m ()
Notify.sendNotif UnlinedText
"Shrun Finished" UnlinedText
totalTimeTxt UrgencyLevel
urgency
    Maybe NotifyAction
_ -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()

  Region m -> Log -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 MonadReader env m, MonadSTM m, MonadTime m) =>
Region m -> Log -> m ()
Logging.putRegionLog Region m
r Log
finalLog

counter ::
  ( HasAnyError env,
    HasCallStack,
    HasCommands env,
    HasCommonLogging env,
    HasConsoleLogging env (Region m),
    HasFileLogging env,
    HasTimeout env,
    MonadIORef m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadSTM m,
    MonadThread m,
    MonadTime m
  ) =>
  m ()
counter :: forall env (m :: Type -> Type).
(HasAnyError env, HasCallStack, HasCommands env,
 HasCommonLogging env, HasConsoleLogging env (Region m),
 HasFileLogging env, HasTimeout env, MonadIORef m,
 MonadReader env m, MonadRegionLogger m, MonadSTM m, MonadThread m,
 MonadTime m) =>
m ()
counter = do
  -- HACK: This brief delay is so that our timer starts "last" i.e. after each
  -- individual command. This way the running timer console region is below all
  -- the commands' in the console.
  Natural -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadThread m) =>
Natural -> m ()
microsleep Natural
100_000
  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
withRegion RegionLayout
Linear ((Region m -> m ()) -> m ()) -> (Region m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Region m
r -> do
    Maybe Timeout
timeout <- (env -> Maybe Timeout) -> m (Maybe Timeout)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> Maybe Timeout
forall env. HasTimeout env => env -> Maybe Timeout
getTimeout
    IORef Natural
timer <- Natural -> m (IORef Natural)
forall a. HasCallStack => a -> m (IORef a)
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
a -> m (IORef a)
newIORef Natural
0
    m Bool -> m () -> m ()
forall (m :: Type -> Type) a. Monad m => m Bool -> m a -> m ()
Utils.whileM_ (Region m -> IORef Natural -> Maybe Timeout -> m Bool
forall (m :: Type -> Type) env.
(HasAnyError env, HasCallStack, HasCommands env,
 HasCommonLogging env, HasConsoleLogging env (Region m),
 HasFileLogging env, MonadIORef m, MonadReader env m, MonadSTM m,
 MonadTime m) =>
Region m -> IORef Natural -> Maybe Timeout -> m Bool
keepRunning Region m
r IORef Natural
timer Maybe Timeout
timeout) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Natural -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadThread m) =>
Natural -> m ()
sleep Natural
1
      Natural
elapsed <- IORef Natural -> (Natural -> (Natural, Natural)) -> m Natural
forall a b. HasCallStack => IORef a -> (a -> (a, b)) -> m b
forall (m :: Type -> Type) a b.
(MonadIORef m, HasCallStack) =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef Natural
timer ((Natural -> (Natural, Natural)) -> m Natural)
-> (Natural -> (Natural, Natural)) -> m Natural
forall a b. (a -> b) -> a -> b
$ \Natural
t -> (Natural
t Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1, Natural
t Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1)
      Region m -> Natural -> m ()
forall (m :: Type -> Type) env.
(HasCallStack, HasCommonLogging env,
 HasConsoleLogging env (Region m), MonadReader env m, MonadSTM m) =>
Region m -> Natural -> m ()
logCounter Region m
r Natural
elapsed

logCounter ::
  forall m env.
  ( HasCallStack,
    HasCommonLogging env,
    HasConsoleLogging env (Region m),
    MonadReader env m,
    MonadSTM m
  ) =>
  Region m ->
  Natural ->
  m ()
logCounter :: forall (m :: Type -> Type) env.
(HasCallStack, HasCommonLogging env,
 HasConsoleLogging env (Region m), MonadReader env m, MonadSTM m) =>
Region m -> Natural -> m ()
logCounter Region m
region Natural
elapsed = do
  TimerFormat
timerFormat <- (env -> TimerFormat) -> m TimerFormat
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (Optic'
  A_Lens
  NoIx
  (Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m))))
  TimerFormat
-> Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m)))
-> TimerFormat
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens
  (Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m))))
  (Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m))))
  ConsoleLoggingEnv
  ConsoleLoggingEnv
forall s t a b. Field1 s t a b => Lens s t a b
_1 Lens
  (Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m))))
  (Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m))))
  ConsoleLoggingEnv
  ConsoleLoggingEnv
-> Optic' A_Lens NoIx ConsoleLoggingEnv TimerFormat
-> Optic'
     A_Lens
     NoIx
     (Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m))))
     TimerFormat
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 ConsoleLoggingEnv TimerFormat
#timerFormat) (Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m)))
 -> TimerFormat)
-> (env
    -> Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion (Region m))))
-> env
-> TimerFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env r.
HasConsoleLogging env r =>
env -> Tuple2 ConsoleLoggingEnv (TBQueue (LogRegion r))
getConsoleLogging @_ @(Region m))

  let msg :: UnlinedText
msg = TimerFormat -> Natural -> UnlinedText
TimerFormat.formatSeconds TimerFormat
timerFormat Natural
elapsed
      lg :: Log
lg =
        MkLog
          { cmd :: Maybe CommandP1
cmd = Maybe CommandP1
forall a. Maybe a
Nothing,
            UnlinedText
msg :: UnlinedText
msg :: UnlinedText
msg,
            lvl :: LogLevel
lvl = LogLevel
LevelTimer,
            mode :: LogMode
mode = LogMode
LogModeSet
          }
  Region m -> Log -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommonLogging env,
 HasConsoleLogging env (Region m), MonadReader env m, MonadSTM m) =>
Region m -> Log -> m ()
Logging.regionLogToConsoleQueue Region m
region Log
lg

keepRunning ::
  forall m env.
  ( HasAnyError env,
    HasCallStack,
    HasCommands env,
    HasCommonLogging env,
    HasConsoleLogging env (Region m),
    HasFileLogging env,
    MonadIORef m,
    MonadReader env m,
    MonadSTM m,
    MonadTime m
  ) =>
  Region m ->
  IORef Natural ->
  Maybe Timeout ->
  m Bool
keepRunning :: forall (m :: Type -> Type) env.
(HasAnyError env, HasCallStack, HasCommands env,
 HasCommonLogging env, HasConsoleLogging env (Region m),
 HasFileLogging env, MonadIORef m, MonadReader env m, MonadSTM m,
 MonadTime m) =>
Region m -> IORef Natural -> Maybe Timeout -> m Bool
keepRunning Region m
region IORef Natural
timer Maybe Timeout
mto = do
  Natural
elapsed <- IORef Natural -> m Natural
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef IORef Natural
timer
  if Natural -> Maybe Timeout -> Bool
timedOut Natural
elapsed Maybe Timeout
mto
    then do
      KeyHideSwitch
keyHide <- (env -> KeyHideSwitch) -> m KeyHideSwitch
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (Optic' An_Iso NoIx CommonLoggingEnv KeyHideSwitch
-> CommonLoggingEnv -> KeyHideSwitch
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' An_Iso NoIx CommonLoggingEnv KeyHideSwitch
#keyHide (CommonLoggingEnv -> KeyHideSwitch)
-> (env -> CommonLoggingEnv) -> env -> KeyHideSwitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. env -> CommonLoggingEnv
forall env. HasCommonLogging env => env -> CommonLoggingEnv
getCommonLogging)
      NESeq CommandP1
allCmds <- (env -> NESeq CommandP1) -> m (NESeq CommandP1)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> NESeq CommandP1
forall env. HasCommands env => env -> NESeq CommandP1
getCommands
      TVar (Seq CommandP1)
completedCommandsTVar <- (env -> TVar (Seq CommandP1)) -> m (TVar (Seq CommandP1))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> TVar (Seq CommandP1)
forall env. HasCommands env => env -> TVar (Seq CommandP1)
getCompletedCommands
      Seq CommandP1
completedCommands <- TVar (Seq CommandP1) -> m (Seq CommandP1)
forall (m :: Type -> Type) a.
(HasCallStack, MonadSTM m) =>
TVar a -> m a
readTVarA TVar (Seq CommandP1)
completedCommandsTVar

      -- update anyError
      m ()
forall env (m :: Type -> Type).
(HasAnyError env, HasCallStack, MonadReader env m, MonadSTM m) =>
m ()
setAnyErrorTrue

      let completedCommandsSet :: HashSet CommandP1
completedCommandsSet = [CommandP1] -> HashSet CommandP1
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([CommandP1] -> HashSet CommandP1)
-> [CommandP1] -> HashSet CommandP1
forall a b. (a -> b) -> a -> b
$ Seq CommandP1 -> [CommandP1]
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList Seq CommandP1
completedCommands
          allCmdsSet :: HashSet CommandP1
allCmdsSet = [CommandP1] -> HashSet CommandP1
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([CommandP1] -> HashSet CommandP1)
-> [CommandP1] -> HashSet CommandP1
forall a b. (a -> b) -> a -> b
$ NESeq CommandP1 -> [CommandP1]
forall a. NESeq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList NESeq CommandP1
allCmds
          incompleteCmds :: HashSet CommandP1
incompleteCmds = HashSet CommandP1 -> HashSet CommandP1 -> HashSet CommandP1
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
Set.difference HashSet CommandP1
allCmdsSet HashSet CommandP1
completedCommandsSet
          toTxtList :: List UnlinedText -> CommandP1 -> List UnlinedText
toTxtList List UnlinedText
acc CommandP1
cmd = CommandP1 -> KeyHideSwitch -> UnlinedText
LogFmt.displayCmd CommandP1
cmd KeyHideSwitch
keyHide UnlinedText -> List UnlinedText -> List UnlinedText
forall a. a -> [a] -> [a]
: List UnlinedText
acc

          unfinishedCmds :: UnlinedText
unfinishedCmds =
            UnlinedText -> List UnlinedText -> UnlinedText
ShrunText.intercalate UnlinedText
", "
              (List UnlinedText -> UnlinedText)
-> List UnlinedText -> UnlinedText
forall a b. (a -> b) -> a -> b
$ (List UnlinedText -> CommandP1 -> List UnlinedText)
-> List UnlinedText -> HashSet CommandP1 -> List UnlinedText
forall b a. (b -> a -> b) -> b -> HashSet a -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' List UnlinedText -> CommandP1 -> List UnlinedText
toTxtList [] HashSet CommandP1
incompleteCmds

      Region m -> Log -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 MonadReader env m, MonadSTM m, MonadTime m) =>
Region m -> Log -> m ()
Logging.putRegionLog Region m
region
        (Log -> m ()) -> Log -> m ()
forall a b. (a -> b) -> a -> b
$ MkLog
          { cmd :: Maybe CommandP1
cmd = Maybe CommandP1
forall a. Maybe a
Nothing,
            msg :: UnlinedText
msg = UnlinedText
"Timed out, cancelling remaining commands: " UnlinedText -> UnlinedText -> UnlinedText
forall a. Semigroup a => a -> a -> a
<> UnlinedText
unfinishedCmds,
            lvl :: LogLevel
lvl = LogLevel
LevelWarn,
            mode :: LogMode
mode = LogMode
LogModeFinish
          }
      pure Bool
False
    else Bool -> m Bool
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
True

timedOut :: Natural -> Maybe Timeout -> Bool
timedOut :: Natural -> Maybe Timeout -> Bool
timedOut Natural
_ Maybe Timeout
Nothing = Bool
False
timedOut Natural
timer (Just (MkTimeout Natural
t)) = Natural
timer Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
t

pollQueueToConsole ::
  ( HasCallStack,
    MonadMask m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadSTM m
  ) =>
  TBQueue (LogRegion (Region m)) ->
  m void
pollQueueToConsole :: forall (m :: Type -> Type) env void.
(HasCallStack, MonadMask m, MonadReader env m, MonadRegionLogger m,
 MonadSTM m) =>
TBQueue (LogRegion (Region m)) -> m void
pollQueueToConsole TBQueue (LogRegion (Region m))
queue = do
  -- NOTE: Same masking behavior as pollQueueToFile.
  m () -> m void
forall (f :: Type -> Type) a b. Applicative f => f a -> f b
forever (m () -> m void) -> m () -> m void
forall a b. (a -> b) -> a -> b
$ TBQueue (LogRegion (Region m))
-> (LogRegion (Region m) -> m ()) -> m ()
forall (m :: Type -> Type) a b.
(HasCallStack, MonadMask m, MonadSTM m) =>
TBQueue a -> (a -> m b) -> m ()
atomicReadWrite TBQueue (LogRegion (Region m))
queue LogRegion (Region m) -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadRegionLogger m) =>
LogRegion (Region m) -> m ()
printConsoleLog

printConsoleLog ::
  ( HasCallStack,
    MonadRegionLogger m
  ) =>
  LogRegion (Region m) ->
  m ()
printConsoleLog :: forall (m :: Type -> Type).
(HasCallStack, MonadRegionLogger m) =>
LogRegion (Region m) -> m ()
printConsoleLog (LogNoRegion ConsoleLog
consoleLog) = Text -> m ()
forall (m :: Type -> Type).
(MonadRegionLogger m, HasCallStack) =>
Text -> m ()
logGlobal (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)
printConsoleLog (LogRegion LogMode
m Region m
r ConsoleLog
consoleLog) = LogMode -> Region m -> Text -> m ()
forall (m :: Type -> Type).
(MonadRegionLogger m, HasCallStack) =>
LogMode -> Region m -> Text -> m ()
logRegion LogMode
m 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)

pollQueueToFile ::
  ( HasCallStack,
    MonadHandleWriter m,
    MonadMask m,
    MonadSTM m
  ) =>
  FileLoggingEnv ->
  m void
pollQueueToFile :: forall (m :: Type -> Type) void.
(HasCallStack, MonadHandleWriter m, MonadMask m, MonadSTM m) =>
FileLoggingEnv -> m void
pollQueueToFile FileLoggingEnv
fileLogging = do
  m () -> m void
forall (f :: Type -> Type) a b. Applicative f => f a -> f b
forever
    (m () -> m void) -> m () -> m void
forall a b. (a -> b) -> a -> b
$
    -- NOTE: Read+write needs to be atomic, otherwise we can lose logs
    -- (i.e. thread reads the log and is cancelled before it can write it).
    -- Hence the mask.
    TBQueue FileLog -> (FileLog -> m ()) -> m ()
forall (m :: Type -> Type) a b.
(HasCallStack, MonadMask m, MonadSTM m) =>
TBQueue a -> (a -> m b) -> m ()
atomicReadWrite TBQueue FileLog
queue (Handle -> FileLog -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadHandleWriter m) =>
Handle -> FileLog -> m ()
logFile Handle
h)
  where
    MkFileLogOpened Handle
h TBQueue FileLog
queue = FileLoggingEnv
fileLogging FileLoggingEnv
-> Optic' A_Lens NoIx FileLoggingEnv FileLogOpened -> FileLogOpened
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx FileLoggingEnv FileLogOpened
#file

logFile :: (HasCallStack, MonadHandleWriter m) => Handle -> FileLog -> m ()
logFile :: forall (m :: Type -> Type).
(HasCallStack, MonadHandleWriter m) =>
Handle -> FileLog -> m ()
logFile Handle
h = (\Text
t -> Handle -> Text -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadHandleWriter m) =>
Handle -> Text -> m ()
hPutUtf8 Handle
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 -> m ()
forall (m :: Type -> Type).
(MonadHandleWriter m, HasCallStack) =>
Handle -> m ()
hFlush Handle
h) (Text -> m ()) -> (FileLog -> Text) -> FileLog -> m ()
forall b c a. (b -> c) -> (a -> b) -> 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

-- | Reads from a queue and applies the function, if we receive a value.
-- Atomic in the sense that if a read is successful, then we will apply the
-- given function, even if an async exception is raised.
atomicReadWrite ::
  ( HasCallStack,
    MonadMask m,
    MonadSTM m
  ) =>
  -- | Queue from which to read.
  TBQueue a ->
  -- | Function to apply.
  (a -> m b) ->
  m ()
atomicReadWrite :: forall (m :: Type -> Type) a b.
(HasCallStack, MonadMask m, MonadSTM m) =>
TBQueue a -> (a -> m b) -> m ()
atomicReadWrite TBQueue a
queue a -> m b
logAction =
  ((forall a. m a -> m a) -> m ()) -> m ()
forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b
forall (m :: Type -> Type) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m ()) -> m ())
-> ((forall a. m a -> m a) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> m a -> m a
forall a. m a -> m a
restore (TBQueue a -> m a
forall (m :: Type -> Type) a.
(HasCallStack, MonadSTM m) =>
TBQueue a -> m a
readTBQueueA TBQueue a
queue) m a -> (a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= m b -> m ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (m b -> m ()) -> (a -> m b) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
logAction