{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE RecordWildCards    #-}

-- Concurrent execution with dependencies. Types currently hard-coded for needs

-- of stack, but could be generalized easily.

module Control.Concurrent.Execute
    ( ActionType (..)
    , ActionId (..)
    , ActionContext (..)
    , Action (..)
    , Concurrency (..)
    , runActions
    ) where

import           Control.Concurrent.STM ( check )
import           Stack.Prelude
import           Data.List ( sortBy )
import qualified Data.Set as Set

-- | Type representing exceptions thrown by functions exported by the

-- "Control.Concurrent.Execute" module.

data ExecuteException
  = InconsistentDependenciesBug
  deriving (Int -> ExecuteException -> ShowS
[ExecuteException] -> ShowS
ExecuteException -> String
(Int -> ExecuteException -> ShowS)
-> (ExecuteException -> String)
-> ([ExecuteException] -> ShowS)
-> Show ExecuteException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExecuteException -> ShowS
showsPrec :: Int -> ExecuteException -> ShowS
$cshow :: ExecuteException -> String
show :: ExecuteException -> String
$cshowList :: [ExecuteException] -> ShowS
showList :: [ExecuteException] -> ShowS
Show, Typeable)

instance Exception ExecuteException where
  displayException :: ExecuteException -> String
displayException ExecuteException
InconsistentDependenciesBug = String -> ShowS
bugReport String
"[S-2816]"
    String
"Inconsistent dependencies were discovered while executing your build \
    \plan."

-- | Type representing types of Stack build actions.

data ActionType
  = ATBuild
    -- ^ Action for building a package's library and executables. If

    -- 'taskAllInOne' is 'True', then this will also build benchmarks and tests.

    -- It is 'False' when the library's benchmarks or test-suites have cyclic

    -- dependencies.

  | ATBuildFinal
    -- ^ Task for building the package's benchmarks and test-suites. Requires

    -- that the library was already built.

  | ATRunTests
    -- ^ Task for running the package's test-suites.

  | ATRunBenchmarks
    -- ^ Task for running the package's benchmarks.

  deriving (Int -> ActionType -> ShowS
[ActionType] -> ShowS
ActionType -> String
(Int -> ActionType -> ShowS)
-> (ActionType -> String)
-> ([ActionType] -> ShowS)
-> Show ActionType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ActionType -> ShowS
showsPrec :: Int -> ActionType -> ShowS
$cshow :: ActionType -> String
show :: ActionType -> String
$cshowList :: [ActionType] -> ShowS
showList :: [ActionType] -> ShowS
Show, ActionType -> ActionType -> Bool
(ActionType -> ActionType -> Bool)
-> (ActionType -> ActionType -> Bool) -> Eq ActionType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ActionType -> ActionType -> Bool
== :: ActionType -> ActionType -> Bool
$c/= :: ActionType -> ActionType -> Bool
/= :: ActionType -> ActionType -> Bool
Eq, Eq ActionType
Eq ActionType
-> (ActionType -> ActionType -> Ordering)
-> (ActionType -> ActionType -> Bool)
-> (ActionType -> ActionType -> Bool)
-> (ActionType -> ActionType -> Bool)
-> (ActionType -> ActionType -> Bool)
-> (ActionType -> ActionType -> ActionType)
-> (ActionType -> ActionType -> ActionType)
-> Ord ActionType
ActionType -> ActionType -> Bool
ActionType -> ActionType -> Ordering
ActionType -> ActionType -> ActionType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ActionType -> ActionType -> Ordering
compare :: ActionType -> ActionType -> Ordering
$c< :: ActionType -> ActionType -> Bool
< :: ActionType -> ActionType -> Bool
$c<= :: ActionType -> ActionType -> Bool
<= :: ActionType -> ActionType -> Bool
$c> :: ActionType -> ActionType -> Bool
> :: ActionType -> ActionType -> Bool
$c>= :: ActionType -> ActionType -> Bool
>= :: ActionType -> ActionType -> Bool
$cmax :: ActionType -> ActionType -> ActionType
max :: ActionType -> ActionType -> ActionType
$cmin :: ActionType -> ActionType -> ActionType
min :: ActionType -> ActionType -> ActionType
Ord)

-- | Types representing the unique ids of Stack build actions.

data ActionId
  = ActionId !PackageIdentifier !ActionType
  deriving (ActionId -> ActionId -> Bool
(ActionId -> ActionId -> Bool)
-> (ActionId -> ActionId -> Bool) -> Eq ActionId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ActionId -> ActionId -> Bool
== :: ActionId -> ActionId -> Bool
$c/= :: ActionId -> ActionId -> Bool
/= :: ActionId -> ActionId -> Bool
Eq, Eq ActionId
Eq ActionId
-> (ActionId -> ActionId -> Ordering)
-> (ActionId -> ActionId -> Bool)
-> (ActionId -> ActionId -> Bool)
-> (ActionId -> ActionId -> Bool)
-> (ActionId -> ActionId -> Bool)
-> (ActionId -> ActionId -> ActionId)
-> (ActionId -> ActionId -> ActionId)
-> Ord ActionId
ActionId -> ActionId -> Bool
ActionId -> ActionId -> Ordering
ActionId -> ActionId -> ActionId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ActionId -> ActionId -> Ordering
compare :: ActionId -> ActionId -> Ordering
$c< :: ActionId -> ActionId -> Bool
< :: ActionId -> ActionId -> Bool
$c<= :: ActionId -> ActionId -> Bool
<= :: ActionId -> ActionId -> Bool
$c> :: ActionId -> ActionId -> Bool
> :: ActionId -> ActionId -> Bool
$c>= :: ActionId -> ActionId -> Bool
>= :: ActionId -> ActionId -> Bool
$cmax :: ActionId -> ActionId -> ActionId
max :: ActionId -> ActionId -> ActionId
$cmin :: ActionId -> ActionId -> ActionId
min :: ActionId -> ActionId -> ActionId
Ord, Int -> ActionId -> ShowS
[ActionId] -> ShowS
ActionId -> String
(Int -> ActionId -> ShowS)
-> (ActionId -> String) -> ([ActionId] -> ShowS) -> Show ActionId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ActionId -> ShowS
showsPrec :: Int -> ActionId -> ShowS
$cshow :: ActionId -> String
show :: ActionId -> String
$cshowList :: [ActionId] -> ShowS
showList :: [ActionId] -> ShowS
Show)

-- | Type representing Stack build actions.

data Action = Action
  { Action -> ActionId
actionId :: !ActionId
    -- ^ The action's unique id.

  , Action -> Set ActionId
actionDeps :: !(Set ActionId)
    -- ^ Actions on which this action depends.

  , Action -> ActionContext -> IO ()
actionDo :: !(ActionContext -> IO ())
    -- ^ The action's 'IO' action, given a context.

  , Action -> Concurrency
actionConcurrency :: !Concurrency
    -- ^ Whether this action may be run concurrently with others.

  }

-- | Type representing permissions for actions to be run concurrently with

-- others.

data Concurrency
  = ConcurrencyAllowed
  | ConcurrencyDisallowed
  deriving Concurrency -> Concurrency -> Bool
(Concurrency -> Concurrency -> Bool)
-> (Concurrency -> Concurrency -> Bool) -> Eq Concurrency
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Concurrency -> Concurrency -> Bool
== :: Concurrency -> Concurrency -> Bool
$c/= :: Concurrency -> Concurrency -> Bool
/= :: Concurrency -> Concurrency -> Bool
Eq

data ActionContext = ActionContext
  { ActionContext -> Set ActionId
acRemaining :: !(Set ActionId)
    -- ^ Does not include the current action.

  , ActionContext -> [Action]
acDownstream :: [Action]
    -- ^ Actions which depend on the current action.

  , ActionContext -> Concurrency
acConcurrency :: !Concurrency
    -- ^ Whether this action may be run concurrently with others.

  }

data ExecuteState = ExecuteState
  { ExecuteState -> TVar [Action]
esActions    :: TVar [Action]
  , ExecuteState -> TVar [SomeException]
esExceptions :: TVar [SomeException]
  , ExecuteState -> TVar (Set ActionId)
esInAction   :: TVar (Set ActionId)
  , ExecuteState -> TVar Int
esCompleted  :: TVar Int
  , ExecuteState -> Bool
esKeepGoing  :: Bool
  }

runActions :: 
     Int -- ^ threads

  -> Bool -- ^ keep going after one task has failed

  -> [Action]
  -> (TVar Int -> TVar (Set ActionId) -> IO ()) -- ^ progress updated

  -> IO [SomeException]
runActions :: Int
-> Bool
-> [Action]
-> (TVar Int -> TVar (Set ActionId) -> IO ())
-> IO [SomeException]
runActions Int
threads Bool
keepGoing [Action]
actions TVar Int -> TVar (Set ActionId) -> IO ()
withProgress = do
  ExecuteState
es <- TVar [Action]
-> TVar [SomeException]
-> TVar (Set ActionId)
-> TVar Int
-> Bool
-> ExecuteState
ExecuteState
    (TVar [Action]
 -> TVar [SomeException]
 -> TVar (Set ActionId)
 -> TVar Int
 -> Bool
 -> ExecuteState)
-> IO (TVar [Action])
-> IO
     (TVar [SomeException]
      -> TVar (Set ActionId) -> TVar Int -> Bool -> ExecuteState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Action] -> IO (TVar [Action])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO ([Action] -> [Action]
sortActions [Action]
actions) -- esActions

    IO
  (TVar [SomeException]
   -> TVar (Set ActionId) -> TVar Int -> Bool -> ExecuteState)
-> IO (TVar [SomeException])
-> IO (TVar (Set ActionId) -> TVar Int -> Bool -> ExecuteState)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [SomeException] -> IO (TVar [SomeException])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO [] -- esExceptions

    IO (TVar (Set ActionId) -> TVar Int -> Bool -> ExecuteState)
-> IO (TVar (Set ActionId))
-> IO (TVar Int -> Bool -> ExecuteState)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set ActionId -> IO (TVar (Set ActionId))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Set ActionId
forall a. Set a
Set.empty -- esInAction

    IO (TVar Int -> Bool -> ExecuteState)
-> IO (TVar Int) -> IO (Bool -> ExecuteState)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (TVar Int)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Int
0 -- esCompleted

    IO (Bool -> ExecuteState) -> IO Bool -> IO ExecuteState
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
keepGoing -- esKeepGoing

  Async ()
_ <- IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ TVar Int -> TVar (Set ActionId) -> IO ()
withProgress (ExecuteState -> TVar Int
esCompleted ExecuteState
es) (ExecuteState -> TVar (Set ActionId)
esInAction ExecuteState
es)
  if Int
threads Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
    then ExecuteState -> IO ()
runActions' ExecuteState
es
    else Int -> IO () -> IO ()
forall (m :: * -> *) a.
(Applicative m, MonadUnliftIO m) =>
Int -> m a -> m ()
replicateConcurrently_ Int
threads (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExecuteState -> IO ()
runActions' ExecuteState
es
  TVar [SomeException] -> IO [SomeException]
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar [SomeException] -> IO [SomeException])
-> TVar [SomeException] -> IO [SomeException]
forall a b. (a -> b) -> a -> b
$ ExecuteState -> TVar [SomeException]
esExceptions ExecuteState
es

-- | Sort actions such that those that can't be run concurrently are at

-- the end.

sortActions :: [Action] -> [Action]
sortActions :: [Action] -> [Action]
sortActions = (Action -> Action -> Ordering) -> [Action] -> [Action]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Concurrency -> Concurrency -> Ordering
compareConcurrency (Concurrency -> Concurrency -> Ordering)
-> (Action -> Concurrency) -> Action -> Action -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Action -> Concurrency
actionConcurrency)
 where
  -- NOTE: Could derive Ord. However, I like to make this explicit so

  -- that changes to the datatype must consider how it's affecting

  -- this.

  compareConcurrency :: Concurrency -> Concurrency -> Ordering
compareConcurrency Concurrency
ConcurrencyAllowed Concurrency
ConcurrencyDisallowed = Ordering
LT
  compareConcurrency Concurrency
ConcurrencyDisallowed Concurrency
ConcurrencyAllowed = Ordering
GT
  compareConcurrency Concurrency
_ Concurrency
_ = Ordering
EQ

runActions' :: ExecuteState -> IO ()
runActions' :: ExecuteState -> IO ()
runActions' ExecuteState {Bool
TVar Int
TVar [SomeException]
TVar [Action]
TVar (Set ActionId)
esActions :: ExecuteState -> TVar [Action]
esExceptions :: ExecuteState -> TVar [SomeException]
esInAction :: ExecuteState -> TVar (Set ActionId)
esCompleted :: ExecuteState -> TVar Int
esKeepGoing :: ExecuteState -> Bool
esActions :: TVar [Action]
esExceptions :: TVar [SomeException]
esInAction :: TVar (Set ActionId)
esCompleted :: TVar Int
esKeepGoing :: Bool
..} = IO ()
loop
 where
  loop :: IO ()
  loop :: IO ()
loop = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> STM (IO ())
breakOnErrs (STM (IO ()) -> STM (IO ())) -> STM (IO ()) -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ ([Action] -> STM (IO ())) -> STM (IO ())
withActions [Action] -> STM (IO ())
processActions

  breakOnErrs :: STM (IO ()) -> STM (IO ())
  breakOnErrs :: STM (IO ()) -> STM (IO ())
breakOnErrs STM (IO ())
inner = do
    [SomeException]
errs <- TVar [SomeException] -> STM [SomeException]
forall a. TVar a -> STM a
readTVar TVar [SomeException]
esExceptions
    if [SomeException] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SomeException]
errs Bool -> Bool -> Bool
|| Bool
esKeepGoing
      then STM (IO ())
inner
      else STM (IO ())
doNothing

  withActions :: ([Action] -> STM (IO ())) -> STM (IO ())
  withActions :: ([Action] -> STM (IO ())) -> STM (IO ())
withActions [Action] -> STM (IO ())
inner = do
    [Action]
actions <- TVar [Action] -> STM [Action]
forall a. TVar a -> STM a
readTVar TVar [Action]
esActions
    if [Action] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Action]
actions
      then STM (IO ())
doNothing
      else [Action] -> STM (IO ())
inner [Action]
actions

  processActions :: [Action] -> STM (IO ())
  processActions :: [Action] -> STM (IO ())
processActions [Action]
actions = do
    Set ActionId
inAction <- TVar (Set ActionId) -> STM (Set ActionId)
forall a. TVar a -> STM a
readTVar TVar (Set ActionId)
esInAction
    case (Action -> Bool) -> [Action] -> ([Action], [Action])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Set ActionId -> Bool
forall a. Set a -> Bool
Set.null (Set ActionId -> Bool)
-> (Action -> Set ActionId) -> Action -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action -> Set ActionId
actionDeps) [Action]
actions of
      ([Action]
_, []) -> do
        Bool -> STM ()
check (Set ActionId -> Bool
forall a. Set a -> Bool
Set.null Set ActionId
inAction)
        Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
esKeepGoing (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
          TVar [SomeException]
-> ([SomeException] -> [SomeException]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [SomeException]
esExceptions (ExecuteException -> SomeException
forall e. Exception e => e -> SomeException
toException ExecuteException
InconsistentDependenciesBug:)
        STM (IO ())
doNothing
      ([Action]
xs, Action
action:[Action]
ys) -> Set ActionId -> [Action] -> Action -> STM (IO ())
processAction Set ActionId
inAction ([Action]
xs [Action] -> [Action] -> [Action]
forall a. [a] -> [a] -> [a]
++ [Action]
ys) Action
action

  processAction :: Set ActionId -> [Action] -> Action -> STM (IO ())
  processAction :: Set ActionId -> [Action] -> Action -> STM (IO ())
processAction Set ActionId
inAction [Action]
otherActions Action
action = do
    let concurrency :: Concurrency
concurrency = Action -> Concurrency
actionConcurrency Action
action
    Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Concurrency
concurrency Concurrency -> Concurrency -> Bool
forall a. Eq a => a -> a -> Bool
== Concurrency
ConcurrencyAllowed) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
      Bool -> STM ()
check (Set ActionId -> Bool
forall a. Set a -> Bool
Set.null Set ActionId
inAction)
    let action' :: ActionId
action' = Action -> ActionId
actionId Action
action
        otherActions' :: Set ActionId
otherActions' = [ActionId] -> Set ActionId
forall a. Ord a => [a] -> Set a
Set.fromList ([ActionId] -> Set ActionId) -> [ActionId] -> Set ActionId
forall a b. (a -> b) -> a -> b
$ (Action -> ActionId) -> [Action] -> [ActionId]
forall a b. (a -> b) -> [a] -> [b]
map Action -> ActionId
actionId [Action]
otherActions
        remaining :: Set ActionId
remaining = Set ActionId -> Set ActionId -> Set ActionId
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set ActionId
otherActions' Set ActionId
inAction
        actionContext :: ActionContext
actionContext = ActionContext
          { acRemaining :: Set ActionId
acRemaining = Set ActionId
remaining
          , acDownstream :: [Action]
acDownstream = ActionId -> [Action] -> [Action]
downstreamActions ActionId
action' [Action]
otherActions
          , acConcurrency :: Concurrency
acConcurrency = Concurrency
concurrency
          }
    TVar [Action] -> [Action] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [Action]
esActions [Action]
otherActions
    TVar (Set ActionId) -> (Set ActionId -> Set ActionId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set ActionId)
esInAction (ActionId -> Set ActionId -> Set ActionId
forall a. Ord a => a -> Set a -> Set a
Set.insert ActionId
action')
    IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ do
      ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
        Either SomeException ()
eres <- IO () -> IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Action -> ActionContext -> IO ()
actionDo Action
action ActionContext
actionContext
        STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          TVar (Set ActionId) -> (Set ActionId -> Set ActionId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set ActionId)
esInAction (ActionId -> Set ActionId -> Set ActionId
forall a. Ord a => a -> Set a -> Set a
Set.delete ActionId
action')
          TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar Int
esCompleted (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
          case Either SomeException ()
eres of
            Left SomeException
err -> TVar [SomeException]
-> ([SomeException] -> [SomeException]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [SomeException]
esExceptions (SomeException
err:)
            Right () -> TVar [Action] -> ([Action] -> [Action]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [Action]
esActions (([Action] -> [Action]) -> STM ())
-> ([Action] -> [Action]) -> STM ()
forall a b. (a -> b) -> a -> b
$ (Action -> Action) -> [Action] -> [Action]
forall a b. (a -> b) -> [a] -> [b]
map (ActionId -> Action -> Action
dropDep ActionId
action')
      IO ()
loop

  -- | Filter a list of actions to include only those that depend on the given

  -- action.

  downstreamActions :: ActionId -> [Action] -> [Action]
  downstreamActions :: ActionId -> [Action] -> [Action]
downstreamActions ActionId
aid = (Action -> Bool) -> [Action] -> [Action]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Action
a -> ActionId
aid ActionId -> Set ActionId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Action -> Set ActionId
actionDeps Action
a)
  
  -- | Given two actions (the first specified by its id) yield an action

  -- equivalent to the second but excluding any dependency on the first action.

  dropDep :: ActionId -> Action -> Action
  dropDep :: ActionId -> Action -> Action
dropDep ActionId
action' Action
action =
    Action
action { actionDeps :: Set ActionId
actionDeps = ActionId -> Set ActionId -> Set ActionId
forall a. Ord a => a -> Set a -> Set a
Set.delete ActionId
action' (Set ActionId -> Set ActionId) -> Set ActionId -> Set ActionId
forall a b. (a -> b) -> a -> b
$ Action -> Set ActionId
actionDeps Action
action }
  
  -- | @IO ()@ lifted into 'STM'.

  doNothing :: STM (IO ())
  doNothing :: STM (IO ())
doNothing = IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()