Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Remove other prefixes from field names of types #6453

Merged
merged 1 commit into from
Jan 20, 2024
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
67 changes: 35 additions & 32 deletions src/Control/Concurrent/Execute.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,7 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE OverloadedRecordDot #-}

-- Concurrent execution with dependencies. Types currently hard-coded for needs
-- of stack, but could be generalized easily.
Expand Down Expand Up @@ -55,9 +57,9 @@ data Action = Action
-- ^ The action's unique id.
, actionDeps :: !(Set ActionId)
-- ^ Actions on which this action depends.
, actionDo :: !(ActionContext -> IO ())
, action :: !(ActionContext -> IO ())
-- ^ The action's 'IO' action, given a context.
, actionConcurrency :: !Concurrency
, concurrency :: !Concurrency
-- ^ Whether this action may be run concurrently with others.
}

Expand All @@ -69,20 +71,20 @@ data Concurrency
deriving Eq

data ActionContext = ActionContext
{ acRemaining :: !(Set ActionId)
{ remaining :: !(Set ActionId)
-- ^ Does not include the current action.
, acDownstream :: [Action]
, downstream :: [Action]
-- ^ Actions which depend on the current action.
, acConcurrency :: !Concurrency
, concurrency :: !Concurrency
-- ^ Whether this action may be run concurrently with others.
}

data ExecuteState = ExecuteState
{ esActions :: TVar [Action]
, esExceptions :: TVar [SomeException]
, esInAction :: TVar (Set ActionId)
, esCompleted :: TVar Int
, esKeepGoing :: Bool
{ actions :: TVar [Action]
, exceptions :: TVar [SomeException]
, inAction :: TVar (Set ActionId)
, completed :: TVar Int
, keepGoing :: Bool
}

runActions ::
Expand All @@ -98,16 +100,16 @@ runActions threads keepGoing actions withProgress = do
<*> newTVarIO Set.empty -- esInAction
<*> newTVarIO 0 -- esCompleted
<*> pure keepGoing -- esKeepGoing
_ <- async $ withProgress es.esCompleted es.esInAction
_ <- async $ withProgress es.completed es.inAction
if threads <= 1
then runActions' es
else replicateConcurrently_ threads $ runActions' es
readTVarIO es.esExceptions
readTVarIO es.exceptions

-- | Sort actions such that those that can't be run concurrently are at
-- the end.
sortActions :: [Action] -> [Action]
sortActions = sortBy (compareConcurrency `on` (.actionConcurrency))
sortActions = sortBy (compareConcurrency `on` (.concurrency))
where
-- NOTE: Could derive Ord. However, I like to make this explicit so
-- that changes to the datatype must consider how it's affecting
Expand All @@ -124,53 +126,54 @@ runActions' es = loop

breakOnErrs :: STM (IO ()) -> STM (IO ())
breakOnErrs inner = do
errs <- readTVar es.esExceptions
if null errs || es.esKeepGoing
errs <- readTVar es.exceptions
if null errs || es.keepGoing
then inner
else doNothing

withActions :: ([Action] -> STM (IO ())) -> STM (IO ())
withActions inner = do
actions <- readTVar es.esActions
actions <- readTVar es.actions
if null actions
then doNothing
else inner actions

processActions :: [Action] -> STM (IO ())
processActions actions = do
inAction <- readTVar es.esInAction
inAction <- readTVar es.inAction
case break (Set.null . (.actionDeps)) actions of
(_, []) -> do
check (Set.null inAction)
unless es.esKeepGoing $
modifyTVar es.esExceptions (toException InconsistentDependenciesBug:)
unless es.keepGoing $
modifyTVar es.exceptions (toException InconsistentDependenciesBug:)
doNothing
(xs, action:ys) -> processAction inAction (xs ++ ys) action

processAction :: Set ActionId -> [Action] -> Action -> STM (IO ())
processAction inAction otherActions action = do
let concurrency = action.actionConcurrency
let concurrency = action.concurrency
unless (concurrency == ConcurrencyAllowed) $
check (Set.null inAction)
let action' = action.actionId
otherActions' = Set.fromList $ map (.actionId) otherActions
remaining = Set.union otherActions' inAction
downstream = downstreamActions action' otherActions
actionContext = ActionContext
{ acRemaining = remaining
, acDownstream = downstreamActions action' otherActions
, acConcurrency = concurrency
{ remaining
, downstream
, concurrency
}
writeTVar es.esActions otherActions
modifyTVar es.esInAction (Set.insert action')
writeTVar es.actions otherActions
modifyTVar es.inAction (Set.insert action')
pure $ do
mask $ \restore -> do
eres <- try $ restore $ action.actionDo actionContext
eres <- try $ restore $ action.action actionContext
atomically $ do
modifyTVar es.esInAction (Set.delete action')
modifyTVar es.esCompleted (+1)
modifyTVar es.inAction (Set.delete action')
modifyTVar es.completed (+1)
case eres of
Left err -> modifyTVar es.esExceptions (err:)
Right () -> modifyTVar es.esActions $ map (dropDep action')
Left err -> modifyTVar es.exceptions (err:)
Right () -> modifyTVar es.actions $ map (dropDep action')
loop

-- | Filter a list of actions to include only those that depend on the given
Expand Down
45 changes: 23 additions & 22 deletions src/Options/Applicative/Builder/Extra.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE OverloadedRecordDot #-}

-- | Extra functions for optparse-applicative.
Expand Down Expand Up @@ -260,22 +261,22 @@ optionalFirstFalse = fmap FirstFalse . optional
absFileOption :: Mod OptionFields (Path Abs File) -> Parser (Path Abs File)
absFileOption mods = option (eitherReader' parseAbsFile) $
completer
(pathCompleterWith defaultPathCompleterOpts { pcoRelative = False })
(pathCompleterWith defaultPathCompleterOpts { relative = False })
<> mods

relFileOption :: Mod OptionFields (Path Rel File) -> Parser (Path Rel File)
relFileOption mods = option (eitherReader' parseRelFile) $
completer
(pathCompleterWith defaultPathCompleterOpts { pcoAbsolute = False })
(pathCompleterWith defaultPathCompleterOpts { absolute = False })
<> mods

absDirOption :: Mod OptionFields (Path Abs Dir) -> Parser (Path Abs Dir)
absDirOption mods = option (eitherReader' parseAbsDir) $
completer
( pathCompleterWith
defaultPathCompleterOpts
{ pcoRelative = False
, pcoFileFilter = const False
{ relative = False
, fileFilter = const False
}
)
<> mods
Expand All @@ -285,8 +286,8 @@ relDirOption mods = option (eitherReader' parseRelDir) $
completer
( pathCompleterWith
defaultPathCompleterOpts
{ pcoAbsolute = False
, pcoFileFilter = const False
{ absolute = False
, fileFilter = const False
}
)
<> mods
Expand All @@ -296,20 +297,20 @@ eitherReader' :: Show e => (String -> Either e a) -> ReadM a
eitherReader' f = eitherReader (mapLeft show . f)

data PathCompleterOpts = PathCompleterOpts
{ pcoAbsolute :: Bool
, pcoRelative :: Bool
, pcoRootDir :: Maybe FilePath
, pcoFileFilter :: FilePath -> Bool
, pcoDirFilter :: FilePath -> Bool
{ absolute :: Bool
, relative :: Bool
, rootDir :: Maybe FilePath
, fileFilter :: FilePath -> Bool
, dirFilter :: FilePath -> Bool
}

defaultPathCompleterOpts :: PathCompleterOpts
defaultPathCompleterOpts = PathCompleterOpts
{ pcoAbsolute = True
, pcoRelative = True
, pcoRootDir = Nothing
, pcoFileFilter = const True
, pcoDirFilter = const True
{ absolute = True
, relative = True
, rootDir = Nothing
, fileFilter = const True
, dirFilter = const True
}

fileCompleter :: Completer
Expand All @@ -318,11 +319,11 @@ fileCompleter = pathCompleterWith defaultPathCompleterOpts
fileExtCompleter :: [String] -> Completer
fileExtCompleter exts =
pathCompleterWith
defaultPathCompleterOpts { pcoFileFilter = (`elem` exts) . takeExtension }
defaultPathCompleterOpts { fileFilter = (`elem` exts) . takeExtension }

dirCompleter :: Completer
dirCompleter =
pathCompleterWith defaultPathCompleterOpts { pcoFileFilter = const False }
pathCompleterWith defaultPathCompleterOpts { fileFilter = const False }

pathCompleterWith :: PathCompleterOpts -> Completer
pathCompleterWith pco = mkCompleter $ \inputRaw -> do
Expand All @@ -333,15 +334,15 @@ pathCompleterWith pco = mkCompleter $ \inputRaw -> do
let (inputSearchDir0, searchPrefix) = splitFileName input
inputSearchDir = if inputSearchDir0 == "./" then "" else inputSearchDir0
msearchDir <-
case (isRelative inputSearchDir, pco.pcoAbsolute, pco.pcoRelative) of
case (isRelative inputSearchDir, pco.absolute, pco.relative) of
(True, _, True) -> do
rootDir <- maybe getCurrentDirectory pure pco.pcoRootDir
rootDir <- maybe getCurrentDirectory pure pco.rootDir
pure $ Just (rootDir </> inputSearchDir)
(False, True, _) -> pure $ Just inputSearchDir
_ -> pure Nothing
case msearchDir of
Nothing
| input == "" && pco.pcoAbsolute -> pure ["/"]
| input == "" && pco.absolute -> pure ["/"]
| otherwise -> pure []
Just searchDir -> do
entries <-
Expand All @@ -354,7 +355,7 @@ pathCompleterWith pco = mkCompleter $ \inputRaw -> do
if searchPrefix `isPrefixOf` entry
then do
let path = searchDir </> entry
case (pco.pcoFileFilter path, pco.pcoDirFilter path) of
case (pco.fileFilter path, pco.dirFilter path) of
(True, True) -> pure $ Just (inputSearchDir </> entry)
(fileAllowed, dirAllowed) -> do
isDir <- doesDirectoryExist path
Expand Down
16 changes: 8 additions & 8 deletions src/Stack/Build/Execute.hs
Original file line number Diff line number Diff line change
Expand Up @@ -522,9 +522,9 @@ toActions installedMap mtestLock runInBase ee (mbuild, mfinal) =
{ actionId = ActionId (taskProvides task) ATBuild
, actionDeps =
Set.map (`ActionId` ATBuild) task.configOpts.missing
, actionDo =
, action =
\ac -> runInBase $ singleBuild ac ee task installedMap False
, actionConcurrency = ConcurrencyAllowed
, concurrency = ConcurrencyAllowed
}
]
afinal = case mfinal of
Expand All @@ -536,9 +536,9 @@ toActions installedMap mtestLock runInBase ee (mbuild, mfinal) =
{ actionId = ActionId pkgId ATBuildFinal
, actionDeps = addBuild
(Set.map (`ActionId` ATBuild) task.configOpts.missing)
, actionDo =
, action =
\ac -> runInBase $ singleBuild ac ee task installedMap True
, actionConcurrency = ConcurrencyAllowed
, concurrency = ConcurrencyAllowed
}
) $
-- These are the "final" actions - running tests and benchmarks.
Expand All @@ -547,20 +547,20 @@ toActions installedMap mtestLock runInBase ee (mbuild, mfinal) =
else (:) Action
{ actionId = ActionId pkgId ATRunTests
, actionDeps = finalDeps
, actionDo = \ac -> withLock mtestLock $ runInBase $
, action = \ac -> withLock mtestLock $ runInBase $
singleTest topts (Set.toList tests) ac ee task installedMap
-- Always allow tests tasks to run concurrently with other tasks,
-- particularly build tasks. Note that 'mtestLock' can optionally
-- make it so that only one test is run at a time.
, actionConcurrency = ConcurrencyAllowed
, concurrency = ConcurrencyAllowed
}
) $
( if Set.null benches
then id
else (:) Action
{ actionId = ActionId pkgId ATRunBenchmarks
, actionDeps = finalDeps
, actionDo = \ac -> runInBase $
, action = \ac -> runInBase $
singleBench
beopts
(Set.toList benches)
Expand All @@ -570,7 +570,7 @@ toActions installedMap mtestLock runInBase ee (mbuild, mfinal) =
installedMap
-- Never run benchmarks concurrently with any other task, see
-- #3663
, actionConcurrency = ConcurrencyDisallowed
, concurrency = ConcurrencyDisallowed
}
)
[]
Expand Down
4 changes: 2 additions & 2 deletions src/Stack/Build/ExecuteEnv.hs
Original file line number Diff line number Diff line change
Expand Up @@ -602,10 +602,10 @@ withSingleContext
( wanted
&& all
(\(ActionId ident _) -> ident == pkgId)
(Set.toList ac.acRemaining)
(Set.toList ac.remaining)
&& ee.totalWanted == 1
)
|| ac.acConcurrency == ConcurrencyDisallowed
|| ac.concurrency == ConcurrencyDisallowed

withPackage inner =
case taskType of
Expand Down
6 changes: 3 additions & 3 deletions src/Stack/Build/ExecutePackage.hs
Original file line number Diff line number Diff line change
Expand Up @@ -456,8 +456,8 @@ singleBuild
-- because their configure step will require that this
-- package is built. See
-- https://github.com/commercialhaskell/stack/issues/2787
(True, _) | null ac.acDownstream -> pure Nothing
(_, True) | null ac.acDownstream || installedMapHasThisPkg -> do
(True, _) | null ac.downstream -> pure Nothing
(_, True) | null ac.downstream || installedMapHasThisPkg -> do
initialBuildSteps executableBuildStatuses cabal announce
pure Nothing
_ -> fulfillCuratorBuildExpectations
Expand Down Expand Up @@ -700,7 +700,7 @@ singleBuild
let remaining =
filter
(\(ActionId x _) -> x == pkgId)
(Set.toList ac.acRemaining)
(Set.toList ac.remaining)
when (null remaining) $ removeDirRecur pkgDir
TTLocalMutable{} -> pure ()

Expand Down
Loading
Loading