From 79873a7f1a93380874f16133aad7c4233937a19b Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Thu, 26 Oct 2023 21:27:09 +0100 Subject: [PATCH] Make taskAnyMissing a function, not field Also reorders test as `(taskAnyMissingHackEnabled && taskAnyMissing task)` Also passes `TaskType` rather than `Task`, to avoid use of `TaskType` values with dummy fields. Also improves related Haddock documentation and code comments. --- src/Stack/Build/ConstructPlan.hs | 2 -- src/Stack/Build/Execute.hs | 55 ++++++++++++++++++++------------ src/Stack/SDist.hs | 22 ++----------- src/Stack/Types/Build.hs | 45 +++++++++++++++----------- 4 files changed, 64 insertions(+), 60 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 35ea144018..0556e91049 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -642,7 +642,6 @@ addFinal lp package isAllInOne buildHaddocks = do , taskType = TTLocalMutable lp , taskAllInOne = isAllInOne , taskCachePkgSrc = CacheSrcLocal (toFilePath (parent (lpCabalFile lp))) - , taskAnyMissing = not $ Set.null missing , taskBuildTypeConfig = packageBuildTypeConfig package } tell mempty { wFinals = Map.singleton (packageName package) res } @@ -961,7 +960,6 @@ installPackageGivenDeps isAllInOne buildHaddocks ps package minstalled TTRemotePackage mutable package pkgLoc , taskAllInOne = isAllInOne , taskCachePkgSrc = toCachePkgSrc ps - , taskAnyMissing = not $ Set.null missing , taskBuildTypeConfig = packageBuildTypeConfig package } diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 8a05f07fd9..5f562e1c43 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -131,8 +131,9 @@ import Stack.Types.ApplyGhcOptions ( ApplyGhcOptions (..) ) import Stack.Types.Build ( ConfigCache (..), Plan (..), PrecompiledCache (..) , Task (..), TaskConfigOpts (..), TaskType (..) - , configCacheComponents, taskIsTarget, taskLocation - , taskProvides + , configCacheComponents, taskAnyMissing, taskIsTarget + , taskLocation, taskProvides, taskTypeLocation + , taskTypePackageIdentifier ) import Stack.Types.Build.Exception ( BuildException (..), BuildPrettyException (..) ) @@ -1108,12 +1109,20 @@ ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task = (getFileStatus (toFilePath setupConfigfp)) newSetupConfigMod <- getNewSetupConfigMod newProjectRoot <- S8.pack . toFilePath <$> view projectRootL - -- See https://github.com/commercialhaskell/stack/issues/3554 - taskAnyMissingHack <- + -- See https://github.com/commercialhaskell/stack/issues/3554. This can be + -- dropped when Stack drops support for GHC < 8.4. + taskAnyMissingHackEnabled <- view $ actualCompilerVersionL.to getGhcVersion.to (< mkVersion [8, 4]) needConfig <- if boptsReconfigure eeBuildOpts - || (taskAnyMissing task && taskAnyMissingHack) + -- The reason 'taskAnyMissing' is necessary is a bug in Cabal. See: + -- . + -- The problem is that Cabal may end up generating the same package ID + -- for a dependency, even if the ABI has changed. As a result, without + -- check, Stack would think that a reconfigure is unnecessary, when in + -- fact we _do_ need to reconfigure. The details here suck. We really + -- need proper hashes for package identifiers. + || (taskAnyMissingHackEnabled && taskAnyMissing task) then pure True else do -- We can ignore the components portion of the config @@ -1198,20 +1207,24 @@ packageNamePrefix ee name' = announceTask :: HasLogFunc env => ExecuteEnv - -> Task + -> TaskType -> Utf8Builder -> RIO env () -announceTask ee task action = logInfo $ - fromString (packageNamePrefix ee (pkgName (taskProvides task))) <> action +announceTask ee taskType action = logInfo $ + fromString + (packageNamePrefix ee (pkgName (taskTypePackageIdentifier taskType))) + <> action prettyAnnounceTask :: HasTerm env => ExecuteEnv - -> Task + -> TaskType -> StyleDoc -> RIO env () -prettyAnnounceTask ee task action = prettyInfo $ - fromString (packageNamePrefix ee (pkgName (taskProvides task))) <> action +prettyAnnounceTask ee taskType action = prettyInfo $ + fromString + (packageNamePrefix ee (pkgName (taskTypePackageIdentifier taskType))) + <> action -- | Ensure we're the only action using the directory. See -- @@ -1275,7 +1288,7 @@ withSingleContext :: forall env a. HasEnvConfig env => ActionContext -> ExecuteEnv - -> Task + -> TaskType -> Map PackageIdentifier GhcPkgId -- ^ All dependencies' package ids to provide to Setup.hs. -> Maybe String @@ -1295,7 +1308,7 @@ withSingleContext :: withSingleContext ActionContext {..} ee@ExecuteEnv {..} - task@Task {..} + taskType allDeps msuffix inner0 @@ -1304,9 +1317,9 @@ withSingleContext withCabal package pkgDir outputType $ \cabal -> inner0 package cabalfp pkgDir cabal announce outputType where - pkgId = taskProvides task - announce = announceTask ee task - prettyAnnounce = prettyAnnounceTask ee task + pkgId = taskTypePackageIdentifier taskType + announce = announceTask ee taskType + prettyAnnounce = prettyAnnounceTask ee taskType wanted = case taskType of @@ -1397,7 +1410,7 @@ withSingleContext unless (configAllowDifferentUser config) $ checkOwnership (pkgDir configWorkDir config) let envSettings = EnvSettings - { esIncludeLocals = taskLocation task == Local + { esIncludeLocals = taskTypeLocation taskType == Local , esIncludeGhcPackagePath = False , esStackExe = False , esLocaleUtf8 = True @@ -1777,7 +1790,7 @@ singleBuild _ -> pure Nothing copyPreCompiled (PrecompiledCache mlib sublibs exes) = do - announceTask ee task "using precompiled package" + announceTask ee taskType "using precompiled package" -- We need to copy .conf files for the main library and all sublibraries -- which exist in the cache, from their old snapshot to the new one. @@ -1841,7 +1854,7 @@ singleBuild bindir = bcoSnapInstallRoot eeBaseConfigOpts bindirSuffix realConfigAndBuild cache mcurator allDepsMap = - withSingleContext ac ee task allDepsMap Nothing $ + withSingleContext ac ee taskType allDepsMap Nothing $ \package cabalfp pkgDir cabal0 announce _outputType -> do let cabal = cabal0 CloseOnException executableBuildStatuses <- getExecutableBuildStatuses package pkgDir @@ -2228,7 +2241,7 @@ singleTest topts testsToRun ac ee task installedMap = do mcurator <- view $ buildConfigL.to bcCurator let pname = pkgName $ taskProvides task expectFailure = expectTestFailure pname mcurator - withSingleContext ac ee task allDepsMap (Just "test") $ + withSingleContext ac ee (taskType task) allDepsMap (Just "test") $ \package _cabalfp pkgDir _cabal announce outputType -> do config <- view configL let needHpc = toCoverage topts @@ -2507,7 +2520,7 @@ singleBench :: HasEnvConfig env -> RIO env () singleBench beopts benchesToRun ac ee task installedMap = do (allDepsMap, _cache) <- getConfigCache ee task installedMap False True - withSingleContext ac ee task allDepsMap (Just "bench") $ + withSingleContext ac ee (taskType task) allDepsMap (Just "bench") $ \_package _cabalfp _pkgDir cabal announce _outputType -> do let args = map T.unpack benchesToRun <> maybe [] ((:[]) . ("--benchmark-options=" <>)) diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 4da347bdbc..e9b4661307 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -63,16 +63,12 @@ import Stack.Prelude import Stack.Runners ( ShouldReexec (..), withConfig, withDefaultEnvConfig ) import Stack.SourceMap ( mkProjectPackage ) -import Stack.Types.Build - ( CachePkgSrc (..), Task (..), TaskConfigOpts (..) - , TaskType (..) - ) +import Stack.Types.Build ( TaskType (..) ) import Stack.Types.BuildConfig ( BuildConfig (..), HasBuildConfig (..), stackYamlL ) import Stack.Types.BuildOpts ( BuildOpts (..), defaultBuildOpts, defaultBuildOptsCLI ) import Stack.Types.Config ( Config (..), HasConfig (..) ) -import Stack.Types.ConfigureOpts ( ConfigureOpts (..) ) import Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL ) import Stack.Types.GhcPkgId ( GhcPkgId ) @@ -493,7 +489,7 @@ getSDistFileList lp deps = [] [] [] Nothing -- provide empty list of globals. This is a hack around -- custom Setup.hs files $ \ee -> - withSingleContext ac ee task deps (Just "sdist") $ + withSingleContext ac ee taskType deps (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _outputType -> do let outFile = toFilePath tmpdir FP. "source-files-list" cabal @@ -504,19 +500,7 @@ getSDistFileList lp deps = pure (T.unpack $ T.decodeUtf8With T.lenientDecode contents, cabalfp) where ac = ActionContext Set.empty [] ConcurrencyAllowed - task = Task - { taskType = TTLocalMutable lp - , taskConfigOpts = TaskConfigOpts - { tcoMissing = Set.empty - , tcoOpts = \_ -> ConfigureOpts [] [] - } - , taskBuildHaddock = False - , taskPresent = Map.empty - , taskAllInOne = True - , taskCachePkgSrc = CacheSrcLocal (toFilePath (parent $ lpCabalFile lp)) - , taskAnyMissing = True - , taskBuildTypeConfig = False - } + taskType = TTLocalMutable lp normalizeTarballPaths :: (HasRunner env, HasTerm env) diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 299efbcff3..0d8032b081 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -9,10 +9,13 @@ module Stack.Types.Build , Installed (..) , psVersion , Task (..) + , taskAnyMissing , taskIsTarget , taskLocation , taskProvides , taskTargetIsMutable + , taskTypeLocation + , taskTypePackageIdentifier , LocalPackage (..) , Plan (..) , TestOpts (..) @@ -43,6 +46,7 @@ import Database.Persist.Sql , PersistValue (PersistText), SqlType (SqlString) ) import Path ( parent ) +import qualified RIO.Set as Set import Stack.Prelude import Stack.Types.BuildOpts ( BenchmarkOpts (..), BuildOpts (..), BuildSubset (..) @@ -121,26 +125,21 @@ toCachePkgSrc (PSFilePath lp) = CacheSrcLocal (toFilePath (parent (lpCabalFile lp))) toCachePkgSrc PSRemote{} = CacheSrcUpstream --- | A task to perform when building +-- | A type representing tasks to perform when building. data Task = Task { taskType :: !TaskType - -- ^ the task type, telling us how to build this + -- ^ The task type, telling us how to build this , taskConfigOpts :: !TaskConfigOpts + -- ^ A set of the package identifiers of dependencies for which 'GhcPkgId' + -- are missing and a function which yields configure options, given a + -- dictionary of those identifiers and their 'GhcPkgId'. , taskBuildHaddock :: !Bool , taskPresent :: !(Map PackageIdentifier GhcPkgId) - -- ^ GhcPkgIds of already-installed dependencies + -- ^ A dictionary of the package identifiers of already-installed + -- dependencies, and their 'GhcPkgId'. , taskAllInOne :: !Bool -- ^ indicates that the package can be built in one step , taskCachePkgSrc :: !CachePkgSrc - , taskAnyMissing :: !Bool - -- ^ Were any of the dependencies missing? The reason this is necessary is... - -- hairy. And as you may expect, a bug in Cabal. See: - -- . - -- The problem is that Cabal may end up generating the same package ID for a - -- dependency, even if the ABI has changed. As a result, without this field, - -- Stack would think that a reconfigure is unnecessary, when in fact we _do_ - -- need to reconfigure. The details here suck. We really need proper hashes - -- for package identifiers. , taskBuildTypeConfig :: !Bool -- ^ Is the build type of this package Configure. Check out -- ensureConfigureScript in Stack.Build.Execute for the motivation @@ -172,6 +171,11 @@ data TaskType -- ^ Building something from the package index (upstream). deriving Show +-- | Were any of the dependencies missing? + +taskAnyMissing :: Task -> Bool +taskAnyMissing task = not $ Set.null $ tcoMissing $ taskConfigOpts task + -- | A function to yield the package name and version of a given 'TaskType' -- value. taskTypePackageIdentifier :: TaskType -> PackageIdentifier @@ -184,14 +188,19 @@ taskIsTarget t = TTLocalMutable lp -> lpWanted lp _ -> False +-- | A function to yield the relevant database (write-only or mutable) of a +-- given 'TaskType' value. +taskTypeLocation :: TaskType -> InstallLocation +taskTypeLocation (TTLocalMutable _) = Local +taskTypeLocation (TTRemotePackage Mutable _ _) = Local +taskTypeLocation (TTRemotePackage Immutable _ _) = Snap + +-- | A function to yield the relevant database (write-only or mutable) of the +-- given task. taskLocation :: Task -> InstallLocation -taskLocation task = - case taskType task of - TTLocalMutable _ -> Local - TTRemotePackage Mutable _ _ -> Local - TTRemotePackage Immutable _ _ -> Snap +taskLocation = taskTypeLocation . taskType --- | A funtion to yield the package name and version to be built by the given +-- | A function to yield the package name and version to be built by the given -- task. taskProvides :: Task -> PackageIdentifier taskProvides = taskTypePackageIdentifier . taskType