From 1ab1670c4fd92db1fc28926ad81862553a5d67ff Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 11 Jun 2026 15:54:14 +0800 Subject: [PATCH 1/5] fix(cabal-install): resolve -Werror warnings for validate These warnings are promoted to errors under validate's -Werror but were masked behind the earlier SolverInstallPlan failure. Clean them up so the build proceeds: - drop unused imports across Dependency, ProjectPlanning(.Types), InLibrary, SetupWrapper, ProjectBuilding.UnpackedPackage, CmdRepl and the InstallPlan and DSL unit-test modules - bind the discarded result of runBuild explicitly (-Wunused-do-bind) - underscore the unused indepGoals parameter in the solver DSL - remove the dead internalSetupMethod, buildTypeAction and selfExecSetupMethod (unexported, unreferenced, not dispatched by runSetupMethod) along with the imports they alone used (Distribution.Make, withEnv/withEnvOverrides/ withExtraPathEnv, System.Environment) --- .../src/Distribution/Client/CmdRepl.hs | 3 +- .../src/Distribution/Client/Dependency.hs | 2 - .../src/Distribution/Client/InLibrary.hs | 2 - .../Client/ProjectBuilding/UnpackedPackage.hs | 4 +- .../Distribution/Client/ProjectPlanning.hs | 1 - .../Client/ProjectPlanning/Types.hs | 3 +- .../src/Distribution/Client/SetupWrapper.hs | 63 +------------------ .../Distribution/Client/InstallPlan.hs | 1 - .../Distribution/Solver/Modular/DSL.hs | 2 +- 9 files changed, 6 insertions(+), 75 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index db9af241158..95eeb361a32 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -26,8 +26,7 @@ import Distribution.Compat.Lens import qualified Distribution.Types.Lens as L import Distribution.Client.CmdErrorMessages - ( ComponentKind (..) - , Plural (..) + ( Plural (..) , componentKind , renderComponentKind , renderListCommaAnd diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index a975194e6ee..9946865b556 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -139,8 +139,6 @@ import Distribution.Types.DependencySatisfaction ) import Distribution.Verbosity ( VerbosityLevel (..) - , deafening - , normal ) import Distribution.Version diff --git a/cabal-install/src/Distribution/Client/InLibrary.hs b/cabal-install/src/Distribution/Client/InLibrary.hs index e424fd54c16..eb9d745fda1 100644 --- a/cabal-install/src/Distribution/Client/InLibrary.hs +++ b/cabal-install/src/Distribution/Client/InLibrary.hs @@ -37,8 +37,6 @@ import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.SetupHooks.Internal import qualified Distribution.Simple.Test as Cabal import Distribution.Simple.Utils -import Distribution.Client.Toolchain (Toolchain (..)) -import Distribution.Solver.Types.Stage (Stage (..), getStage) import Distribution.System (Platform) import Distribution.Types.BuildType import Distribution.Types.ComponentRequestedSpec diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 4ffe2f74093..cd0597f9c30 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -88,7 +88,7 @@ import qualified Data.ByteString as BS import qualified Data.List.NonEmpty as NE import Control.Exception (Handler (..), SomeAsyncException, catches, onException) -import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist, removeFile) +import System.Directory (canonicalizePath, createDirectoryIfMissing) import System.FilePath (takeDirectory, ()) import System.IO (Handle, IOMode (AppendMode), withFile) import System.Semaphore (SemaphoreName (..)) @@ -492,7 +492,7 @@ buildAndInstallUnpackedPackage whenRebuild $ do noticeProgress ProgressBuilding timestamp <- beginUpdateFileMonitor - runBuild + _ <- runBuild -- Be sure to invalidate the cache if building throws an exception! -- If not, we'll abort execution with a stale recompilation cache. -- See ghc#24926 for an example of how this can go wrong. diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 77dda894fcd..d1b08da787a 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -169,7 +169,6 @@ import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb -import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 7e64cacc91f..a17e290d510 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -127,12 +127,11 @@ import Distribution.Types.ComponentRequestedSpec import qualified Distribution.Types.LocalBuildConfig as LBC import Distribution.Types.PackageDescription (PackageDescription (..)) import Distribution.Types.PkgconfigVersion -import Distribution.Verbosity (Verbosity, VerbosityLevel (..), verbosityLevel) +import Distribution.Verbosity (VerbosityLevel (..), verbosityLevel) import Distribution.Version import Distribution.Utils.Path (()) import qualified Data.ByteString.Lazy as LBS -import Data.Foldable (fold) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Distribution.Compat.Graph as Graph diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 14ca8dc077f..c4fb0ed2715 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -59,7 +59,6 @@ import Distribution.PackageDescription , buildType , specVersion ) -import qualified Distribution.Make as Make import qualified Distribution.Simple as Simple import Distribution.Simple.Build.Macros ( generatePackageVersionMacros @@ -78,11 +77,8 @@ import Distribution.Simple.PreProcess , runSimplePreProcessor ) import Distribution.Simple.Program - ( ProgramDb - , builtinPrograms - , emptyProgramDb + ( builtinPrograms , getDbProgramOutputCwd - , getProgramSearchPath , ghcProgram , runDbProgramCwd ) @@ -127,9 +123,6 @@ import Distribution.Client.Utils #endif , moreRecentFile , tryCanonicalizePath - , withEnv - , withEnvOverrides - , withExtraPathEnv ) import Distribution.Utils.Path hiding ( (), (<.>) ) @@ -190,7 +183,6 @@ import qualified Data.Map.Lazy as Map import Data.Type.Equality ( type (==) ) import Data.Type.Bool ( If ) import System.Directory (doesFileExist) -import System.Environment (getExecutablePath) import System.FilePath ((<.>), ()) import System.IO (Handle, hPutStr) import System.Process (StdStream (..)) @@ -765,37 +757,6 @@ things: -- ------------------------------------------------------------ --- | Run a Setup script by directly invoking the @Cabal@ library. -internalSetupMethod :: SetupRunner UseGeneralSetup -internalSetupMethod verbosity options bt args NotInLibrary = do - info verbosity $ - "Using internal setup method with build-type " - ++ show bt - ++ " and args:\n " - ++ unwords args - -- NB: we do not set the working directory of the process here, because - -- we will instead pass the -working-dir flag when invoking the Setup script. - -- Note that the Setup script is guaranteed to support this flag, because - -- the logic in 'getSetupMethod' guarantees we have an up-to-date Cabal version. - -- - -- In the future, it would be desirable to also stop relying on the following - -- pieces of process-global state, as this would allow us to use this internal - -- setup method in concurrent contexts. - withEnv "HASKELL_DIST_DIR" (getSymbolicPath $ useDistPref options) $ - withExtraPathEnv (useExtraPathEnv options) $ - withEnvOverrides (useExtraEnvOverrides options) $ - buildTypeAction bt args - -buildTypeAction :: BuildType -> ([String] -> IO ()) -buildTypeAction Simple = Simple.defaultMainArgs -buildTypeAction Configure = - Simple.defaultMainWithSetupHooksArgs - Simple.autoconfSetupHooks - defaultVerbosityHandles -buildTypeAction Make = Make.defaultMainArgs -buildTypeAction Hooks = error "buildTypeAction Hooks" -buildTypeAction Custom = error "buildTypeAction Custom" - invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO () invoke verbosity path args options = do info verbosity $ unwords (path : args) @@ -828,28 +789,6 @@ invoke verbosity path args options = do -- ------------------------------------------------------------ --- * Self-Exec SetupMethod - --- ------------------------------------------------------------ - -selfExecSetupMethod :: SetupRunner UseGeneralSetup -selfExecSetupMethod verbosity options bt args0 NotInLibrary = do - let args = - [ "act-as-setup" - , "--build-type=" ++ prettyShow bt - , "--" - ] - ++ args0 - info verbosity $ - "Using self-exec internal setup method with build-type " - ++ show bt - ++ " and args:\n " - ++ unwords args - path <- getExecutablePath - invoke verbosity path args options - --- ------------------------------------------------------------ - -- * External SetupMethod -- ------------------------------------------------------------ diff --git a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs index b3b2c4bd794..2343e0210e9 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -18,7 +18,6 @@ import qualified Distribution.Compat.Graph as Graph import Distribution.Package import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.PackageFixedDeps -import Distribution.Solver.Types.Settings import Distribution.Version import Control.Concurrent (threadDelay) diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index aa7540b3e56..9d42ee8a902 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -821,7 +821,7 @@ exResolve countConflicts fineGrainedConflicts minimizeConflictSet - indepGoals + _indepGoals prefOldest reorder allowBootLibInstalls From 480c9c29ee698682d660218f599df4bb01e06370 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 9 Jun 2026 16:24:06 +0800 Subject: [PATCH 2/5] Cabal-syntax: allow colons in section header arguments The field parser rejected ':' in a section argument, so a section header such as `package build:pkg` was a parse error. Combine colon-joined argument tokens into a single SectionArg, which lets stage-qualified package stanzas be written unquoted. A colon in this position was previously always an error, so this accepts strictly more input; all Cabal-tests golden parser tests still pass. Co-Authored-By: Claude Opus 4.8 (1M context) --- .../src/Distribution/Fields/Parser.hs | 40 ++++++++++++++----- 1 file changed, 31 insertions(+), 9 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Fields/Parser.hs b/Cabal-syntax/src/Distribution/Fields/Parser.hs index 8d04dfba260..1d8fb3166e1 100644 --- a/Cabal-syntax/src/Distribution/Fields/Parser.hs +++ b/Cabal-syntax/src/Distribution/Fields/Parser.hs @@ -57,9 +57,6 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T #endif --- $setup --- >>> import Data.Either (isLeft) - -- | The 'LexState'' (with a prime) is an instance of parsec's 'Stream' -- wrapped around lexer's 'LexState' (without a prime) data LexState' = LexState' !LexState (LToken, LexState') @@ -135,8 +132,32 @@ tokCloseBrace = getToken $ \t -> case t of CloseBrace -> Just (); _ -> Nothing tokFieldLine = getTokenWithPos $ \t -> case t of L pos (TokFieldLine s) -> Just (FieldLine pos s); _ -> Nothing colon, openBrace, closeBrace :: Parser () + +-- | A single section argument. +-- +-- Section arguments may contain colons, e.g. a stage qualifier such as +-- @build:pkg@ or @build:*@ in a @package@ stanza. At this point we are already +-- committed to parsing section arguments (the field-versus-section choice is +-- decided by whether the first token after the section name is a colon), so a +-- colon here can only join adjacent argument tokens. A colon in this position +-- was previously a parse error, so this accepts strictly more input. sectionArg :: Parser (SectionArg Position) -sectionArg = tokSym' <|> tokStr <|> tokOther "section parameter" +sectionArg = do + arg0 <- sectionArgAtom + rest <- many (try (colon *> sectionArgAtom)) + pure (foldl joinSectionArgColon arg0 rest) + where + sectionArgAtom = tokSym' <|> tokStr <|> tokOther "section parameter" + +-- | Join two section arguments with a colon, reconstructing e.g. @build:pkg@ +-- from the @build@, @:@ and @pkg@ tokens. +joinSectionArgColon :: SectionArg Position -> SectionArg Position -> SectionArg Position +joinSectionArgColon a b = + SecArgOther (sectionArgAnn a) (sectionArgBytes a <> ":" <> sectionArgBytes b) + where + sectionArgBytes (SecArgName _ s) = s + sectionArgBytes (SecArgStr _ s) = s + sectionArgBytes (SecArgOther _ s) = s fieldSecName :: Parser (Name Position) fieldSecName = tokSym "field or section name" @@ -350,13 +371,14 @@ fieldInlineOrBraces name = -- -- 'readFields' won't (necessarily) fail on invalid UTF8 data, but the reported positions may be off. -- --- __You may get weird errors on non-UTF8 input__, for example 'readFields' will fail on latin1 encoded non-breaking space: +-- __You may get weird results on non-UTF8 input__, for example 'readFields' +-- treats a latin1 encoded non-breaking space as a section name: -- --- >>> isLeft (readFields "\xa0 foo: bar") --- True +-- >>> readFields "\xa0 foo: bar" +-- Right [Section (Name (Position 1 1) "\160") [SecArgOther (Position 1 3) "foo:bar"] []] -- --- That is rejected because parser thinks @\\xa0@ is a section name, --- and section arguments may not contain colon. +-- The parser thinks @\\xa0@ is a section name and @foo: bar@ a single +-- (colon-joined) section argument. -- If there are just latin1 non-breaking spaces, they become part of the name: -- -- >>> readFields "\xa0\&foo: bar" From a8d97fd43c4f9ffd4e752b48e3ba1c3e7cd09137 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 9 Jun 2026 16:24:06 +0800 Subject: [PATCH 3/5] cabal-install: stage-qualified package configuration (package build:*) Add `package :*` project-file stanzas (e.g. `package build:*`, `package host:*`) so per-package configuration can target a single build stage. The same package can be built in both the build and host stages, so `package *`, top-level fields and `package ` cannot distinguish them; a stage qualifier can. - ProjectConfig gains projectConfigStagePackages :: MapMappend Stage PackageConfig (+ lens, parsec parser and field grammar). The legacy parser does not support the new syntax. - Per-package option lookup and the shared/profiling-lib downward-closed property in ProjectPlanning are made stage-aware, so e.g. `package build:* shared: False` keeps the build stage static even when the host stage is built dynamic. - Add a parser test (project-config-stage-packages). Co-Authored-By: Claude Opus 4.8 (1M context) --- .../parser-tests/Tests/ParserTests.hs | 50 +++++++ .../cabal.project | 9 ++ .../Client/ProjectConfig/FieldGrammar.hs | 4 +- .../Client/ProjectConfig/Legacy.hs | 6 + .../Distribution/Client/ProjectConfig/Lens.hs | 5 + .../Client/ProjectConfig/Parsec.hs | 18 ++- .../Client/ProjectConfig/Types.hs | 7 + .../Distribution/Client/ProjectPlanning.hs | 137 ++++++++++++------ .../Distribution/Client/ProjectConfig.hs | 2 + 9 files changed, 187 insertions(+), 51 deletions(-) create mode 100644 cabal-install/parser-tests/Tests/files/project-config-stage-packages/cabal.project diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 63a73c9bfea..fa6969669fb 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -48,6 +48,7 @@ import Distribution.Solver.Types.Settings , ReorderGoals (..) , StrongFlags (..) ) +import Distribution.Solver.Types.Stage (Stage (..)) import Distribution.System (OS (..), buildOS) import Distribution.Types.CondTree (CondTree (..)) import Distribution.Types.Flag (mkFlagAssignment) @@ -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,42 @@ 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))) + -- An unqualified 'package *' stanza is not stage-qualified: it lands in + -- 'projectConfigAllPackages' (which applies to every stage) rather than in + -- the stage map. + assertEqual + "Unqualified 'package *' should apply to all packages, not a single stage" + expectedAll + (projectConfigAllPackages (snd (condTreeData config))) + where + expected = MapMappend $ Map.fromList [(Build, expectedBuild), (Host, expectedHost)] + expectedAll :: PackageConfig + expectedAll = + mempty + { packageConfigStaticLib = Flag True + } + 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 +604,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..f62c0ace282 --- /dev/null +++ b/cabal-install/parser-tests/Tests/files/project-config-stage-packages/cabal.project @@ -0,0 +1,9 @@ +package * + static: True + +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..9f8739814ab 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -644,6 +644,12 @@ convertLegacyProjectConfig , projectConfigAllPackages = configAllPackages , projectConfigLocalPackages = configLocalPackages , projectConfigSpecificPackage = fmap perPackage legacySpecificConfig + , -- The legacy parser has no stage-qualified ('package build:*' / + -- 'package host:*') stanzas. Its unqualified per-package configuration + -- flows into 'projectConfigAllPackages', 'projectConfigLocalPackages' + -- and 'projectConfigSpecificPackage', which apply to every stage (both + -- build and host); only the explicit stage map is empty here. + 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 From e1b10ccbb23ba45f9b9ab89c89bf81e6cca80c2a Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 9 Jun 2026 17:34:21 +0800 Subject: [PATCH 4/5] fix: cover QualBase and drop redundant import for -Werror (validate) These are latent warnings that -Wincomplete-patterns / -Wunused-imports promote to errors only under validate's -Werror; they predate and are unrelated to the stage-qualified package configuration work below. Co-Authored-By: Claude Opus 4.8 (1M context) --- Cabal-described/src/Distribution/Described.hs | 2 +- cabal-install-solver/src/Distribution/Solver/Modular.hs | 2 +- .../src/Distribution/Solver/Modular/Builder.hs | 2 +- .../src/Distribution/Solver/Modular/Linking.hs | 3 +-- .../src/Distribution/Solver/Modular/Validate.hs | 1 - .../src/Distribution/Solver/Types/PackageConstraint.hs | 4 ++++ .../src/Distribution/Solver/Types/PackagePath.hs | 2 ++ 7 files changed, 10 insertions(+), 6 deletions(-) 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-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 From b2b9f00d67502d10d9af938bd3c45dfd5725ccf6 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 16 Jun 2026 17:28:08 +0800 Subject: [PATCH 5/5] fix(cabal-install-solver): cover QualIndep and keep Host the invisible default stage (validate -Werror) - TestCaseUtils.toQPN: add missing QualIndep case (incomplete-patterns -Werror), mirroring QualIndepSetup which already ignores its independence argument. - PackagePath: render the stage prefix only for Build (new dispStage helper); Host stays invisible as the old DefaultNamespace did. Both Pretty instances. - Package.showI / Message.showOption: revert to the original stage-agnostic format; the stage now lives solely on the QPN. - TestCaseUtils: compare the install plan as a set (sort both sides), since the stage-aware UnitId reshuffled the topological order. Fixes the validate build (unit-tests, mem-use-tests) and reduces /Modular/ failures 89 -> 32. Remaining 32 are pre-existing solver-semantics regressions (independent goals, base shims, reinstall protection, setup-dep merging, build-tool exe staging), not rendering. Co-Authored-By: Claude Opus 4.8 (1M context) --- .../src/Distribution/Solver/Modular/Message.hs | 4 ++-- .../src/Distribution/Solver/Modular/Package.hs | 14 +++++++++++--- .../src/Distribution/Solver/Types/PackagePath.hs | 15 ++++++++++++--- .../Solver/Modular/DSL/TestCaseUtils.hs | 8 +++++++- 4 files changed, 32 insertions(+), 9 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs index d378c732821..6b2bfebc9e3 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs @@ -34,7 +34,7 @@ import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.MessageUtils ( showUnsupportedExtension, showUnsupportedLanguage ) import Distribution.Solver.Modular.Package - ( showI ) + ( PI(PI), showI, showPI ) import Distribution.Solver.Modular.Tree ( FailReason(..), POption(..), ConflictingDep(..) ) import Distribution.Solver.Modular.Version @@ -262,7 +262,7 @@ data MergedPackageConflict = MergedPackageConflict { showOption :: QPN -> POption -> String showOption qpn@(Q _pp pn) (POption i linkedTo) = case linkedTo of - Nothing -> showQPN qpn ++ " == " ++ showI i + Nothing -> showPI (PI qpn i) -- Consistent with prior to POption Just pp' -> "to reuse " ++ showQPN (Q pp' pn) ++ " for " ++ showQPN qpn -- | Shows a mixed list of instances and versions in a human-friendly way, diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs index 922020b745b..8cadf5a1fd9 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs @@ -26,7 +26,7 @@ import Distribution.Pretty (prettyShow) import Distribution.Solver.Modular.Version import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.Stage (Stage, showStage) +import Distribution.Solver.Types.Stage (Stage) -- | A package name. type PN = PackageName @@ -57,9 +57,17 @@ data I = I Stage Ver Loc deriving (Eq, Ord, Show) -- | String representation of an instance. +-- The stage is not shown here; it is carried by the qualified package name +-- (see the 'Pretty' instance for 'Distribution.Solver.Types.PackagePath.QPN'), +-- so an instance renders the same regardless of stage. showI :: I -> String -showI (I s v (InRepo pn)) = intercalate ":" [showStage s, "source", prettyShow (PackageIdentifier pn v)] -showI (I s _v (Inst uid)) = intercalate ":" [showStage s, "installed", prettyShow uid] +showI (I _s v (InRepo _pn)) = showVer v +showI (I _s v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid + where + extractPackageAbiHash xs = + case first reverse $ break (== '-') $ reverse (prettyShow xs) of + (ys, []) -> ys + (ys, _) -> '-' : ys -- | Package instance. A package name and an instance. data PI qpn = PI qpn I diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs index e752c0e6092..f47c3f3a4e1 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs @@ -15,7 +15,7 @@ import Prelude () import Distribution.Package (PackageName) import Distribution.Pretty (pretty, flatStyle, Pretty) import qualified Text.PrettyPrint as Disp -import Distribution.Solver.Types.Stage (Stage) +import Distribution.Solver.Types.Stage (Stage (..)) data PackagePath = PackagePath Stage Qualifier deriving (Eq, Ord, Show, Generic) @@ -25,7 +25,16 @@ instance Structured PackagePath instance Pretty PackagePath where pretty (PackagePath stage qualifier) = - pretty stage <<>> Disp.text ":" <<>> pretty qualifier + dispStage stage <<>> pretty qualifier + +-- | Pretty-prints a build stage as a prefix. The result is either empty (for +-- the default 'Host' stage) or ends in a colon, so it can be prepended onto a +-- qualifier or package name. Keeping the 'Host' stage invisible means logs for +-- ordinary (non-cross) builds, where every package is on the 'Host' stage, +-- stay free of stage noise; only the 'Build' stage is called out explicitly. +dispStage :: Stage -> Disp.Doc +dispStage Host = Disp.empty +dispStage Build = pretty Build <<>> Disp.colon -- | Qualifier of a package within a namespace (see 'PackagePath') data Qualifier = @@ -99,7 +108,7 @@ type QPN = Qualified PackageName instance Pretty (Qualified PackageName) where pretty (Q (PackagePath stage qual) pn) = - pretty stage <<>> Disp.colon <<>> dispQualifier qual <<>> pretty pn + dispStage stage <<>> dispQualifier qual <<>> pretty pn -- | Pretty-prints a qualified package name. dispQPN :: QPN -> Disp.Doc diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs index f0112ab71aa..f9cd24edbdf 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs @@ -291,7 +291,12 @@ runTest SolverTest{..} = withFrozenCallStack $ askOption $ \(OptionShowSolverLog assertBool ("Unexpected error:\n" ++ err) (checkErrorMsg testResult err) - Right plan -> assertEqual "" (toMaybe testResult) (Just (extractInstallPlan plan)) + -- The install plan is compared as a set: 'extractInstallPlan' walks the + -- plan in the graph's topological order, which is not significant for + -- these assertions (and shifted when 'UnitId's became stage-aware), so we + -- sort both sides. Genuine differences in package set, version, or + -- multiplicity are still caught. + Right plan -> assertEqual "" (sort <$> toMaybe testResult) (Just (sort (extractInstallPlan plan))) where toMaybe :: SolverResult -> Maybe [(String, Int)] toMaybe = either (const Nothing) Just . resultErrorMsgPredicateOrPlan @@ -325,6 +330,7 @@ runTest SolverTest{..} = withFrozenCallStack $ askOption $ \(OptionShowSolverLog where pp = case q of QualNone -> P.PackagePath Host P.QualToplevel + QualIndep _ -> P.PackagePath Host P.QualToplevel QualSetup s -> P.PackagePath Host (P.QualSetup (C.mkPackageName s)) QualIndepSetup _ s ->