diff --git a/.stan.toml b/.stan.toml index bb90593661..8e1d393afb 100644 --- a/.stan.toml +++ b/.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 diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 73969daea7..506a72451f 100644 --- a/src/Stack/Build.hs +++ b/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 ) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 439962e8b4..df942caea6 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/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) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index ec7115543e..da99268986 100644 --- a/src/Stack/Build/Execute.hs +++ b/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 () diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 94b9f9d92e..4da347bdbc 100644 --- a/src/Stack/SDist.hs +++ b/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 [] [] diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index ce522e4131..b582987a29 100644 --- a/src/Stack/Types/Build.hs +++ b/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 diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index f425240c64..e32dcb45ea 100644 --- a/src/Stack/Types/Package.hs +++ b/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