{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# 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   (retry)
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExecuteException] -> ShowS
$cshowList :: [ExecuteException] -> ShowS
show :: ExecuteException -> String
$cshow :: ExecuteException -> String
showsPrec :: Int -> ExecuteException -> ShowS
$cshowsPrec :: Int -> 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."

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 then 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ActionType] -> ShowS
$cshowList :: [ActionType] -> ShowS
show :: ActionType -> String
$cshow :: ActionType -> String
showsPrec :: Int -> ActionType -> ShowS
$cshowsPrec :: Int -> ActionType -> ShowS
Show, ActionType -> ActionType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ActionType -> ActionType -> Bool
$c/= :: ActionType -> ActionType -> Bool
== :: ActionType -> ActionType -> Bool
$c== :: ActionType -> ActionType -> Bool
Eq, Eq 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
min :: ActionType -> ActionType -> ActionType
$cmin :: ActionType -> ActionType -> ActionType
max :: ActionType -> ActionType -> ActionType
$cmax :: ActionType -> ActionType -> ActionType
>= :: ActionType -> ActionType -> Bool
$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
compare :: ActionType -> ActionType -> Ordering
$ccompare :: ActionType -> ActionType -> Ordering
Ord)
data ActionId = ActionId !PackageIdentifier !ActionType
    deriving (Int -> ActionId -> ShowS
[ActionId] -> ShowS
ActionId -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ActionId] -> ShowS
$cshowList :: [ActionId] -> ShowS
show :: ActionId -> String
$cshow :: ActionId -> String
showsPrec :: Int -> ActionId -> ShowS
$cshowsPrec :: Int -> ActionId -> ShowS
Show, ActionId -> ActionId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ActionId -> ActionId -> Bool
$c/= :: ActionId -> ActionId -> Bool
== :: ActionId -> ActionId -> Bool
$c== :: ActionId -> ActionId -> Bool
Eq, Eq 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
min :: ActionId -> ActionId -> ActionId
$cmin :: ActionId -> ActionId -> ActionId
max :: ActionId -> ActionId -> ActionId
$cmax :: ActionId -> ActionId -> ActionId
>= :: ActionId -> ActionId -> Bool
$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
compare :: ActionId -> ActionId -> Ordering
$ccompare :: ActionId -> ActionId -> Ordering
Ord)
data Action = Action
    { Action -> ActionId
actionId :: !ActionId
    , Action -> Set ActionId
actionDeps :: !(Set ActionId)
    , Action -> ActionContext -> IO ()
actionDo :: !(ActionContext -> IO ())
    , Action -> Concurrency
actionConcurrency :: !Concurrency
    }

data Concurrency = ConcurrencyAllowed | ConcurrencyDisallowed
    deriving (Concurrency -> Concurrency -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Concurrency -> Concurrency -> Bool
$c/= :: Concurrency -> Concurrency -> Bool
== :: Concurrency -> Concurrency -> Bool
$c== :: 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]
actions0 TVar Int -> TVar (Set ActionId) -> IO ()
withProgress = do
    ExecuteState
es <- TVar [Action]
-> TVar [SomeException]
-> TVar (Set ActionId)
-> TVar Int
-> Bool
-> ExecuteState
ExecuteState
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO ([Action] -> [Action]
sortActions [Action]
actions0)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO []
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO forall a. Set a
Set.empty
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Int
0
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
keepGoing
    Async ()
_ <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
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 forall a. Ord a => a -> a -> Bool
<= Int
1
        then ExecuteState -> IO ()
runActions' ExecuteState
es
        else forall (m :: * -> *) a.
(Applicative m, MonadUnliftIO m) =>
Int -> m a -> m ()
replicateConcurrently_ Int
threads forall a b. (a -> b) -> a -> b
$ ExecuteState -> IO ()
runActions' ExecuteState
es
    forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO 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 = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Concurrency -> Concurrency -> Ordering
compareConcurrency 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)
esKeepGoing :: Bool
esCompleted :: TVar Int
esInAction :: TVar (Set ActionId)
esExceptions :: TVar [SomeException]
esActions :: TVar [Action]
esKeepGoing :: ExecuteState -> Bool
esCompleted :: ExecuteState -> TVar Int
esInAction :: ExecuteState -> TVar (Set ActionId)
esExceptions :: ExecuteState -> TVar [SomeException]
esActions :: ExecuteState -> TVar [Action]
..} =
    IO ()
loop
  where
    breakOnErrs :: STM (f ()) -> STM (f ())
breakOnErrs STM (f ())
inner = do
        [SomeException]
errs <- forall a. TVar a -> STM a
readTVar TVar [SomeException]
esExceptions
        if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SomeException]
errs Bool -> Bool -> Bool
|| Bool
esKeepGoing
            then STM (f ())
inner
            else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    withActions :: ([Action] -> STM (f ())) -> STM (f ())
withActions [Action] -> STM (f ())
inner = do
        [Action]
as <- forall a. TVar a -> STM a
readTVar TVar [Action]
esActions
        if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Action]
as
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            else [Action] -> STM (f ())
inner [Action]
as
    loop :: IO ()
loop = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall {f :: * -> *}. Applicative f => STM (f ()) -> STM (f ())
breakOnErrs forall a b. (a -> b) -> a -> b
$ forall {f :: * -> *}.
Applicative f =>
([Action] -> STM (f ())) -> STM (f ())
withActions forall a b. (a -> b) -> a -> b
$ \[Action]
as ->
        case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Set a -> Bool
Set.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action -> Set ActionId
actionDeps) [Action]
as of
            ([Action]
_, []) -> do
                Set ActionId
inAction <- forall a. TVar a -> STM a
readTVar TVar (Set ActionId)
esInAction
                if forall a. Set a -> Bool
Set.null Set ActionId
inAction
                    then do
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
esKeepGoing forall a b. (a -> b) -> a -> b
$
                            forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [SomeException]
esExceptions
                                (forall e. Exception e => e -> SomeException
toException ExecuteException
InconsistentDependenciesBugforall a. a -> [a] -> [a]
:)
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    else forall a. STM a
retry
            ([Action]
xs, Action
action:[Action]
ys) -> do
                Set ActionId
inAction <- forall a. TVar a -> STM a
readTVar TVar (Set ActionId)
esInAction
                case Action -> Concurrency
actionConcurrency Action
action of
                  Concurrency
ConcurrencyAllowed -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                  Concurrency
ConcurrencyDisallowed -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Set a -> Bool
Set.null Set ActionId
inAction) forall a. STM a
retry
                let as' :: [Action]
as' = [Action]
xs forall a. [a] -> [a] -> [a]
++ [Action]
ys
                    remaining :: Set ActionId
remaining = forall a. Ord a => Set a -> Set a -> Set a
Set.union
                        (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Action -> ActionId
actionId [Action]
as')
                        Set ActionId
inAction
                forall a. TVar a -> a -> STM ()
writeTVar TVar [Action]
esActions [Action]
as'
                forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set ActionId)
esInAction (forall a. Ord a => a -> Set a -> Set a
Set.insert forall a b. (a -> b) -> a -> b
$ Action -> ActionId
actionId Action
action)
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
                    Either SomeException ()
eres <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ Action -> ActionContext -> IO ()
actionDo Action
action ActionContext
                        { acRemaining :: Set ActionId
acRemaining = Set ActionId
remaining
                        , acDownstream :: [Action]
acDownstream = ActionId -> [Action] -> [Action]
downstreamActions (Action -> ActionId
actionId Action
action) [Action]
as'
                        , acConcurrency :: Concurrency
acConcurrency = Action -> Concurrency
actionConcurrency Action
action
                        }
                    forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
                        forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set ActionId)
esInAction (forall a. Ord a => a -> Set a -> Set a
Set.delete forall a b. (a -> b) -> a -> b
$ Action -> ActionId
actionId Action
action)
                        forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar Int
esCompleted (forall a. Num a => a -> a -> a
+Int
1)
                        case Either SomeException ()
eres of
                            Left SomeException
err -> forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [SomeException]
esExceptions (SomeException
errforall a. a -> [a] -> [a]
:)
                            Right () ->
                                let dropDep :: Action -> Action
dropDep Action
a = Action
a { actionDeps :: Set ActionId
actionDeps = forall a. Ord a => a -> Set a -> Set a
Set.delete (Action -> ActionId
actionId Action
action) forall a b. (a -> b) -> a -> b
$ Action -> Set ActionId
actionDeps Action
a }
                                 in forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [Action]
esActions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Action -> Action
dropDep
                    forall a. IO a -> IO a
restore IO ()
loop

downstreamActions :: ActionId -> [Action] -> [Action]
downstreamActions :: ActionId -> [Action] -> [Action]
downstreamActions ActionId
aid = forall a. (a -> Bool) -> [a] -> [a]
filter (\Action
a -> ActionId
aid forall a. Ord a => a -> Set a -> Bool
`Set.member` Action -> Set ActionId
actionDeps Action
a)