module Shrun.Command
  ( -- * Primary
    runCommands,

    -- * Misc
    PredecessorResult (..),
  )
where

import Data.HashMap.Strict qualified as Map
import Data.Text qualified as T
import Effects.Concurrent.Async qualified as Async
import Shrun.Command.Types
  ( CommandP1,
    CommandStatus
      ( CommandFailure,
        CommandRunning,
        CommandSuccess,
        CommandWaiting
      ),
    TCommandStatusMap,
  )
import Shrun.Command.Types qualified as Command.Types
import Shrun.Configuration.Data.Graph
  ( CommandGraph,
    EdgeLabel (EdgeAnd, EdgeAny, EdgeOr),
    Vertex,
  )
import Shrun.Configuration.Data.Graph qualified as Graph
import Shrun.Configuration.Env.Types
  ( HasCommands (getCommandDepGraph, getCommandStatusMap),
    HasCommonLogging (getCommonLogging),
    HasLogging,
  )
import Shrun.Data.Text (UnlinedText (UnsafeUnlinedText))
import Shrun.Logging qualified as Logging
import Shrun.Logging.Formatting qualified as Formatting
import Shrun.Logging.MonadRegionLogger (MonadRegionLogger (withRegion))
import Shrun.Logging.Types
  ( Log (MkLog, cmd, lvl, mode, msg),
    LogLevel (LevelError, LevelWarn),
    LogMessage (UnsafeLogMessage),
  )
import Shrun.Logging.Types.Internal (LogMode (LogModeFinish))
import Shrun.Prelude

-- | Responsible for scheduling commands.
runCommands ::
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAsync m,
    MonadAtomic m,
    MonadEvaluate m,
    MonadMVar m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadThrow m,
    MonadTime m
  ) =>
  -- | Individual command runner.
  ((HasCallStack) => CommandP1 -> m ()) ->
  m ()
runCommands :: forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAsync m,
 MonadAtomic m, MonadEvaluate m, MonadMVar m, MonadReader env m,
 MonadRegionLogger m, MonadThrow m, MonadTime m) =>
(HasCallStack => CommandP1 -> m ()) -> m ()
runCommands HasCallStack => CommandP1 -> m ()
runner = do
  CommandGraph
cdg <- (env -> CommandGraph) -> m CommandGraph
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> CommandGraph
forall env. HasCommands env => env -> CommandGraph
getCommandDepGraph
  TCommandStatusMap
commandStatusMap <- (env -> TCommandStatusMap) -> m TCommandStatusMap
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> TCommandStatusMap
forall env. HasCommands env => env -> TCommandStatusMap
getCommandStatusMap
  let roots :: NESeq Vertex
roots = CommandGraph
cdg CommandGraph
-> Optic' A_Lens NoIx CommandGraph (NESeq Vertex) -> NESeq Vertex
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandGraph (NESeq Vertex)
#roots
  HashMap Vertex (MVar ())
vtxSemMap <- CommandGraph -> m (HashMap Vertex (MVar ()))
forall (m :: Type -> Type).
MonadMVar m =>
CommandGraph -> m (HashMap Vertex (MVar ()))
mkVertexSemMap CommandGraph
cdg
  (Vertex -> m ()) -> NESeq Vertex -> m ()
forall (m :: Type -> Type) (f :: Type -> Type) a b.
(MonadAsync m, Foldable f) =>
(a -> m b) -> f a -> m ()
Async.mapConcurrently_ ((HasCallStack => CommandP1 -> m ())
-> CommandGraph
-> TCommandStatusMap
-> HashMap Vertex (MVar ())
-> Vertex
-> m ()
forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasLogging env m, MonadAsync m,
 MonadAtomic m, MonadEvaluate m, MonadMVar m, MonadReader env m,
 MonadRegionLogger m, MonadThrow m, MonadTime m) =>
(HasCallStack => CommandP1 -> m ())
-> CommandGraph
-> TCommandStatusMap
-> HashMap Vertex (MVar ())
-> Vertex
-> m ()
runCommand HasCallStack => CommandP1 -> m ()
CommandP1 -> m ()
runner CommandGraph
cdg TCommandStatusMap
commandStatusMap HashMap Vertex (MVar ())
vtxSemMap) NESeq Vertex
roots
{-# INLINEABLE runCommands #-}

-- | Builds a map for each Vertex -> MVar. This ensures that we only start
-- each command at most once.
mkVertexSemMap :: (MonadMVar m) => CommandGraph -> m (HashMap Vertex (MVar ()))
mkVertexSemMap :: forall (m :: Type -> Type).
MonadMVar m =>
CommandGraph -> m (HashMap Vertex (MVar ()))
mkVertexSemMap =
  ([(Vertex, MVar ())] -> HashMap Vertex (MVar ()))
-> m [(Vertex, MVar ())] -> m (HashMap Vertex (MVar ()))
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Vertex, MVar ())] -> HashMap Vertex (MVar ())
forall k v. Hashable k => [(k, v)] -> HashMap k v
Map.fromList
    (m [(Vertex, MVar ())] -> m (HashMap Vertex (MVar ())))
-> (CommandGraph -> m [(Vertex, MVar ())])
-> CommandGraph
-> m (HashMap Vertex (MVar ()))
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
. (Vertex -> m (Vertex, MVar ()))
-> [Vertex] -> m [(Vertex, MVar ())]
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) -> [a] -> f [b]
traverse (\Vertex
v -> (Vertex
v,) (MVar () -> (Vertex, MVar ()))
-> m (MVar ()) -> m (Vertex, MVar ())
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> m (MVar ())
forall a. a -> m (MVar a)
forall (m :: Type -> Type) a. MonadMVar m => a -> m (MVar a)
newMVar' ())
    ([Vertex] -> m [(Vertex, MVar ())])
-> (CommandGraph -> [Vertex])
-> CommandGraph
-> m [(Vertex, MVar ())]
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
. CommandGraph -> [Vertex]
Graph.vertices
{-# INLINEABLE mkVertexSemMap #-}

runCommand ::
  forall m env.
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAsync m,
    MonadAtomic m,
    MonadEvaluate m,
    MonadMVar m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadThrow m,
    MonadTime m
  ) =>
  -- | Individual command runner.
  ((HasCallStack) => CommandP1 -> m ()) ->
  -- | Command dependency graph.
  CommandGraph ->
  -- | Command status ref.
  TCommandStatusMap ->
  -- | Vertex semaphore map, for preventing the same command being kicked off
  -- by multiple commands.
  HashMap Vertex (MVar ()) ->
  -- | Vertex to run.
  Vertex ->
  m ()
runCommand :: forall (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasLogging env m, MonadAsync m,
 MonadAtomic m, MonadEvaluate m, MonadMVar m, MonadReader env m,
 MonadRegionLogger m, MonadThrow m, MonadTime m) =>
(HasCallStack => CommandP1 -> m ())
-> CommandGraph
-> TCommandStatusMap
-> HashMap Vertex (MVar ())
-> Vertex
-> m ()
runCommand HasCallStack => CommandP1 -> m ()
runner CommandGraph
cdg TCommandStatusMap
commandStatusMap HashMap Vertex (MVar ())
vtxSemMap = Maybe Vertex -> Vertex -> m ()
go Maybe Vertex
forall a. Maybe a
Nothing
  where
    go :: Maybe Vertex -> Vertex -> m ()
go Maybe Vertex
prevVertex Vertex
vertex = do
      -- Check that all predecessor edges have been satisfied.
      PredecessorResult
status <- CommandGraph -> TCommandStatusMap -> Vertex -> m PredecessorResult
forall (m :: Type -> Type).
(HasCallStack, MonadAtomic m, MonadThrow m) =>
CommandGraph -> TCommandStatusMap -> Vertex -> m PredecessorResult
getPredecessorsStatus CommandGraph
cdg TCommandStatusMap
commandStatusMap Vertex
vertex
      case PredecessorResult
status of
        PredecessorUnfinished Vertex
depV ->
          (LogLevel -> m ()) -> m ()
forall env (m :: Type -> Type).
(HasCommonLogging env, MonadReader env m) =>
(LogLevel -> m ()) -> m ()
Logging.logDebug ((LogLevel -> m ()) -> m ()) -> (LogLevel -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \LogLevel
lvl -> do
            CommandGraph
-> LogLevel
-> Maybe Vertex
-> (UnlinedText -> UnlinedText -> UnlinedText)
-> Maybe Vertex
-> Vertex
-> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadEvaluate m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
CommandGraph
-> LogLevel
-> Maybe Vertex
-> (UnlinedText -> UnlinedText -> UnlinedText)
-> Maybe Vertex
-> Vertex
-> m ()
logCommandAction CommandGraph
cdg LogLevel
lvl Maybe Vertex
prevVertex UnlinedText -> UnlinedText -> UnlinedText
forall {a}. (Monoid a, IsString a) => a -> a -> a
debugMsg (Vertex -> Maybe Vertex
forall a. a -> Maybe a
Just Vertex
depV) Vertex
vertex
        PredecessorFailure Bool
failExpected Vertex
depV -> do
          if Bool
failExpected
            then
              CommandGraph
-> LogLevel
-> Maybe Vertex
-> (UnlinedText -> UnlinedText -> UnlinedText)
-> Maybe Vertex
-> Vertex
-> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadEvaluate m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
CommandGraph
-> LogLevel
-> Maybe Vertex
-> (UnlinedText -> UnlinedText -> UnlinedText)
-> Maybe Vertex
-> Vertex
-> m ()
logCommandAction CommandGraph
cdg LogLevel
LevelWarn Maybe Vertex
prevVertex UnlinedText -> UnlinedText -> UnlinedText
forall {a}. (Monoid a, IsString a) => a -> a -> a
failOkMsg (Vertex -> Maybe Vertex
forall a. a -> Maybe a
Just Vertex
depV) Vertex
vertex
            else
              CommandGraph
-> LogLevel
-> Maybe Vertex
-> (UnlinedText -> UnlinedText -> UnlinedText)
-> Maybe Vertex
-> Vertex
-> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadEvaluate m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
CommandGraph
-> LogLevel
-> Maybe Vertex
-> (UnlinedText -> UnlinedText -> UnlinedText)
-> Maybe Vertex
-> Vertex
-> m ()
logCommandAction CommandGraph
cdg LogLevel
LevelError Maybe Vertex
prevVertex UnlinedText -> UnlinedText -> UnlinedText
forall {a}. (Monoid a, IsString a) => a -> a -> a
errMsg (Vertex -> Maybe Vertex
forall a. a -> Maybe a
Just Vertex
depV) Vertex
vertex
        PredecessorResult
PredecessorSuccess -> do
          case Vertex -> HashMap Vertex (MVar ()) -> Maybe (MVar ())
forall k v. Hashable k => k -> HashMap k v -> Maybe v
Map.lookup Vertex
vertex HashMap Vertex (MVar ())
vtxSemMap of
            Maybe (MVar ())
Nothing ->
              Text -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadThrow m) =>
Text -> m a
throwText
                (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                  [ Text
"Could not find vertex ",
                    Vertex -> Text
forall a. Show a => a -> Text
showt Vertex
vertex,
                    Text
" in vertex map ",
                    Text -> [Text] -> Text
T.intercalate Text
", " (Vertex -> Text
forall a. Show a => a -> Text
showt (Vertex -> Text) -> [Vertex] -> [Text]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Vertex (MVar ()) -> [Vertex]
forall k v. HashMap k v -> [k]
Map.keys HashMap Vertex (MVar ())
vtxSemMap)
                  ]
            Just MVar ()
mvar ->
              -- NOTE: [Command Race]
              --
              -- Suppose we have the following dep graph:
              --
              --   1 -> 3, 2 -> 3
              --
              -- and commmands 1 and 2 take the same amount of time. If both
              -- threads finish 'runner' and call 'mapConcurrently' at the
              -- same time, then we will have two threads corresponding to
              -- 3, and each will notice that all dependent tasks have finished
              -- successfully, hence start the task. That is obviously not
              -- what we want!
              --
              -- Normally, our logic blocks multiple sends like this by
              -- abandoning the attempt if any attempts are still running.
              -- When both finish simultaneously, however, this won't work.
              --
              -- Hence we have a map Vertex -> MVar, and the task can only
              -- start if it can retrieve the MVar. If the MVar is empty,
              -- another thread must have started it.
              --
              -- We never restore the MVar (because a command should only
              -- be run at most once), so the only sensible thing we can do
              -- is exit.
              MVar () -> m (Maybe ())
forall a. MVar a -> m (Maybe a)
forall (m :: Type -> Type) a. MonadMVar m => MVar a -> m (Maybe a)
tryTakeMVar' MVar ()
mvar m (Maybe ()) -> (Maybe () -> 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
>>= \case
                Maybe ()
Nothing ->
                  -- No MVar, print a message and leave.
                  (LogLevel -> m ()) -> m ()
forall env (m :: Type -> Type).
(HasCommonLogging env, MonadReader env m) =>
(LogLevel -> m ()) -> m ()
Logging.logDebug ((LogLevel -> m ()) -> m ()) -> (LogLevel -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \LogLevel
lvl -> do
                    CommandGraph
-> LogLevel
-> Maybe Vertex
-> (UnlinedText -> UnlinedText -> UnlinedText)
-> Maybe Vertex
-> Vertex
-> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadEvaluate m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
CommandGraph
-> LogLevel
-> Maybe Vertex
-> (UnlinedText -> UnlinedText -> UnlinedText)
-> Maybe Vertex
-> Vertex
-> m ()
logCommandAction CommandGraph
cdg LogLevel
lvl Maybe Vertex
prevVertex UnlinedText -> UnlinedText -> UnlinedText
forall {a} {p}. (Monoid a, IsString a) => p -> a -> a
alreadyRunningMsg Maybe Vertex
forall a. Maybe a
Nothing Vertex
vertex
                Just () -> do
                  -- We are not blocked. Run the command and kick off all
                  -- successors.
                  Context CommandP1 EdgeLabel
ctx <- CommandGraph -> Vertex -> m (Context CommandP1 EdgeLabel)
forall (m :: Type -> Type).
(HasCallStack, MonadEvaluate m) =>
CommandGraph -> Vertex -> m (Context CommandP1 EdgeLabel)
Graph.context CommandGraph
cdg Vertex
vertex
                  let (Vertex
_, CommandP1
cmd) = Context CommandP1 EdgeLabel -> (Vertex, CommandP1)
forall a b. Context a b -> LVertex a
Graph.ctxLabVertex Context CommandP1 EdgeLabel
ctx
                      outNodes :: [Vertex]
outNodes = Context CommandP1 EdgeLabel -> [Vertex]
forall a b. Context a b -> [Vertex]
Graph.ctxOutVertices Context CommandP1 EdgeLabel
ctx

                  (LogLevel -> m ()) -> m ()
forall env (m :: Type -> Type).
(HasCommonLogging env, MonadReader env m) =>
(LogLevel -> m ()) -> m ()
Logging.logDebug ((LogLevel -> m ()) -> m ()) -> (LogLevel -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \LogLevel
lvl -> do
                    CommandGraph
-> LogLevel
-> Maybe Vertex
-> (UnlinedText -> UnlinedText -> UnlinedText)
-> Maybe Vertex
-> Vertex
-> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadEvaluate m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
CommandGraph
-> LogLevel
-> Maybe Vertex
-> (UnlinedText -> UnlinedText -> UnlinedText)
-> Maybe Vertex
-> Vertex
-> m ()
logCommandAction CommandGraph
cdg LogLevel
lvl Maybe Vertex
prevVertex UnlinedText -> UnlinedText -> UnlinedText
forall {a} {p}. (Monoid a, IsString a) => p -> a -> a
startMsg Maybe Vertex
forall a. Maybe a
Nothing Vertex
vertex

                  HasCallStack => CommandP1 -> m ()
CommandP1 -> m ()
runner CommandP1
cmd
                  (Vertex -> m ()) -> [Vertex] -> m ()
forall (m :: Type -> Type) (f :: Type -> Type) a b.
(MonadAsync m, Foldable f) =>
(a -> m b) -> f a -> m ()
Async.mapConcurrently_ (Maybe Vertex -> Vertex -> m ()
go (Vertex -> Maybe Vertex
forall a. a -> Maybe a
Just Vertex
vertex)) [Vertex]
outNodes

    debugMsg :: a -> a -> a
debugMsg a
depCmdTxt a
cmdTxt =
      [a] -> a
forall a. Monoid a => [a] -> a
mconcat
        [ a
"Command '",
          a
cmdTxt,
          a
"' is blocked due to dependency pending: '",
          a
depCmdTxt,
          a
"'."
        ]

    errMsg :: a -> a -> a
errMsg a
depCmdTxt a
cmdTxt =
      [a] -> a
forall a. Monoid a => [a] -> a
mconcat
        [ a
"Not starting '",
          a
cmdTxt,
          a
"' due to dependency failure: '",
          a
depCmdTxt,
          a
"'."
        ]

    failOkMsg :: a -> a -> a
failOkMsg a
depCmdTxt a
cmdTxt =
      [a] -> a
forall a. Monoid a => [a] -> a
mconcat
        [ a
"Not starting '",
          a
cmdTxt,
          a
"' due to dependency success: '",
          a
depCmdTxt,
          a
"'."
        ]

    startMsg :: p -> a -> a
startMsg p
_ a
cmdTxt =
      [a] -> a
forall a. Monoid a => [a] -> a
mconcat
        [ a
"Starting '",
          a
cmdTxt,
          a
"'."
        ]

    alreadyRunningMsg :: p -> a -> a
alreadyRunningMsg p
_ a
cmdTxt =
      [a] -> a
forall a. Monoid a => [a] -> a
mconcat
        [ a
"Command '",
          a
cmdTxt,
          a
"' is already running."
        ]
{-# INLINEABLE runCommand #-}

-- | Given a vertex v, 'PredecessorResult' represents the status of all of
-- its predecessors. Note that this refers to the status of the
-- 'edge condition', /not/ the predecessor command itself. For instance,
-- if we have 'cmd1 | cmd2' and cmd1 fails, that is considered
-- PredecessorSuccess.
--
-- The algebra is left-biased for identical constructors, otherwise takes the
-- greatest in
--
-- @
--   PredecessorSuccess < PredecessorFailure < PredecessorUnfinished
-- @
--
-- We have unfinished higher than failed as we only need to consider the
-- overall success/failed status once, when everything has finished. This also
-- makes logging simpler, as we only print non-debug messages for
-- failure, and having unfinished first means we do not have multiple commands
-- all printing the same "cannot start command ... due to other failure"
-- log.
data PredecessorResult
  = -- | Some predecessor unfinished.
    PredecessorUnfinished Vertex
  | -- | All predecessors finished and expectations matched. Note that this
    -- does /not/ necessarily imply all predecessor /commands/ finished
    -- successfully.
    PredecessorSuccess
  | -- | Some predecessor finished but did not match the expectation. The
    -- boolean is True iff failure was expected.
    PredecessorFailure Bool Vertex
  deriving stock (PredecessorResult -> PredecessorResult -> Bool
(PredecessorResult -> PredecessorResult -> Bool)
-> (PredecessorResult -> PredecessorResult -> Bool)
-> Eq PredecessorResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PredecessorResult -> PredecessorResult -> Bool
== :: PredecessorResult -> PredecessorResult -> Bool
$c/= :: PredecessorResult -> PredecessorResult -> Bool
/= :: PredecessorResult -> PredecessorResult -> Bool
Eq, Vertex -> PredecessorResult -> ShowS
[PredecessorResult] -> ShowS
PredecessorResult -> String
(Vertex -> PredecessorResult -> ShowS)
-> (PredecessorResult -> String)
-> ([PredecessorResult] -> ShowS)
-> Show PredecessorResult
forall a.
(Vertex -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Vertex -> PredecessorResult -> ShowS
showsPrec :: Vertex -> PredecessorResult -> ShowS
$cshow :: PredecessorResult -> String
show :: PredecessorResult -> String
$cshowList :: [PredecessorResult] -> ShowS
showList :: [PredecessorResult] -> ShowS
Show)

instance Semigroup PredecessorResult where
  PredecessorUnfinished Vertex
v <> :: PredecessorResult -> PredecessorResult -> PredecessorResult
<> PredecessorResult
_ = Vertex -> PredecessorResult
PredecessorUnfinished Vertex
v
  PredecessorResult
_ <> PredecessorUnfinished Vertex
v = Vertex -> PredecessorResult
PredecessorUnfinished Vertex
v
  PredecessorFailure Bool
b Vertex
v <> PredecessorResult
_ = Bool -> Vertex -> PredecessorResult
PredecessorFailure Bool
b Vertex
v
  PredecessorResult
_ <> PredecessorFailure Bool
b Vertex
v = Bool -> Vertex -> PredecessorResult
PredecessorFailure Bool
b Vertex
v
  PredecessorResult
PredecessorSuccess <> PredecessorResult
PredecessorSuccess = PredecessorResult
PredecessorSuccess

instance Monoid PredecessorResult where
  mempty :: PredecessorResult
mempty = PredecessorResult
PredecessorSuccess

-- | Get result of all predecessor nodes. We only progress if all have finished
-- and each result matches the expectation (e.g. CommandSuccess and EdgeSucces).
getPredecessorsStatus ::
  forall m.
  ( HasCallStack,
    MonadAtomic m,
    MonadThrow m
  ) =>
  CommandGraph ->
  TCommandStatusMap ->
  Vertex ->
  m PredecessorResult
getPredecessorsStatus :: forall (m :: Type -> Type).
(HasCallStack, MonadAtomic m, MonadThrow m) =>
CommandGraph -> TCommandStatusMap -> Vertex -> m PredecessorResult
getPredecessorsStatus CommandGraph
cdg TCommandStatusMap
commandStatusMap Vertex
v =
  -- Do all the processing in one transaction. STM inherits its type's monoid
  -- instance, so this satisfies:
  --
  -- 1. Result is fail-fast (Err is a hard stop).
  -- 2. If there are no predecessors we have mempty which is
  --    @Ok PredecessorSuccess@.
  -- 3. Otherwise, results are combined via PredecessorResult's Semigroup,
  --    which is what we want.
  STM (Result Text PredecessorResult)
-> m (Result Text PredecessorResult)
forall a. HasCallStack => STM a -> m a
forall (m :: Type -> Type) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (((Vertex, EdgeLabel) -> STM (Result Text PredecessorResult))
-> [(Vertex, EdgeLabel)] -> STM (Result Text PredecessorResult)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Vertex, EdgeLabel) -> STM (Result Text PredecessorResult)
toResult [(Vertex, EdgeLabel)]
predecessors) m (Result Text PredecessorResult)
-> (Result Text PredecessorResult -> m PredecessorResult)
-> m PredecessorResult
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
>>= \case
    Err Text
err -> Text -> m PredecessorResult
forall (m :: Type -> Type) a.
(HasCallStack, MonadThrow m) =>
Text -> m a
throwText Text
err
    Ok PredecessorResult
r -> PredecessorResult -> m PredecessorResult
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure PredecessorResult
r
  where
    predecessors :: [(Vertex, EdgeLabel)]
predecessors = CommandGraph -> Vertex -> [(Vertex, EdgeLabel)]
Graph.labInVertices CommandGraph
cdg Vertex
v

    toResult :: Tuple2 Vertex EdgeLabel -> STM (Result Text PredecessorResult)
    toResult :: (Vertex, EdgeLabel) -> STM (Result Text PredecessorResult)
toResult (Vertex
p, EdgeLabel
lbl) =
      let idx :: CommandIndex
idx = HasCallStack => Vertex -> CommandIndex
Vertex -> CommandIndex
Command.Types.fromVertex Vertex
p
       in case CommandIndex
-> HashMap CommandIndex (CommandP1, TVar CommandStatus)
-> Maybe (CommandP1, TVar CommandStatus)
forall k v. Hashable k => k -> HashMap k v -> Maybe v
Map.lookup CommandIndex
idx (TCommandStatusMap
commandStatusMap TCommandStatusMap
-> Optic'
     An_Iso
     NoIx
     TCommandStatusMap
     (HashMap CommandIndex (CommandP1, TVar CommandStatus))
-> HashMap CommandIndex (CommandP1, TVar CommandStatus)
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic'
  An_Iso
  NoIx
  TCommandStatusMap
  (HashMap CommandIndex (CommandP1, TVar CommandStatus))
#unCommandStatusMap) of
            Maybe (CommandP1, TVar CommandStatus)
Nothing ->
              Result Text PredecessorResult
-> STM (Result Text PredecessorResult)
forall a. a -> STM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
                (Result Text PredecessorResult
 -> STM (Result Text PredecessorResult))
-> (Text -> Result Text PredecessorResult)
-> Text
-> STM (Result Text PredecessorResult)
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 -> Result Text PredecessorResult
forall e a. e -> Result e a
Err
                (Text -> STM (Result Text PredecessorResult))
-> Text -> STM (Result Text PredecessorResult)
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                  [ Text
"Failed searching for command index ",
                    CommandIndex -> Text
forall a. Pretty a => a -> Text
prettyToText CommandIndex
idx
                  ]
            Just (CommandP1
_, TVar CommandStatus
statusVar) -> do
              CommandStatus
status <- TVar CommandStatus -> STM CommandStatus
forall a. TVar a -> STM a
readTVar' TVar CommandStatus
statusVar
              Result Text PredecessorResult
-> STM (Result Text PredecessorResult)
forall a. a -> STM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Result Text PredecessorResult
 -> STM (Result Text PredecessorResult))
-> (PredecessorResult -> Result Text PredecessorResult)
-> PredecessorResult
-> STM (Result Text PredecessorResult)
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
. PredecessorResult -> Result Text PredecessorResult
forall e a. a -> Result e a
Ok (PredecessorResult -> STM (Result Text PredecessorResult))
-> PredecessorResult -> STM (Result Text PredecessorResult)
forall a b. (a -> b) -> a -> b
$ case (CommandStatus
status, EdgeLabel
lbl) of
                (CommandStatus
CommandWaiting, EdgeLabel
_) -> Vertex -> PredecessorResult
PredecessorUnfinished Vertex
p
                (CommandRunning (Maybe Pid, [Pid])
_, EdgeLabel
_) -> Vertex -> PredecessorResult
PredecessorUnfinished Vertex
p
                (CommandStatus
CommandSuccess, EdgeLabel
EdgeAnd) -> PredecessorResult
PredecessorSuccess
                (CommandStatus
CommandSuccess, EdgeLabel
EdgeOr) -> Bool -> Vertex -> PredecessorResult
PredecessorFailure Bool
True Vertex
p
                (CommandStatus
CommandSuccess, EdgeLabel
EdgeAny) -> PredecessorResult
PredecessorSuccess
                (CommandStatus
CommandFailure, EdgeLabel
EdgeAnd) -> Bool -> Vertex -> PredecessorResult
PredecessorFailure Bool
False Vertex
p
                (CommandStatus
CommandFailure, EdgeLabel
EdgeOr) -> PredecessorResult
PredecessorSuccess
                (CommandStatus
CommandFailure, EdgeLabel
EdgeAny) -> PredecessorResult
PredecessorSuccess
{-# INLINEABLE getPredecessorsStatus #-}

logCommandAction ::
  ( HasCallStack,
    HasCommands env,
    HasLogging env m,
    MonadAtomic m,
    MonadEvaluate m,
    MonadReader env m,
    MonadRegionLogger m,
    MonadTime m
  ) =>
  -- | Dependency graph
  CommandGraph ->
  -- | Log level
  LogLevel ->
  -- | The predecessor vertex that started this one. Note that this may
  -- not be the same as mDepVertex.
  Maybe Vertex ->
  -- | Function to construct log message. Parameters are the dep vertex
  -- text and this vertex text.
  (UnlinedText -> UnlinedText -> UnlinedText) ->
  -- | Some predecessor vertex that has some problem.
  Maybe Vertex ->
  -- | Command vertex that will not be run.
  Vertex ->
  m ()
logCommandAction :: forall env (m :: Type -> Type).
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadEvaluate m, MonadReader env m, MonadRegionLogger m,
 MonadTime m) =>
CommandGraph
-> LogLevel
-> Maybe Vertex
-> (UnlinedText -> UnlinedText -> UnlinedText)
-> Maybe Vertex
-> Vertex
-> m ()
logCommandAction CommandGraph
cdg LogLevel
lvl Maybe Vertex
mPrevVertex UnlinedText -> UnlinedText -> UnlinedText
msgFn Maybe Vertex
mDepVertex Vertex
vertex = 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
  CommandP1
thisCmd <- Vertex -> m CommandP1
nodeToCommand Vertex
vertex
  Maybe CommandP1
prevCmd <- Maybe Vertex -> (Vertex -> m CommandP1) -> m (Maybe CommandP1)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe Vertex
mPrevVertex Vertex -> m CommandP1
nodeToCommand
  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

  UnlinedText
depCmdTxt <- case Maybe Vertex
mDepVertex of
    Maybe Vertex
Nothing -> UnlinedText -> m UnlinedText
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure UnlinedText
""
    Just Vertex
depVertex -> do
      CommandP1
depCmd <- Vertex -> m CommandP1
nodeToCommand Vertex
depVertex
      pure
        $ [UnlinedText] -> UnlinedText
forall a. Monoid a => [a] -> a
mconcat
          [ UnlinedText
"(",
            Vertex -> UnlinedText
vToUnlined Vertex
depVertex,
            UnlinedText
") ",
            CommandP1 -> KeyHideSwitch -> UnlinedText
Formatting.displayCmd CommandP1
depCmd KeyHideSwitch
keyHide
          ]
  let cmdTxt :: UnlinedText
cmdTxt = CommandP1 -> KeyHideSwitch -> UnlinedText
Formatting.displayCmd CommandP1
thisCmd KeyHideSwitch
keyHide
      errMsg :: UnlinedText
errMsg = UnlinedText -> UnlinedText -> UnlinedText
msgFn UnlinedText
depCmdTxt UnlinedText
cmdTxt

      log :: Log
log =
        MkLog
          { cmd :: Maybe CommandP1
cmd = Maybe CommandP1
prevCmd,
            msg :: LogMessage
msg = UnlinedText -> LogMessage
forall a b. Coercible a b => a -> b
coerce UnlinedText
errMsg,
            LogLevel
lvl :: LogLevel
lvl :: LogLevel
lvl,
            mode :: LogMode
mode = LogMode
LogModeFinish
          }

  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 (m :: Type -> Type) env.
(HasCallStack, HasCommands env, HasLogging env m, MonadAtomic m,
 MonadReader env m, MonadTime m) =>
Region m -> Log -> m ()
Logging.putRegionLog Region m
r Log
log
  where
    nodeToCommand :: Vertex -> m CommandP1
nodeToCommand = ((Vertex, CommandP1) -> CommandP1)
-> m (Vertex, CommandP1) -> m CommandP1
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Optic' A_Lens NoIx (Vertex, CommandP1) CommandP1
-> (Vertex, CommandP1) -> CommandP1
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx (Vertex, CommandP1) CommandP1
forall s t a b. Field2 s t a b => Lens s t a b
_2) (m (Vertex, CommandP1) -> m CommandP1)
-> (Vertex -> m (Vertex, CommandP1)) -> Vertex -> m CommandP1
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
. CommandGraph -> Vertex -> m (Vertex, CommandP1)
forall (m :: Type -> Type).
(HasCallStack, MonadEvaluate m) =>
CommandGraph -> Vertex -> m (Vertex, CommandP1)
Graph.labVertex CommandGraph
cdg

    -- Convert back to CommandIndex to match user-supplied value.
    vToUnlined :: Vertex -> UnlinedText
    vToUnlined :: Vertex -> UnlinedText
vToUnlined =
      String -> UnlinedText
forall a. IsString a => String -> a
fromString
        (String -> UnlinedText)
-> (Vertex -> String) -> Vertex -> 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 -> String
unpack
        (Text -> String) -> (Vertex -> Text) -> Vertex -> String
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
. CommandIndex -> Text
forall a. Pretty a => a -> Text
prettyToText
        (CommandIndex -> Text)
-> (Vertex -> CommandIndex) -> Vertex -> 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
. HasCallStack => Vertex -> CommandIndex
Vertex -> CommandIndex
Command.Types.fromVertex
{-# INLINEABLE logCommandAction #-}