Merge pull request #6314 from commercialhaskell/fix6313

Fix #6313 Make `taskProvides` a function, not a field of `Task`

.stan.toml

@@ -52,7 +52,7 @@
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
-  id = "OBS-STAN-0203-fki0nd-1098:21"
+  id = "OBS-STAN-0203-fki0nd-1100:21"
 # ✦ Description:   Usage of 'pack' function that doesn't handle Unicode characters
 #  ✦ Category:      #AntiPattern
 #  ✦ File:          src\Stack\Build\Execute.hs
@@ -63,7 +63,7 @@
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
-  id = "OBS-STAN-0203-fki0nd-2626:3"
+  id = "OBS-STAN-0203-fki0nd-2631:3"
 # ✦ Description:   Usage of 'pack' function that doesn't handle Unicode characters
 # ✦ Category:      #AntiPattern
 # ✦ File:          src\Stack\Build\Execute.hs

src/Stack/Build.hs

@@ -35,7 +35,9 @@ import           Stack.Prelude hiding ( loadPackage )
 import           Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig )
 import           Stack.Setup ( withNewLocalBuildTargets )
 import           Stack.Types.Build
-                   ( Plan (..), Task (..), TaskType (..), taskLocation )
+                   ( Plan (..), Task (..), TaskType (..), taskLocation
+                   , taskProvides
+                   )
 import           Stack.Types.Build.Exception
                    ( BuildException (..), BuildPrettyException (..) )
 import           Stack.Types.BuildConfig ( HasBuildConfig, stackYamlL )

src/Stack/Build/ConstructPlan.hs

@@ -35,7 +35,7 @@ import           Stack.Types.Build
                    ( CachePkgSrc (..), ConfigCache (..), Plan (..), Task (..)
                    , TaskConfigOpts (..), TaskType (..)
                    , installLocationIsMutable, taskIsTarget, taskLocation
-                   , taskTargetIsMutable, toCachePkgSrc
+                   , taskProvides, taskTargetIsMutable, toCachePkgSrc
                    )
 import           Stack.Types.Build.Exception
                    ( BadDependency (..), BuildException (..)
@@ -525,10 +525,7 @@ addFinal lp package isAllInOne buildHaddocks = do
     Right (missing, present, _minLoc) -> do
       ctx <- ask
       pure $ Right Task
-        { taskProvides = PackageIdentifier
-            (packageName package)
-            (packageVersion package)
-        , taskConfigOpts = TaskConfigOpts missing $ \missing' ->
+        { taskConfigOpts = TaskConfigOpts missing $ \missing' ->
             let allDeps = Map.union present missing'
             in  configureOpts
                   (view envConfigL ctx)
@@ -833,10 +830,7 @@ installPackageGivenDeps isAllInOne buildHaddocks ps package minstalled
     pure $ case mRightVersionInstalled of
       Just installed -> ADRFound loc installed
       Nothing -> ADRToInstall Task
-        { taskProvides = PackageIdentifier
-            (packageName package)
-            (packageVersion package)
-        , taskConfigOpts = TaskConfigOpts missing $ \missing' ->
+        { taskConfigOpts = TaskConfigOpts missing $ \missing' ->
             let allDeps = Map.union present missing'
             in  configureOpts
                   (view envConfigL ctx)

src/Stack/Build/Execute.hs

@@ -132,6 +132,7 @@ import           Stack.Types.Build
                    ( ConfigCache (..), Plan (..), PrecompiledCache (..)
                    , Task (..), TaskConfigOpts (..), TaskType (..)
                    , configCacheComponents, taskIsTarget, taskLocation
+                   , taskProvides
                    )
 import           Stack.Types.Build.Exception
                    ( BuildException (..), BuildPrettyException (..) )
@@ -174,7 +175,7 @@ import           Stack.Types.NamedComponent
 import           Stack.Types.Package
                    ( InstallLocation (..), Installed (..), InstalledMap
                    , LocalPackage (..), Package (..), PackageLibraries (..)
-                   , installedPackageIdentifier, packageIdent, packageIdentifier
+                   , installedPackageIdentifier, packageIdentifier
                    , runMemoizedWith
                    )
 import           Stack.Types.PackageFile ( PackageWarning (..) )
@@ -948,7 +949,7 @@ toActions installedMap mtestLock runInBase ee (mbuild, mfinal) =
     Nothing -> []
     Just task@Task {..} ->
       [ Action
-          { actionId = ActionId taskProvides ATBuild
+          { actionId = ActionId (taskProvides task) ATBuild
           , actionDeps =
               Set.map (`ActionId` ATBuild) (tcoMissing taskConfigOpts)
           , actionDo =
@@ -961,7 +962,7 @@ toActions installedMap mtestLock runInBase ee (mbuild, mfinal) =
     Just task@Task {..} ->
       (if taskAllInOne then id else (:)
           Action
-              { actionId = ActionId taskProvides ATBuildFinal
+              { actionId = ActionId pkgId ATBuildFinal
               , actionDeps = addBuild
                   (Set.map (`ActionId` ATBuild) (tcoMissing taskConfigOpts))
               , actionDo =
@@ -971,7 +972,7 @@ toActions installedMap mtestLock runInBase ee (mbuild, mfinal) =
       -- These are the "final" actions - running tests and benchmarks.
       (if Set.null tests then id else (:)
           Action
-              { actionId = ActionId taskProvides ATRunTests
+              { actionId = ActionId pkgId ATRunTests
               , actionDeps = finalDeps
               , actionDo = \ac -> withLock mtestLock $ runInBase $
                   singleTest topts (Set.toList tests) ac ee task installedMap
@@ -983,7 +984,7 @@ toActions installedMap mtestLock runInBase ee (mbuild, mfinal) =
               }) $
       (if Set.null benches then id else (:)
           Action
-              { actionId = ActionId taskProvides ATRunBenchmarks
+              { actionId = ActionId pkgId ATRunBenchmarks
               , actionDeps = finalDeps
               , actionDo = \ac -> runInBase $
                   singleBench
@@ -999,17 +1000,18 @@ toActions installedMap mtestLock runInBase ee (mbuild, mfinal) =
               })
       []
      where
+      pkgId = taskProvides task
       comps = taskComponents task
       tests = testComponents comps
       benches = benchComponents comps
       finalDeps =
         if taskAllInOne
           then addBuild mempty
-          else Set.singleton (ActionId taskProvides ATBuildFinal)
+          else Set.singleton (ActionId pkgId ATBuildFinal)
       addBuild =
         case mbuild of
           Nothing -> id
-          Just _ -> Set.insert $ ActionId taskProvides ATBuild
+          Just _ -> Set.insert $ ActionId pkgId ATBuild
   withLock Nothing f = f
   withLock (Just lock) f = withMVar lock $ \() -> f
   bopts = eeBuildOpts ee
@@ -1292,6 +1294,7 @@ 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
 
@@ -1310,7 +1313,7 @@ withSingleContext
   console =
        (  wanted
        && all
-            (\(ActionId ident _) -> ident == taskProvides)
+            (\(ActionId ident _) -> ident == pkgId)
             (Set.toList acRemaining)
        && eeTotalWanted == 1
        )
@@ -1323,28 +1326,29 @@ withSingleContext
         withLockedDistDir prettyAnnounce root $
           inner (lpPackage lp) (lpCabalFile lp) root
       TTRemotePackage _ package pkgloc -> do
-          suffix <- parseRelDir $ packageIdentifierString $ packageIdent package
-          let dir = eeTempDir </> suffix
-          unpackPackageLocation dir pkgloc
-
-          -- See: https://github.com/commercialhaskell/stack/issues/157
-          distDir <- distRelativeDir
-          let oldDist = dir </> relDirDist
-              newDist = dir </> distDir
-          exists <- doesDirExist oldDist
-          when exists $ do
-            -- Previously used takeDirectory, but that got confused
-            -- by trailing slashes, see:
-            -- https://github.com/commercialhaskell/stack/issues/216
-            --
-            -- Instead, use Path which is a bit more resilient
-            ensureDir $ parent newDist
-            renameDir oldDist newDist
-
-          let name = pkgName taskProvides
-          cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal"
-          let cabalfp = dir </> cabalfpRel
-          inner package cabalfp dir
+        suffix <-
+          parseRelDir $ packageIdentifierString $ packageIdentifier package
+        let dir = eeTempDir </> suffix
+        unpackPackageLocation dir pkgloc
+
+        -- See: https://github.com/commercialhaskell/stack/issues/157
+        distDir <- distRelativeDir
+        let oldDist = dir </> relDirDist
+            newDist = dir </> distDir
+        exists <- doesDirExist oldDist
+        when exists $ do
+          -- Previously used takeDirectory, but that got confused
+          -- by trailing slashes, see:
+          -- https://github.com/commercialhaskell/stack/issues/216
+          --
+          -- Instead, use Path which is a bit more resilient
+          ensureDir $ parent newDist
+          renameDir oldDist newDist
+
+        let name = pkgName pkgId
+        cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal"
+        let cabalfp = dir </> cabalfpRel
+        inner package cabalfp dir
 
   withOutputType pkgDir package inner
     -- Not in interleaved mode. When building a single wanted package, dump
@@ -1546,7 +1550,7 @@ withSingleContext
                                stripTHLoading makeAbsolute pkgDir compilerVer
                           .| CL.consume
               prettyThrowM $ CabalExitedUnsuccessfully
-                (eceExitCode ece) taskProvides exeName fullArgs mlogFile bss
+                (eceExitCode ece) pkgId exeName fullArgs mlogFile bss
            where
             runAndOutput :: ActualCompiler -> RIO env ()
             runAndOutput compilerVer = withWorkingDir (toFilePath pkgDir) $
@@ -1677,9 +1681,10 @@ singleBuild
       Just installed -> do
         writeFlagCache installed cache
         liftIO $ atomically $
-          modifyTVar eeGhcPkgIds $ Map.insert taskProvides installed
+          modifyTVar eeGhcPkgIds $ Map.insert pkgId installed
  where
-  PackageIdentifier pname pversion = taskProvides
+  pkgId = taskProvides task
+  PackageIdentifier pname pversion = pkgId
   doHaddock mcurator package =
        taskBuildHaddock
     && not isFinalBuild
@@ -1781,7 +1786,7 @@ singleBuild
         PackageIdentifier (encodeCompatPackageName n) v
       allToUnregister :: [Either PackageIdentifier GhcPkgId]
       allToUnregister = mcons
-        (Left taskProvides <$ mlib)
+        (Left pkgId <$ mlib)
         (map (Left . toPackageId . toMungedPackageId) subLibNames)
       allToRegister = mcons mlib sublibs
 
@@ -1807,21 +1812,21 @@ singleBuild
       let dst = bindir </> filename exe
       createLink (toFilePath exe) (toFilePath dst) `catchIO` \_ -> copyFile exe dst
     case (mlib, exes) of
-      (Nothing, _:_) -> markExeInstalled (taskLocation task) taskProvides
+      (Nothing, _:_) -> markExeInstalled (taskLocation task) pkgId
       _ -> pure ()
 
     -- Find the package in the database
     let pkgDbs = [bcoSnapDB eeBaseConfigOpts]
 
     case mlib of
-      Nothing -> pure $ Just $ Executable taskProvides
+      Nothing -> pure $ Just $ Executable pkgId
       Just _ -> do
         mpkgid <- loadInstalledPkg pkgDbs eeSnapshotDumpPkgs pname
 
         pure $ Just $
           case mpkgid of
-            Nothing -> assert False $ Executable taskProvides
-            Just pkgid -> Library taskProvides pkgid Nothing
+            Nothing -> assert False $ Executable pkgId
+            Just pkgid -> Library pkgId pkgid Nothing
    where
     bindir = bcoSnapInstallRoot eeBaseConfigOpts </> bindirSuffix
 
@@ -1855,7 +1860,7 @@ singleBuild
         let installedMapHasThisPkg :: Bool
             installedMapHasThisPkg =
               case Map.lookup (packageName package) installedMap of
-                Just (_, Library ident _ _) -> ident == taskProvides
+                Just (_, Library ident _ _) -> ident == pkgId
                 Just (_, Executable _) -> True
                 _ -> False
 
@@ -1898,7 +1903,7 @@ singleBuild
     let cabal = cabal0 CloseOnException
     wc <- view $ actualCompilerVersionL.whichCompilerL
 
-    markExeNotInstalled (taskLocation task) taskProvides
+    markExeNotInstalled (taskLocation task) pkgId
     case taskType of
       TTLocalMutable lp -> do
         when enableTests $ setTestStatus pkgDir TSUnknown
@@ -2085,7 +2090,7 @@ singleBuild
           Nothing -> throwM $ Couldn'tFindPkgId $ packageName package
           Just pkgid -> pure (Library ident pkgid Nothing, sublibsPkgIds)
       NoLibraries -> do
-        markExeInstalled (taskLocation task) taskProvides -- TODO unify somehow
+        markExeInstalled (taskLocation task) pkgId -- TODO unify somehow
                                                           -- with writeFlagCache?
         pure (Executable ident, []) -- don't pure sublibs in this case
 
@@ -2106,7 +2111,7 @@ singleBuild
       TTRemotePackage{} -> do
         let remaining =
               filter
-                (\(ActionId x _) -> x == taskProvides)
+                (\(ActionId x _) -> x == pkgId)
                 (Set.toList acRemaining)
         when (null remaining) $ removeDirRecur pkgDir
       TTLocalMutable{} -> pure ()

src/Stack/SDist.hs

@@ -503,12 +503,9 @@ getSDistFileList lp deps =
           contents <- liftIO (S.readFile outFile)
           pure (T.unpack $ T.decodeUtf8With T.lenientDecode contents, cabalfp)
  where
-  package = lpPackage lp
   ac = ActionContext Set.empty [] ConcurrencyAllowed
   task = Task
-    { taskProvides =
-        PackageIdentifier (packageName package) (packageVersion package)
-    , taskType = TTLocalMutable lp
+    { taskType = TTLocalMutable lp
     , taskConfigOpts = TaskConfigOpts
         { tcoMissing = Set.empty
         , tcoOpts = \_ -> ConfigureOpts [] []

src/Stack/Types/Build.hs

@@ -11,6 +11,7 @@ module Stack.Types.Build
   , Task (..)
   , taskIsTarget
   , taskLocation
+  , taskProvides
   , taskTargetIsMutable
   , LocalPackage (..)
   , Plan (..)
@@ -53,7 +54,7 @@ import           Stack.Types.IsMutable ( IsMutable (..) )
 import           Stack.Types.Package
                    ( FileCacheInfo (..), InstallLocation (..), Installed (..)
                    , LocalPackage (..), Package (..), PackageSource (..)
-                   , psVersion
+                   , packageIdentifier, psVersion
                    )
 
 -- | Package dependency oracle.
@@ -122,9 +123,7 @@ toCachePkgSrc PSRemote{} = CacheSrcUpstream
 
 -- | A task to perform when building
 data Task = Task
-  { taskProvides        :: !PackageIdentifier -- FIXME turn this into a function on taskType?
-    -- ^ the package/version to be built
-  , taskType            :: !TaskType
+  { taskType            :: !TaskType
     -- ^ the task type, telling us how to build this
   , taskConfigOpts      :: !TaskConfigOpts
   , taskBuildHaddock    :: !Bool
@@ -171,6 +170,12 @@ data TaskType
   | TTRemotePackage IsMutable Package PackageLocationImmutable
   deriving Show
 
+-- | A function to yield the package name and version of a given 'TaskType'
+-- value.
+taskTypePackageIdentifier :: TaskType -> PackageIdentifier
+taskTypePackageIdentifier (TTLocalMutable lp) = packageIdentifier $ lpPackage lp
+taskTypePackageIdentifier (TTRemotePackage _ p _) = packageIdentifier p
+
 taskIsTarget :: Task -> Bool
 taskIsTarget t =
   case taskType t of
@@ -184,6 +189,11 @@ taskLocation task =
     TTRemotePackage Mutable _ _ -> Local
     TTRemotePackage Immutable _ _ -> Snap
 
+-- | A funtion to yield the package name and version to be built by the given
+-- task.
+taskProvides :: Task -> PackageIdentifier
+taskProvides = taskTypePackageIdentifier . taskType
+
 taskTargetIsMutable :: Task -> IsMutable
 taskTargetIsMutable task =
   case taskType task of

src/Stack/Types/Package.hs

@@ -31,7 +31,6 @@ module Stack.Types.Package
   , lpFilesForComponents
   , memoizeRefWith
   , packageDefinedFlags
-  , packageIdent
   , packageIdentifier
   , psVersion
   , runMemoizedWith
@@ -197,12 +196,8 @@ data Package = Package
   }
   deriving (Show, Typeable)
 
-packageIdent :: Package -> PackageIdentifier
-packageIdent p = PackageIdentifier (packageName p) (packageVersion p)
-
 packageIdentifier :: Package -> PackageIdentifier
-packageIdentifier pkg =
-  PackageIdentifier (packageName pkg) (packageVersion pkg)
+packageIdentifier p = PackageIdentifier (packageName p) (packageVersion p)
 
 packageDefinedFlags :: Package -> Set FlagName
 packageDefinedFlags = M.keysSet . packageDefaultFlags