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.
commercialhaskell · Oct 26, 2023 · 79873a7 · 79873a7
1 parent f0b7fa0
commit 79873a7
Show file tree

Hide file tree

Showing 4 changed files with 64 additions and 60 deletions.
diff --git 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
@@ -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:
+          -- <https://github.com/haskell/cabal/issues/4728#issuecomment-337937673>.
+          -- 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
 -- <https://github.com/commercialhaskell/stack/issues/2730>
@@ -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
@@ -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
@@ -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:
-    -- <https://github.com/haskell/cabal/issues/4728#issuecomment-337937673>.
-    -- 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