{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RecordWildCards #-}
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
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
| ATBuildFinal
| ATRunTests
| ATRunBenchmarks
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)
, ActionContext -> [Action]
acDownstream :: [Action]
, ActionContext -> Concurrency
acConcurrency :: !Concurrency
}
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
-> Bool
-> [Action]
-> (TVar Int -> TVar (Set ActionId) -> IO ())
-> 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
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
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)