diff --git a/Cabal-described/src/Distribution/Described.hs b/Cabal-described/src/Distribution/Described.hs index 160e50ef15f..35840a96a64 100644 --- a/Cabal-described/src/Distribution/Described.hs +++ b/Cabal-described/src/Distribution/Described.hs @@ -101,7 +101,7 @@ import Distribution.Types.TestType (TestType) import Distribution.Types.UnitId (UnitId) import Distribution.Types.UnqualComponentName (UnqualComponentName) import Distribution.Utils.Path (SymbolicPath, RelativePath, FileOrDir(..), Pkg, Build) -import Distribution.Verbosity (Verbosity, VerbosityFlags) +import Distribution.Verbosity (VerbosityFlags) import Distribution.Version (Version, VersionRange) import Language.Haskell.Extension (Extension, Language, knownLanguages) diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs index ac1067764f8..12f7d8914f2 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs @@ -55,6 +55,8 @@ import System.FilePath , replaceExtension ) +import Distribution.Simple.InstallDirs (bindir, libdir) + -- | Links together the object files of the Haskell modules and extra sources -- using the context in which the component is being built. -- @@ -624,9 +626,63 @@ getRPaths pbci = do let hostPref = case hostOS of OSX -> "@loader_path" _ -> "$ORIGIN" - relPath p = if isRelative p then hostPref p else p + -- The artifact's eventual install directory; absolute rpaths are + -- expressed as `@loader_path`/`$ORIGIN`-relative to this when the + -- user has opted into relocatable mode (`relocatable: True` or + -- `--enable-relocatable`). + -- + -- Mirrors the executable/library split in + -- 'Distribution.Simple.LocalBuildInfo.depLibraryPaths'. + installDirs = absoluteComponentInstallDirs + (localPkgDescr lbi) lbi (componentUnitId clbi) NoCopyDest + isExe = case clbi of + ExeComponentLocalBuildInfo{} -> True + _ -> False + relDir + | isExe = bindir installDirs + | otherwise = libdir installDirs + -- Convert an rpath entry to its loader-relative form. + -- + -- * Already-relative paths get the `@loader_path` / `$ORIGIN` + -- prefix as before. + -- * Absolute paths are rewritten to a relative-form expression + -- (`@loader_path/../../...`) computed against the binary's + -- install dir, so the resulting binary does not bake a + -- build-host absolute path into LC_RPATH / DT_RUNPATH. + -- + -- This matters on macOS 15 (Sequoia), whose dyld treats an + -- unresolvable absolute rpath as fatal — older dyld silently + -- falls through to subsequent rpath entries. Pre-fix, a + -- bindist produced under e.g. + -- `/Volumes/WorkSpace/_work/ghc/ghc/_build/stage2/store/...` + -- would abort-trap on launch when relocated off the build + -- host. Post-fix, the same entry becomes + -- `@loader_path/../..//lib`, which dyld treats + -- as a normal missing-directory rpath when the bindist + -- layout no longer matches the store layout. + -- + -- Not gated on `relocatable lbi`: that flag also triggers + -- `checkRelocatable` (which refuses cabal-store layouts + -- where deps live in sibling prefixes) and changes how + -- library-dirs are emitted in .conf files. Both behaviors + -- are independent of rpath generation and incompatible with + -- the stable-haskell GHC bindist assembly pipeline. + relPath p + | isRelative p = hostPref p + | otherwise = hostPref shortRelativePath relDir p rpaths = - toNubListR (map relPath libraryPaths) + -- Always search the artifact's own directory ($ORIGIN / + -- @loader_path) first, so a sibling library installed alongside it + -- is found by the dynamic loader. depLibraryPaths can yield the + -- parent directory for a same-directory dependency (relativized to + -- "$ORIGIN/.."), which leaves the dependency unfound. glibc papers + -- over this via the runtime LD_LIBRARY_PATH GHC sets before + -- dlopen, but musl reads LD_LIBRARY_PATH only at process startup, + -- so the missing self-rpath is fatal there: a Backpack signature + -- implementation (libHSp) installed next to the instantiated unit + -- (libHSindef) fails to load (testsuite T14304 on Alpine/musl). + toNubListR [hostPref] + <> toNubListR (map relPath libraryPaths) <> toNubListR (map getSymbolicPath $ extraLibDirs bi) return rpaths else return mempty diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index a2ac44fcf44..fae7f4e9def 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs @@ -75,7 +75,7 @@ import Distribution.Simple.Setup ( BooleanFlag(..) ) import Distribution.Simple.Utils ( ordNubBy ) -import Distribution.Verbosity ( VerbosityLevel (..), normal, verbose ) +import Distribution.Verbosity ( VerbosityLevel (..) ) -- | Ties the two worlds together: classic cabal-install vs. the modular -- solver. Performs the necessary translations before and after. diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs index 63694b0b37c..c9f1ac521c7 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs @@ -261,7 +261,7 @@ alreadyLinked = error "addLinking called on tree that already contains linked no -- | Interface to the tree builder. Just takes an index and a list of package names, -- and computes the initial state and then the tree from there. buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason -buildTree idx (IndependentGoals ind) igs = +buildTree idx (IndependentGoals _ind) igs = build Linker { buildState = BS { index = idx diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs index 3ea4f5fd5a6..f99c34a64d1 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs @@ -274,8 +274,7 @@ linkDeps target = \deps -> do (Simple (LDep _ (Pkg _ _)) _, _) -> return () requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN) - requalify deps = do - vs <- get + requalify deps = return $ qualifyDeps target (unqualifyDeps deps) pickFlag :: QFN -> Bool -> UpdateState () diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs index 3623a11d5df..f0c0566d6a1 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs @@ -201,7 +201,6 @@ validate = go svd <- asks saved -- obtain saved dependencies aComps <- asks availableComponents rComps <- asks requiredComponents - qo <- asks qualifyOptions -- obtain dependencies and index-dictated exclusions introduced by the choice let I stage _vr _loc = i let (PInfo deps comps _ mfr) = idx ! pn ! i diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index e7525d24f29..018d0befd9e 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -94,6 +94,10 @@ constraintQualifierMatches (ScopeAnySetupQualifier pn) (QualSetup _) pn' = pn == constraintQualifierMatches (ScopeAnyExeQualifier pn) (QualExe _ _) pn' = pn == pn' constraintQualifierMatches (ScopeAnyExeQualifier _) QualToplevel _ = False constraintQualifierMatches (ScopeAnyExeQualifier _) (QualSetup _) _compile = False +-- A base-qualified dependency is never matched by a toplevel/setup/exe scope. +constraintQualifierMatches (ScopeTarget _) (QualBase _) _ = False +constraintQualifierMatches (ScopeAnySetupQualifier _) (QualBase _) _ = False +constraintQualifierMatches (ScopeAnyExeQualifier _) (QualBase _) _ = False constraintQualifierMatches (ScopeAnyQualifier pn) _ pn' = pn == pn' instance Pretty ConstraintScope where diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs index 069e45181e0..e752c0e6092 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs @@ -64,6 +64,7 @@ instance Structured Qualifier instance Pretty Qualifier where pretty QualToplevel = Disp.text "toplevel" + pretty (QualBase pn) = pretty pn <<>> Disp.text ":base" pretty (QualSetup pn) = pretty pn <<>> Disp.text ":setup" pretty (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>> pretty pn2 <<>> Disp.text ":exe" @@ -78,6 +79,7 @@ instance Pretty Qualifier where -- 'Base' qualifier, will always be @base@). dispQualifier :: Qualifier -> Disp.Doc dispQualifier QualToplevel = mempty +dispQualifier (QualBase pn) = pretty pn <> Disp.text "." dispQualifier (QualSetup pn) = pretty pn <> Disp.text ":setup." dispQualifier (QualExe pn pn2) = pretty pn diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 63a73c9bfea..11265787340 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -37,6 +37,7 @@ import Distribution.Simple.InstallDirs (InstallDirs (..), toPathTemplate) import Distribution.Simple.Setup (DumpBuildInfo (..), HaddockTarget (..), TestShowDetails (..)) import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath (..)) +import Distribution.Solver.Types.Stage (Stage (..)) import Distribution.Solver.Types.Settings ( AllowBootLibInstalls (..) , CountConflicts (..) @@ -84,6 +85,7 @@ parserTests = , testCase "read project-config-local-packages" testProjectConfigLocalPackages , testCase "read project-config-all-packages" testProjectConfigAllPackages , testCase "read project-config-specific-packages" testProjectConfigSpecificPackages + , testCase "read project-config-stage-packages" testProjectConfigStagePackages , testCase "test projectConfigAllPackages concatenation" testAllPackagesConcat , testCase "test projectConfigSpecificPackages concatenation" testSpecificPackagesConcat , testCase "test program-locations concatenation" testProgramLocationsConcat @@ -438,6 +440,30 @@ testProjectConfigSpecificPackages = do { packageConfigSharedLib = Flag True } +testProjectConfigStagePackages :: Assertion +testProjectConfigStagePackages = do + -- The legacy parser does not support stage-qualified package stanzas (it + -- would reject the @build:*@ argument), so we read with the parsec parser + -- only rather than 'readConfigDefault', which also runs the legacy parser. + config <- readConfigParsec "project-config-stage-packages" + assertEqual + "Parsed Config does not match expected" + expected + (projectConfigStagePackages (snd (condTreeData config))) + where + expected = MapMappend $ Map.fromList [(Build, expectedBuild), (Host, expectedHost)] + expectedBuild :: PackageConfig + expectedBuild = + mempty + { packageConfigSharedLib = Flag False + , packageConfigDynExe = Flag False + } + expectedHost :: PackageConfig + expectedHost = + mempty + { packageConfigSharedLib = Flag True + } + testAllPackagesConcat :: Assertion testAllPackagesConcat = do (config, legacy) <- readConfigDefault "all-packages-concat" @@ -566,6 +592,18 @@ verbosity = mkVerbosity defaultVerbosityHandles normal readConfigDefault :: FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton) readConfigDefault testSubDir = readConfig testSubDir "cabal.project" +-- | Read a project config using the parsec parser only. Useful for syntax the +-- legacy parser does not support (e.g. stage-qualified package stanzas). +readConfigParsec :: FilePath -> IO ProjectConfigSkeleton +readConfigParsec testSubDir = do + (TestDir testRootFp projectConfigFp distDirLayout) <- testDirInfo testSubDir "cabal.project" + exists <- liftIO $ doesFileExist projectConfigFp + assertBool ("projectConfig does not exist: " <> projectConfigFp) exists + httpTransport <- liftIO $ configureTransport verbosity [] Nothing + liftIO $ + runRebuild testRootFp $ + readProjectFileSkeletonParsec verbosity httpTransport distDirLayout "" "" + readConfig :: FilePath -> FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton) readConfig testSubDir projectFileName = do (TestDir testRootFp projectConfigFp distDirLayout) <- testDirInfo testSubDir projectFileName diff --git a/cabal-install/parser-tests/Tests/files/project-config-stage-packages/cabal.project b/cabal-install/parser-tests/Tests/files/project-config-stage-packages/cabal.project new file mode 100644 index 00000000000..2bf82caa5c5 --- /dev/null +++ b/cabal-install/parser-tests/Tests/files/project-config-stage-packages/cabal.project @@ -0,0 +1,6 @@ +package build:* + shared: False + executable-dynamic: False + +package host:* + shared: True diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index 1422900fdd0..de5124c19ab 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -44,8 +44,10 @@ projectConfigFieldGrammar source knownPrograms = <*> blurFieldGrammar L.projectConfigLocalPackages (packageConfigFieldGrammar knownPrograms) -- \^ PackageConfig to be applied to locally built packages, specified not inside a stanza <*> pure mempty - where -- \^ PackageConfig applied to explicitly named packages + <*> pure mempty + -- \^ PackageConfig applied to all packages of a given stage ('package build:*' etc.) + where provenance = Set.singleton (Explicit source) formatPackageVersionConstraints :: [PackageVersionConstraint] -> List CommaVCat (Identity PackageVersionConstraint) PackageVersionConstraint diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 692fd8ff982..dc98620cd08 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -644,6 +644,8 @@ convertLegacyProjectConfig , projectConfigAllPackages = configAllPackages , projectConfigLocalPackages = configLocalPackages , projectConfigSpecificPackage = fmap perPackage legacySpecificConfig + , -- The legacy parser does not support stage-qualified package stanzas. + projectConfigStagePackages = mempty } where configAllPackages = convertLegacyPerPackageFlags g i h t b diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index fcbdbcbae88..111593695b6 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -60,6 +60,7 @@ import Distribution.Solver.Types.Settings , ReorderGoals (..) , StrongFlags (..) ) +import Distribution.Solver.Types.Stage (Stage) import Distribution.Types.PackageVersionConstraint ( PackageVersionConstraint ) @@ -109,6 +110,10 @@ projectConfigSpecificPackage :: Lens' ProjectConfig (MapMappend PackageName Pack projectConfigSpecificPackage f s = fmap (\x -> s{T.projectConfigSpecificPackage = x}) (f (T.projectConfigSpecificPackage s)) {-# INLINEABLE projectConfigSpecificPackage #-} +projectConfigStagePackages :: Lens' ProjectConfig (MapMappend Stage PackageConfig) +projectConfigStagePackages f s = fmap (\x -> s{T.projectConfigStagePackages = x}) (f (T.projectConfigStagePackages s)) +{-# INLINEABLE projectConfigStagePackages #-} + projectConfigVerbosity :: Lens' ProjectConfigBuildOnly (Flag VerbosityFlags) projectConfigVerbosity f s = fmap (\x -> s{T.projectConfigVerbosity = x}) (f (T.projectConfigVerbosity s)) {-# INLINEABLE projectConfigVerbosity #-} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 0576186de29..d0b68a7dd56 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -42,6 +42,7 @@ import Distribution.Simple.Program.Types (programName) import Distribution.Simple.Setup import Distribution.Simple.Utils (debug, noticeDoc) import Distribution.Solver.Types.ProjectConfigPath +import Distribution.Solver.Types.Stage (Stage) import Distribution.System (buildOS) import Distribution.Types.CondTree (CondBranch (..), CondTree (..)) import Distribution.Types.ConfVar (ConfVar (..)) @@ -284,8 +285,11 @@ parseSection programDb (MkSection (Name pos name) args secFields) Just (SpecificPackage packageName) -> do packageCfg <- parsePackageConfig stateConfig . L.projectConfigSpecificPackage %= (<> MapMappend (Map.singleton packageName packageCfg)) + Just (AllStagePackages stage) -> do + packageCfg <- parsePackageConfig + stateConfig . L.projectConfigStagePackages %= (<> MapMappend (Map.singleton stage packageCfg)) Nothing -> do - lift $ parseWarning pos PWTUnknownSection "target package name or * required" + lift $ parseWarning pos PWTUnknownSection "target package name, '*', or ':*' required" return () | otherwise = do warnInvalidSubsection pos name @@ -345,7 +349,7 @@ parseRepoName pos args = case args of return Nothing Right name -> return $ Just name -data PackageConfigTarget = AllPackages | SpecificPackage !PackageName +data PackageConfigTarget = AllPackages | AllStagePackages !Stage | SpecificPackage !PackageName parsePackageName :: Position -> [SectionArg Position] -> ParseResult src (Maybe PackageConfigTarget) parsePackageName pos args = case args of @@ -356,12 +360,18 @@ parsePackageName pos args = case args of where parseName secName = case runParsecParser parser "" (fieldLineStreamFromBS secName) of Left _ -> do - parseFailure pos ("Invalid package name" ++ fromUTF8BS secName) + parseFailure pos ("Invalid 'package' target (expected a package name, '*', or ':*'): " ++ fromUTF8BS secName) return Nothing Right cfgTarget -> return $ pure cfgTarget parser :: ParsecParser PackageConfigTarget parser = - P.choice [P.try (P.char '*' >> return AllPackages), SpecificPackage <$> parsec] + P.choice + [ P.try (P.char '*' >> return AllPackages) + , -- A stage qualifier, e.g. @build:*@ or @host:*@, applies the + -- package configuration to all packages built for that stage. + P.try (AllStagePackages <$> parsec <* P.char ':' <* P.char '*') + , SpecificPackage <$> parsec + ] -- | Parse fields of a program-options stanza. parseProgramArgs :: ProgramDb -> Fields Position -> ParseResult src (MapMappend String [String]) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index e2c36da813f..0a519755be2 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -57,6 +57,7 @@ import Distribution.Client.CmdInstall.ClientInstallFlags ) import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Stage (Stage) import Distribution.Solver.Types.Settings import Distribution.Package @@ -155,6 +156,12 @@ data ProjectConfig = ProjectConfig -- ^ Configuration to be applied to *local* packages; i.e., -- any packages which are explicitly named in `cabal.project`. , projectConfigSpecificPackage :: MapMappend PackageName PackageConfig + , projectConfigStagePackages :: MapMappend Stage PackageConfig + -- ^ Configuration to be applied to all packages built for a particular + -- stage (e.g. @package build:*@ or @package host:*@). Lets a staged build + -- target the build-stage and host-stage packages independently, which + -- plain @package *@ cannot since the same package can be built in both + -- stages. } deriving (Eq, Show, Generic) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index d1b08da787a..b84c79d42f9 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -883,6 +883,7 @@ rebuildInstallPlan , projectConfigAllPackages , projectConfigLocalPackages , projectConfigSpecificPackage + , projectConfigStagePackages , projectConfigBuildOnly } toolchains @@ -912,6 +913,7 @@ rebuildInstallPlan projectConfigAllPackages projectConfigLocalPackages (getMapMappend projectConfigSpecificPackage) + (getMapMappend projectConfigStagePackages) instantiatedPlan <- instantiateInstallPlan @@ -1512,6 +1514,7 @@ elaborateInstallPlan -> PackageConfig -> PackageConfig -> Map PackageName PackageConfig + -> Map Stage PackageConfig -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) elaborateInstallPlan verbosity @@ -1524,7 +1527,8 @@ elaborateInstallPlan sharedPackageConfig allPackagesConfig localPackagesConfig - perPackageConfig = do + perPackageConfig + stagePackagesConfig = do x <- elaboratedInstallPlan return (x, elaboratedSharedConfig) where @@ -2120,6 +2124,28 @@ elaborateInstallPlan elabPkgSourceId = srcpkgPackageId elabStage = solverPkgStage + + -- Per-package option lookups for this package, specialised to its + -- stage so that stage-qualified config (@package build:*@ etc.) is + -- applied. These need explicit (polymorphic) type signatures: they + -- close over 'elabStage', and with MonoLocalBinds (implied by the + -- extensions this module uses) such local bindings would not + -- otherwise generalise over their result type. + perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a + perPkgOptionFlag pkgid = perPkgOptionFlagStaged elabStage pkgid + perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a + perPkgOptionMaybe pkgid = perPkgOptionMaybeStaged elabStage pkgid + perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] + perPkgOptionList pkgid = perPkgOptionListStaged elabStage pkgid + perPkgOptionNubList :: Ord a => PackageId -> (PackageConfig -> NubList a) -> [a] + perPkgOptionNubList pkgid = perPkgOptionNubListStaged elabStage pkgid + perPkgOptionMapLast :: Ord k => PackageId -> (PackageConfig -> MapLast k v) -> Map k v + perPkgOptionMapLast pkgid = perPkgOptionMapLastStaged elabStage pkgid + perPkgOptionMapMappend :: (Ord k, Semigroup v) => PackageId -> (PackageConfig -> MapMappend k v) -> Map k v + perPkgOptionMapMappend pkgid = perPkgOptionMapMappendStaged elabStage pkgid + perPkgOptionLibExeFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> (PackageConfig -> Flag a) -> (a, a) + perPkgOptionLibExeFlag pkgid = perPkgOptionLibExeFlagStaged elabStage pkgid + elabToolchain = getStage toolchains elabStage elabCompiler = toolchainCompiler elabToolchain elabPlatform = toolchainPlatform elabToolchain @@ -2229,7 +2255,7 @@ elaborateInstallPlan elabBuildOptionsRaw = LBC.BuildOptions { withVanillaLib = perPkgOptionFlag srcpkgPackageId True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively - , withSharedLib = srcpkgPackageId `Set.member` pkgsUseSharedLibrary elabCompiler + , withSharedLib = srcpkgPackageId `Set.member` pkgsUseSharedLibrary elabStage elabCompiler , withStaticLib = perPkgOptionFlag srcpkgPackageId False packageConfigStaticLib , withBytecodeLib = perPkgOptionFlag srcpkgPackageId False packageConfigBytecodeLib , withDynExe = @@ -2241,8 +2267,8 @@ elaborateInstallPlan , withFullyStaticExe = perPkgOptionFlag srcpkgPackageId False packageConfigFullyStaticExe , withGHCiLib = perPkgOptionFlag srcpkgPackageId False packageConfigGHCiLib -- TODO: [required feature] needs to default to enabled on windows still , withProfExe = perPkgOptionFlag srcpkgPackageId False packageConfigProf - , withProfLib = srcpkgPackageId `Set.member` pkgsUseProfilingLibrary elabCompiler - , withProfLibShared = srcpkgPackageId `Set.member` pkgsUseProfilingLibraryShared elabCompiler + , withProfLib = srcpkgPackageId `Set.member` pkgsUseProfilingLibrary elabStage elabCompiler + , withProfLibShared = srcpkgPackageId `Set.member` pkgsUseProfilingLibraryShared elabStage elabCompiler , exeCoverage = perPkgOptionFlag srcpkgPackageId False packageConfigCoverage , libCoverage = perPkgOptionFlag srcpkgPackageId False packageConfigCoverage , withOptimization = perPkgOptionFlag srcpkgPackageId NormalOptimisation packageConfigOptimization @@ -2344,40 +2370,52 @@ elaborateInstallPlan -- localPackageConfig applies to all project source packages -- perPackageConfig applies to specific named packages - perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a - perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f) + -- These helpers take the 'Stage' of the package being elaborated so that + -- stage-qualified package configuration (e.g. @package build:*@) can be + -- applied. Within 'elaborateSolverToCommon' they are re-bound to the + -- current 'elabStage' (see the local definitions there), so the many call + -- sites can keep using the un-suffixed names. + perPkgOptionFlagStaged :: Stage -> PackageId -> a -> (PackageConfig -> Flag a) -> a + perPkgOptionFlagStaged stage pkgid def f = fromFlagOrDefault def (lookupPerPkgOptionStaged stage pkgid f) - perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a - perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f) + perPkgOptionMaybeStaged :: Stage -> PackageId -> (PackageConfig -> Flag a) -> Maybe a + perPkgOptionMaybeStaged stage pkgid f = flagToMaybe (lookupPerPkgOptionStaged stage pkgid f) - perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] - perPkgOptionList pkgid f = lookupPerPkgOption pkgid f + perPkgOptionListStaged :: Stage -> PackageId -> (PackageConfig -> [a]) -> [a] + perPkgOptionListStaged stage pkgid f = lookupPerPkgOptionStaged stage pkgid f - perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f) + perPkgOptionNubListStaged :: Ord a => Stage -> PackageId -> (PackageConfig -> NubList a) -> [a] + perPkgOptionNubListStaged stage pkgid f = fromNubList (lookupPerPkgOptionStaged stage pkgid f) - perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f) + perPkgOptionMapLastStaged :: Ord k => Stage -> PackageId -> (PackageConfig -> MapLast k v) -> Map k v + perPkgOptionMapLastStaged stage pkgid f = getMapLast (lookupPerPkgOptionStaged stage pkgid f) - perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f) + perPkgOptionMapMappendStaged :: (Ord k, Semigroup v) => Stage -> PackageId -> (PackageConfig -> MapMappend k v) -> Map k v + perPkgOptionMapMappendStaged stage pkgid f = getMapMappend (lookupPerPkgOptionStaged stage pkgid f) - perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib) + perPkgOptionLibExeFlagStaged :: Stage -> PackageId -> a -> (PackageConfig -> Flag a) -> (PackageConfig -> Flag a) -> (a, a) + perPkgOptionLibExeFlagStaged stage pkgid def fboth flib = (exe, lib) where exe = fromFlagOrDefault def bothflag lib = fromFlagOrDefault def (bothflag <> libflag) - bothflag = lookupPerPkgOption pkgid fboth - libflag = lookupPerPkgOption pkgid flib + bothflag = lookupPerPkgOptionStaged stage pkgid fboth + libflag = lookupPerPkgOptionStaged stage pkgid flib - lookupPerPkgOption + lookupPerPkgOptionStaged :: (Package pkg, Monoid m) - => pkg + => Stage + -> pkg -> (PackageConfig -> m) -> m - lookupPerPkgOption pkg f = + lookupPerPkgOptionStaged stage pkg f = -- This is where we merge the options from the project config that - -- apply to all packages, all project local packages, and to specific - -- named packages - global `mappend` local `mappend` perpkg + -- apply to all packages, all project local packages, all packages of + -- a given stage, and to specific named packages. Later (more specific) + -- entries override earlier ones. + global `mappend` local `mappend` stagecfg `mappend` perpkg where global = f allPackagesConfig + stagecfg = foldMap f (Map.lookup stage stagePackagesConfig) local | isProjectSourcePackage pkg = f localPackagesConfig @@ -2424,11 +2462,16 @@ elaborateInstallPlan projectSourcePackages = Set.fromList (mapMaybe isLocalUnpackedPackage localPackages) - pkgsUseSharedLibrary :: Compiler -> Set PackageId - pkgsUseSharedLibrary compiler = - packagesWithLibDepsDownwardClosedProperty (needsSharedLib compiler) + -- These are parameterised by 'Stage' so that stage-qualified package + -- configuration (@package build:*@ etc.) is honoured and so the + -- downward-closed lib-dependency closure stays within a single stage. + -- Without this a host-stage dynamic executable would drag its (same + -- 'PackageId') build-stage dependencies into the shared-lib set. + pkgsUseSharedLibrary :: Stage -> Compiler -> Set PackageId + pkgsUseSharedLibrary stage compiler = + packagesWithLibDepsDownwardClosedProperty stage (needsSharedLib stage compiler) - needsSharedLib compiler pkgid = + needsSharedLib stage compiler pkgid = fromMaybe compilerShouldUseSharedLibByDefault -- Case 1: --enable-shared or --disable-shared is passed explicitly, honour that. @@ -2449,9 +2492,9 @@ elaborateInstallPlan _ -> Nothing ) where - pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib - pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe - pkgProf = perPkgOptionMaybe pkgid packageConfigProf + pkgSharedLib = perPkgOptionMaybeStaged stage pkgid packageConfigSharedLib + pkgDynExe = perPkgOptionMaybeStaged stage pkgid packageConfigDynExe + pkgProf = perPkgOptionMaybeStaged stage pkgid packageConfigProf compilerShouldUseSharedLibByDefault = case compilerFlavor compiler of @@ -2467,16 +2510,15 @@ elaborateInstallPlan canBuildSharedLibs = canBuildWayLibs dynamicSupported canBuildProfilingSharedLibs = canBuildWayLibs profilingDynamicSupported - pkgsUseProfilingLibrary :: Compiler -> Set PackageId - pkgsUseProfilingLibrary compiler = - packagesWithLibDepsDownwardClosedProperty (needsProfilingLib compiler) + pkgsUseProfilingLibrary :: Stage -> Compiler -> Set PackageId + pkgsUseProfilingLibrary stage compiler = + packagesWithLibDepsDownwardClosedProperty stage (needsProfilingLib stage compiler) - needsProfilingLib compiler pkg = + needsProfilingLib stage compiler pkgid = fromFlagOrDefault compilerShouldUseProfilingLibByDefault (profBothFlag <> profLibFlag) where - pkgid = packageId pkg - profBothFlag = lookupPerPkgOption pkgid packageConfigProf - profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib + profBothFlag = lookupPerPkgOptionStaged stage pkgid packageConfigProf + profLibFlag = lookupPerPkgOptionStaged stage pkgid packageConfigProfLib compilerShouldUseProfilingLibByDefault = case compilerFlavor compiler of @@ -2487,11 +2529,11 @@ elaborateInstallPlan canBuildProfilingLibs = canBuildWayLibs profilingVanillaSupported - pkgsUseProfilingLibraryShared :: Compiler -> Set PackageId - pkgsUseProfilingLibraryShared compiler = - packagesWithLibDepsDownwardClosedProperty (needsProfilingLibShared compiler) + pkgsUseProfilingLibraryShared :: Stage -> Compiler -> Set PackageId + pkgsUseProfilingLibraryShared stage compiler = + packagesWithLibDepsDownwardClosedProperty stage (needsProfilingLibShared stage compiler) - needsProfilingLibShared compiler pkg = + needsProfilingLibShared stage compiler pkgid = fromMaybe compilerShouldUseProfilingSharedLibByDefault -- case 1: If --enable-profiling-shared is passed explicitly, honour that @@ -2510,10 +2552,9 @@ elaborateInstallPlan _ -> Nothing ) where - pkgid = packageId pkg - profLibSharedFlag = perPkgOptionMaybe pkgid packageConfigProfShared - pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe - pkgProf = perPkgOptionMaybe pkgid packageConfigProf + profLibSharedFlag = perPkgOptionMaybeStaged stage pkgid packageConfigProfShared + pkgDynExe = perPkgOptionMaybeStaged stage pkgid packageConfigDynExe + pkgProf = perPkgOptionMaybeStaged stage pkgid packageConfigProf compilerShouldUseProfilingSharedLibByDefault = case compilerFlavor compiler of @@ -2532,14 +2573,18 @@ elaborateInstallPlan NonSetupLibDepSolverPlanPackage (SolverInstallPlan.toList solverPlan) - packagesWithLibDepsDownwardClosedProperty :: (PackageIdentifier -> Bool) -> Set PackageIdentifier - packagesWithLibDepsDownwardClosedProperty property = + -- Only packages built for the given 'stage' are considered as roots; the + -- lib-dependency closure (which never crosses stages) then keeps the + -- result within that stage. + packagesWithLibDepsDownwardClosedProperty :: Stage -> (PackageIdentifier -> Bool) -> Set PackageIdentifier + packagesWithLibDepsDownwardClosedProperty stage property = Set.fromList . maybe [] (map packageId) $ Graph.closure libDepGraph [ Graph.nodeKey pkg | pkg <- SolverInstallPlan.toList solverPlan + , solverStage (solverId pkg) == stage , property (packageId pkg) -- just the packages that satisfy the property -- TODO: [nice to have] this does not check the config consistency, -- e.g. a package explicitly turning off profiling, but something diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 6a68d366507..6fca4cd3d6a 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -418,6 +418,7 @@ instance Arbitrary ProjectConfig where <*> ( MapMappend . fmap getNonMEmpty . Map.fromList <$> shortListOf 3 arbitrary ) + <*> pure mempty -- projectConfigStagePackages: no round-trip coverage yet -- package entries with no content are equivalent to -- the entry not existing at all, so exclude empty @@ -449,6 +450,7 @@ instance Arbitrary ProjectConfig where (fmap getNonMEmpty x8') ) , projectConfigAllPackages = x9' + , projectConfigStagePackages = mempty } | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8', x9')) <- shrink