From 5457a5992ee0a59b091dc75ad016c88e047e1305 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 19 Mar 2025 16:57:10 +0800 Subject: [PATCH 01/54] refactor(cabal-install,Cabal): move programDbSignature to Cabal --- Cabal/src/Distribution/Simple/Program/Db.hs | 15 +++++++++++++++ .../src/Distribution/Client/ProjectPlanning.hs | 14 -------------- 2 files changed, 15 insertions(+), 14 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs index 929b3dd6372..be1c3ccebfb 100644 --- a/Cabal/src/Distribution/Simple/Program/Db.hs +++ b/Cabal/src/Distribution/Simple/Program/Db.hs @@ -68,6 +68,7 @@ module Distribution.Simple.Program.Db , updateUnconfiguredProgs , updateConfiguredProgs , updatePathProgDb + , programDbSignature ) where import Distribution.Compat.Prelude @@ -604,3 +605,17 @@ requireProgramVersion verbosity prog range programDb = join $ either (dieWithException verbosity) return `fmap` lookupProgramVersion verbosity prog range programDb + +-- | Select the bits of a 'ProgramDb' to monitor for value changes. +-- Use 'programsMonitorFiles' for the files to monitor. +programDbSignature :: ProgramDb -> [ConfiguredProgram] +programDbSignature progdb = + [ prog + { programMonitorFiles = [] + , programOverrideEnv = + filter + ((/= "PATH") . fst) + (programOverrideEnv prog) + } + | prog <- configuredPrograms progdb + ] diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 5be55634324..0ce35d9aa08 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1036,20 +1036,6 @@ programsMonitorFiles progdb = (programPath prog) ] --- | Select the bits of a 'ProgramDb' to monitor for value changes. --- Use 'programsMonitorFiles' for the files to monitor. -programDbSignature :: ProgramDb -> [ConfiguredProgram] -programDbSignature progdb = - [ prog - { programMonitorFiles = [] - , programOverrideEnv = - filter - ((/= "PATH") . fst) - (programOverrideEnv prog) - } - | prog <- configuredPrograms progdb - ] - getInstalledPackages :: Verbosity -> Compiler From 2e332478eb532805b319aeb91a73863efab20c25 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 8 May 2025 15:07:59 +0800 Subject: [PATCH 02/54] refactor(cabal-install): separate GenericReadyPackage from ReadyPackage --- cabal-install/cabal-install.cabal | 1 + .../src/Distribution/Client/Configure.hs | 2 +- .../src/Distribution/Client/Install.hs | 1 + .../src/Distribution/Client/Types.hs | 4 +-- .../Client/Types/GenericReadyPackage.hs | 36 +++++++++++++++++++ .../Distribution/Client/Types/ReadyPackage.hs | 33 +---------------- 6 files changed, 42 insertions(+), 35 deletions(-) create mode 100644 cabal-install/src/Distribution/Client/Types/GenericReadyPackage.hs diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index eeae37f45d5..c6eafc40c31 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -222,6 +222,7 @@ library Distribution.Client.Types.ConfiguredId Distribution.Client.Types.ConfiguredPackage Distribution.Client.Types.Credentials + Distribution.Client.Types.GenericReadyPackage Distribution.Client.Types.InstallMethod Distribution.Client.Types.OverwritePolicy Distribution.Client.Types.PackageLocation diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index 6cc4bfec285..6b396d0eb0c 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -53,7 +53,7 @@ import Distribution.Client.Targets , userToPackageConstraint ) import Distribution.Client.Types as Source - +import Distribution.Client.Types.ReadyPackage (ReadyPackage) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index 4082259c9f5..df030e7a515 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -127,6 +127,7 @@ import Distribution.Client.Tar (extractTarGzFile) import Distribution.Client.Targets import Distribution.Client.Types as Source import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..)) +import Distribution.Client.Types.ReadyPackage (ReadyPackage) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Solver.Types.PackageFixedDeps diff --git a/cabal-install/src/Distribution/Client/Types.hs b/cabal-install/src/Distribution/Client/Types.hs index 841a4dbc9d2..e8647b1edb5 100644 --- a/cabal-install/src/Distribution/Client/Types.hs +++ b/cabal-install/src/Distribution/Client/Types.hs @@ -22,7 +22,7 @@ module Distribution.Client.Types , module Distribution.Client.Types.BuildResults , module Distribution.Client.Types.PackageLocation , module Distribution.Client.Types.PackageSpecifier - , module Distribution.Client.Types.ReadyPackage + , module Distribution.Client.Types.GenericReadyPackage , module Distribution.Client.Types.Repo , module Distribution.Client.Types.RepoName , module Distribution.Client.Types.SourcePackageDb @@ -33,9 +33,9 @@ import Distribution.Client.Types.AllowNewer import Distribution.Client.Types.BuildResults import Distribution.Client.Types.ConfiguredId import Distribution.Client.Types.ConfiguredPackage +import Distribution.Client.Types.GenericReadyPackage import Distribution.Client.Types.PackageLocation import Distribution.Client.Types.PackageSpecifier -import Distribution.Client.Types.ReadyPackage import Distribution.Client.Types.Repo import Distribution.Client.Types.RepoName import Distribution.Client.Types.SourcePackageDb diff --git a/cabal-install/src/Distribution/Client/Types/GenericReadyPackage.hs b/cabal-install/src/Distribution/Client/Types/GenericReadyPackage.hs new file mode 100644 index 00000000000..a8b673cb36b --- /dev/null +++ b/cabal-install/src/Distribution/Client/Types/GenericReadyPackage.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Distribution.Client.Types.GenericReadyPackage + ( GenericReadyPackage (..) + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Package (HasMungedPackageId, HasUnitId, Package, PackageInstalled) + +import Distribution.Solver.Types.PackageFixedDeps + +-- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be +-- installed already, hence itself ready to be installed. +newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'. + deriving + ( Eq + , Show + , Generic + , Package + , PackageFixedDeps + , HasMungedPackageId + , HasUnitId + , PackageInstalled + , Binary + ) + +-- Can't newtype derive this +instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where + type Key (GenericReadyPackage srcpkg) = Key srcpkg + nodeKey (ReadyPackage spkg) = nodeKey spkg + nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg diff --git a/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs b/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs index e04b5af79c8..5eeb8e5e194 100644 --- a/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs +++ b/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs @@ -1,41 +1,10 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - module Distribution.Client.Types.ReadyPackage ( GenericReadyPackage (..) , ReadyPackage ) where -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Compat.Graph (IsNode (..)) -import Distribution.Package (HasMungedPackageId, HasUnitId, Package, PackageInstalled) - import Distribution.Client.Types.ConfiguredPackage (ConfiguredPackage) +import Distribution.Client.Types.GenericReadyPackage (GenericReadyPackage (..)) import Distribution.Client.Types.PackageLocation (UnresolvedPkgLoc) -import Distribution.Solver.Types.PackageFixedDeps - --- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be --- installed already, hence itself ready to be installed. -newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'. - deriving - ( Eq - , Show - , Generic - , Package - , PackageFixedDeps - , HasMungedPackageId - , HasUnitId - , PackageInstalled - , Binary - ) - --- Can't newtype derive this -instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where - type Key (GenericReadyPackage srcpkg) = Key srcpkg - nodeKey (ReadyPackage spkg) = nodeKey spkg - nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc) From 6279d14d349e9f71170877b6812c70144d91d367 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 8 Apr 2025 16:04:17 +0800 Subject: [PATCH 03/54] refactor(cabal-install): resolve package dbs during planning --- .../src/Distribution/Client/PackageHash.hs | 2 +- .../Client/ProjectBuilding/UnpackedPackage.hs | 7 ++--- .../Distribution/Client/ProjectPlanning.hs | 2 +- .../Client/ProjectPlanning/Types.hs | 29 +++++++++---------- 4 files changed, 18 insertions(+), 22 deletions(-) diff --git a/cabal-install/src/Distribution/Client/PackageHash.hs b/cabal-install/src/Distribution/Client/PackageHash.hs index 3a94c0e028b..6ba0bfb98bb 100644 --- a/cabal-install/src/Distribution/Client/PackageHash.hs +++ b/cabal-install/src/Distribution/Client/PackageHash.hs @@ -220,7 +220,7 @@ data PackageHashConfigInputs = PackageHashConfigInputs , pkgHashExtraIncludeDirs :: [FilePath] , pkgHashProgPrefix :: Maybe PathTemplate , pkgHashProgSuffix :: Maybe PathTemplate - , pkgHashPackageDbs :: [Maybe PackageDBCWD] + , pkgHashPackageDbs :: [PackageDBCWD] , -- Haddock options pkgHashDocumentation :: Bool , pkgHashHaddockHoogle :: Bool diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 4168472065f..0cf5aea5308 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -766,11 +766,8 @@ buildAndInstallUnpackedPackage "registerPkg: elab does NOT require registration for " ++ prettyShow uid | otherwise = do - assert - ( elabRegisterPackageDBStack pkg - == storePackageDBStack compiler (elabPackageDbs pkg) - ) - (return ()) + let packageDbStack = elabPackageDbs pkg ++ [storePackageDB storeDirLayout compiler] + assert (elabRegisterPackageDBStack pkg == packageDbStack) (return ()) _ <- runRegister (elabRegisterPackageDBStack pkg) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 0ce35d9aa08..0a4c77add3a 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -2289,7 +2289,7 @@ elaborateInstallPlan if shouldBuildInplaceOnly pkg then BuildInplaceOnly OnDisk else BuildAndInstall - elabPackageDbs = projectConfigPackageDBs sharedPackageConfig + elabPackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs sharedPackageConfig) elabBuildPackageDBStack = buildAndRegisterDbs elabRegisterPackageDBStack = buildAndRegisterDbs diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index adbd8a85f5e..4dffb1c84f7 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -250,21 +250,20 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage -- to disable. This tells us which ones we build by default, and -- helps with error messages when the user asks to build something -- they explicitly disabled. - -- - -- TODO: The 'Bool' here should be refined into an ADT with three - -- cases: NotRequested, ExplicitlyRequested and - -- ImplicitlyRequested. A stanza is explicitly requested if - -- the user asked, for this *specific* package, that the stanza - -- be enabled; it's implicitly requested if the user asked for - -- all global packages to have this stanza enabled. The - -- difference between an explicit and implicit request is - -- error reporting behavior: if a user asks for tests to be - -- enabled for a specific package that doesn't have any tests, - -- we should warn them about it, but we shouldn't complain - -- that a user enabled tests globally, and some local packages - -- just happen not to have any tests. (But perhaps we should - -- warn if ALL local packages don't have any tests.) - , elabPackageDbs :: [Maybe PackageDBCWD] + , -- TODO: The 'Bool' here should be refined into an ADT with three + -- cases: NotRequested, ExplicitlyRequested and + -- ImplicitlyRequested. A stanza is explicitly requested if + -- the user asked, for this *specific* package, that the stanza + -- be enabled; it's implicitly requested if the user asked for + -- all global packages to have this stanza enabled. The + -- difference between an explicit and implicit request is + -- error reporting behavior: if a user asks for tests to be + -- enabled for a specific package that doesn't have any tests, + -- we should warn them about it, but we shouldn't complain + -- that a user enabled tests globally, and some local packages + -- just happen not to have any tests. (But perhaps we should + -- warn if ALL local packages don't have any tests.) + elabPackageDbs :: [PackageDBCWD] , elabSetupPackageDBStack :: PackageDBStackCWD , elabBuildPackageDBStack :: PackageDBStackCWD , elabRegisterPackageDBStack :: PackageDBStackCWD From d4516fff055ea663990ff9b61653cd5dd0b6f1d1 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 5 May 2025 16:31:02 +0800 Subject: [PATCH 04/54] refactor(cabal-install): remove workaround for build tools listed as build dependencies --- cabal-install/src/Distribution/Client/ProjectPlanning.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 0a4c77add3a..42b1ed130da 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1985,15 +1985,10 @@ elaborateInstallPlan external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids - - -- Combine library and build-tool dependencies, for backwards - -- compatibility (See issue #5412 and the documentation for - -- InstallPlan.fromSolverInstallPlan), but prefer the versions - -- specified as build-tools. external_exe_dep_pkgs = concatMap mapDep $ ordNubBy (pkgName . packageId) $ - external_exe_dep_sids ++ external_lib_dep_sids + external_exe_dep_sids external_exe_map = Map.fromList $ From 23b082b947499f3b1e1370cb12c0ff68e4cbbe42 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 5 May 2025 16:31:02 +0800 Subject: [PATCH 05/54] refactor(cabal-install): move elabInstantiatedWith and elabLinkedInstantiatedWith from ElaboratedConfiguredPackage to ElaboratedComponent Instantiation only makes sense for components. --- .../Client/ProjectOrchestration.hs | 10 ++++---- .../Distribution/Client/ProjectPlanning.hs | 25 ++++++++----------- .../Client/ProjectPlanning/Types.hs | 4 +-- 3 files changed, 18 insertions(+), 21 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 12718e4be5f..4b7cca55948 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -1145,17 +1145,17 @@ printPlan , case elabPkgOrComp elab of ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg)) ElabComponent comp -> - "(" ++ showComp elab comp ++ ")" + "(" ++ showComp comp ++ ")" , showFlagAssignment (nonDefaultFlags elab) , showConfigureFlags elab , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab in "(" ++ showBuildStatus buildStatus ++ ")" ] - showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String - showComp elab comp = + showComp :: ElaboratedComponent -> String + showComp comp = maybe "custom" prettyShow (compComponentName comp) - ++ if Map.null (elabInstantiatedWith elab) + ++ if Map.null (compInstantiatedWith comp) then "" else " with " @@ -1163,7 +1163,7 @@ printPlan ", " -- TODO: Abbreviate the UnitIds [ prettyShow k ++ "=" ++ prettyShow v - | (k, v) <- Map.toList (elabInstantiatedWith elab) + | (k, v) <- Map.toList (compInstantiatedWith comp) ] nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 42b1ed130da..0626ca5d3f6 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1805,7 +1805,6 @@ elaborateInstallPlan { elabModuleShape = emptyModuleShape , elabUnitId = notImpl "elabUnitId" , elabComponentId = notImpl "elabComponentId" - , elabLinkedInstantiatedWith = Map.empty , elabInstallDirs = notImpl "elabInstallDirs" , elabPkgOrComp = ElabComponent (ElaboratedComponent{..}) } @@ -1824,14 +1823,11 @@ elaborateInstallPlan compOrderLibDependencies = notImpl "compOrderLibDependencies" -- Not supported: - compExeDependencies :: [a] compExeDependencies = [] - - compExeDependencyPaths :: [a] compExeDependencyPaths = [] - - compPkgConfigDependencies :: [a] compPkgConfigDependencies = [] + compInstantiatedWith = mempty + compLinkedInstantiatedWith = Map.empty notImpl f = error $ @@ -1888,6 +1884,8 @@ elaborateInstallPlan , Just paths <- [Map.lookup (ann_id aid') exe_map1] , path <- paths ] + compInstantiatedWith = Map.empty + compLinkedInstantiatedWith = Map.empty elab_comp = ElaboratedComponent{..} -- 3. Construct a preliminary ElaboratedConfiguredPackage, @@ -1941,7 +1939,6 @@ elaborateInstallPlan { elabModuleShape = lc_shape lc , elabUnitId = abstractUnitId (lc_uid lc) , elabComponentId = lc_cid lc - , elabLinkedInstantiatedWith = Map.fromList (lc_insts lc) , elabPkgOrComp = ElabComponent $ elab_comp @@ -1952,6 +1949,7 @@ elaborateInstallPlan (abstractUnitId . ci_id) (lc_includes lc ++ lc_sig_includes lc) ) + , compLinkedInstantiatedWith = Map.fromList (lc_insts lc) } } elab = @@ -2103,7 +2101,6 @@ elaborateInstallPlan elab0 { elabUnitId = newSimpleUnitId pkgInstalledId , elabComponentId = pkgInstalledId - , elabLinkedInstantiatedWith = Map.empty , elabPkgOrComp = ElabPackage $ ElaboratedPackage{..} , elabModuleShape = modShape } @@ -2208,8 +2205,6 @@ elaborateInstallPlan -- These get filled in later elabUnitId = error "elaborateSolverToCommon: elabUnitId" elabComponentId = error "elaborateSolverToCommon: elabComponentId" - elabInstantiatedWith = Map.empty - elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith" elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp" elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs" elabModuleShape = error "elaborateSolverToCommon: elabModuleShape" @@ -2891,7 +2886,6 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = elab0 { elabUnitId = uid , elabComponentId = cid - , elabInstantiatedWith = fmap fst insts , elabIsCanonical = Map.null (fmap fst insts) , elabPkgOrComp = ElabComponent @@ -2903,6 +2897,7 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = unDefUnitId (deps ++ concatMap (getDep . fst) (Map.elems insts)) ) + , compInstantiatedWith = fmap fst insts } } elab = @@ -3013,8 +3008,8 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = work = for_ pkgs $ \pkg -> case pkg of - InstallPlan.Configured elab - | not (Map.null (elabLinkedInstantiatedWith elab)) -> + InstallPlan.Configured (elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp}) + | not (Map.null (compLinkedInstantiatedWith comp)) -> indefiniteUnitId (elabComponentId elab) >> return () _ -> @@ -4093,7 +4088,9 @@ setupHsConfigureFlags configProfExe = mempty configProf = toFlag $ LBC.withProfExe elabBuildOptions - configInstantiateWith = Map.toList elabInstantiatedWith + configInstantiateWith = case elabPkgOrComp of + ElabPackage _ -> mempty + ElabComponent comp -> Map.toList (compInstantiatedWith comp) configDeterministic = mempty -- doesn't matter, configIPID/configCID overridese configIPID = case elabPkgOrComp of diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 4dffb1c84f7..10171b76adb 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -204,8 +204,6 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage { elabUnitId :: UnitId -- ^ The 'UnitId' which uniquely identifies this item in a build plan , elabComponentId :: ComponentId - , elabInstantiatedWith :: Map ModuleName Module - , elabLinkedInstantiatedWith :: Map ModuleName OpenModule , elabIsCanonical :: Bool -- ^ This is true if this is an indefinite package, or this is a -- package with no signatures. (Notably, it's not true for instantiated @@ -685,6 +683,8 @@ data ElaboratedComponent = ElaboratedComponent -- instantiation phase. It's more precise than -- 'compLibDependencies', and also stores information about internal -- dependencies. + , compInstantiatedWith :: Map ModuleName Module + , compLinkedInstantiatedWith :: Map ModuleName OpenModule , compExeDependencies :: [ConfiguredId] -- ^ The executable dependencies of this component (including -- internal executables). From de98287de34784f4a8fbf5625d47dd10d784c0a6 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 20 Mar 2025 18:23:24 +0800 Subject: [PATCH 06/54] feat(cabal-install-solver): introduce Stage and Toolchain add stages list --- .../cabal-install-solver.cabal | 2 + .../src/Distribution/Solver/Types/Stage.hs | 113 ++++++++++++++++++ .../Distribution/Solver/Types/Toolchain.hs | 39 ++++++ .../Distribution/Client/ArbitraryInstances.hs | 5 + .../Distribution/Client/TreeDiffInstances.hs | 2 + .../Distribution/Solver/Modular/QuickCheck.hs | 8 ++ 6 files changed, 169 insertions(+) create mode 100644 cabal-install-solver/src/Distribution/Solver/Types/Stage.hs create mode 100644 cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs diff --git a/cabal-install-solver/cabal-install-solver.cabal b/cabal-install-solver/cabal-install-solver.cabal index 5d5eaa37e5a..c769c22b506 100644 --- a/cabal-install-solver/cabal-install-solver.cabal +++ b/cabal-install-solver/cabal-install-solver.cabal @@ -95,7 +95,9 @@ library Distribution.Solver.Types.SolverId Distribution.Solver.Types.SolverPackage Distribution.Solver.Types.SourcePackage + Distribution.Solver.Types.Stage Distribution.Solver.Types.SummarizedMessage + Distribution.Solver.Types.Toolchain Distribution.Solver.Types.Variable build-depends: diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs b/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs new file mode 100644 index 00000000000..7ca70f701cc --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveTraversable #-} + +module Distribution.Solver.Types.Stage + ( Stage (..) + , showStage + , stages + , prevStage + , nextStage + , Staged (..) + , tabulate + , foldMapWithKey + , always + ) where + +import Prelude (Enum (..)) +import Distribution.Compat.Prelude +import qualified Distribution.Compat.CharParsing as P + +import Data.Maybe (fromJust) +import GHC.Stack + +import Distribution.Parsec (Parsec (..)) +import Distribution.Pretty (Pretty (..)) +import Distribution.Utils.Structured (Structured (..)) +import qualified Text.PrettyPrint as Disp + + +data Stage + = -- | -- The system where the build is running + Build + | -- | -- The system where the built artifacts will run + Host + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) + +instance Binary Stage +instance Structured Stage + +instance Pretty Stage where + pretty = Disp.text . showStage + +showStage :: Stage -> String +showStage Build = "build" +showStage Host = "host" + +instance Parsec Stage where + parsec = P.choice [ + Build <$ P.string "build", + Host <$ P.string "host" + ] + +stages :: [Stage] +stages = [minBound .. maxBound] + +prevStage :: Stage -> Stage +prevStage s | s == minBound = s + | otherwise = Prelude.pred s +nextStage :: Stage -> Stage +nextStage s | s == maxBound = s + | otherwise = Prelude.succ s + +-- TOOD: I think there is similar code for stanzas, compare. + +newtype Staged a = Staged + { getStage :: Stage -> a + } + deriving (Functor, Generic) + deriving Applicative via ((->) Stage) + +instance Eq a => Eq (Staged a) where + lhs == rhs = + all + (\stage -> getStage lhs stage == getStage rhs stage) + [minBound .. maxBound] + +instance Show a => Show (Staged a) where + showsPrec _ staged = + showList + [ (stage, getStage staged stage) + | stage <- [minBound .. maxBound] + ] + +instance Foldable Staged where + foldMap f (Staged gs) = foldMap (f . gs) [minBound..maxBound] + +instance Traversable Staged where + traverse f = fmap index . traverse (traverse f) . tabulate + +instance Binary a => Binary (Staged a) where + put staged = put (tabulate staged) + -- TODO this could be done better I think + get = index <$> get + +-- TODO: I have no idea if this is right +instance (Typeable a, Structured a) => Structured (Staged a) where + structure _ = structure (Proxy :: Proxy [(Stage, a)]) + +tabulate :: Staged a -> [(Stage, a)] +tabulate staged = + [ (stage, getStage staged stage) + | stage <- [minBound .. maxBound] + ] + +index :: HasCallStack => [(Stage, a)] -> Staged a +index t = Staged (\s -> fromJust (lookup s t)) + +foldMapWithKey :: Monoid m => (Stage -> a -> m) -> Staged a -> m +foldMapWithKey f = foldMap (uncurry f) . tabulate + +always :: a -> Staged a +always = Staged . const diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs b/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs new file mode 100644 index 00000000000..a69963f3a56 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Solver.Types.Toolchain + ( Toolchain (..) + , Toolchains + , Stage (..) + , Staged (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Simple.Compiler +import Distribution.Simple.Program.Db +import Distribution.Solver.Types.Stage (getStage, Stage (..), Staged (..)) +import Distribution.System + +--------------------------- +-- Toolchain +-- + +data Toolchain = Toolchain + { toolchainPlatform :: Platform + , toolchainCompiler :: Compiler + , toolchainProgramDb :: ProgramDb + } + deriving (Show, Generic) + +-- TODO: review this +instance Eq Toolchain where + lhs == rhs = + (((==) `on` toolchainPlatform) lhs rhs) + && (((==) `on` toolchainCompiler) lhs rhs) + && ((((==)) `on` (configuredPrograms . toolchainProgramDb)) lhs rhs) + +instance Binary Toolchain +instance Structured Toolchain + +type Toolchains = Staged Toolchain diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index 5a8945eafe0..5a7daf43cc7 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -44,6 +44,7 @@ import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..), OptionalSt import Distribution.Solver.Types.PackageConstraint (PackageProperty (..)) import Data.Coerce (Coercible, coerce) +import Distribution.Solver.Types.Stage (Stage) import Network.URI (URI (..), URIAuth (..), isUnreserved) import Test.QuickCheck ( Arbitrary (..) @@ -323,6 +324,10 @@ instance Arbitrary a => Arbitrary (OptionalStanzaMap a) where TestStanzas -> x1 BenchStanzas -> x2 +instance Arbitrary Stage where + arbitrary = genericArbitrary + shrink = genericShrink + ------------------------------------------------------------------------------- -- BuildReport ------------------------------------------------------------------------------- diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs index ef4f9fb7c9f..31b46f46a9d 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -9,6 +9,7 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.ProjectConfigPath import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.Stage import Distribution.Client.BuildReports.Types import Distribution.Client.CmdInstall.ClientInstallFlags @@ -74,6 +75,7 @@ instance ToExpr ReorderGoals instance ToExpr RepoIndexState instance ToExpr RepoName instance ToExpr ReportLevel +instance ToExpr Stage instance ToExpr StrongFlags instance ToExpr Timestamp instance ToExpr TotalIndexState diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index ab056c820c9..cbf15810149 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -43,6 +43,7 @@ import Distribution.Solver.Types.Variable import Distribution.Verbosity import Distribution.Version +import Distribution.Solver.Types.Stage (Stage) import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils ( ArbitraryOrd (..) @@ -621,6 +622,12 @@ instance Arbitrary OptionalStanza where shrink BenchStanzas = [TestStanzas] shrink TestStanzas = [] +instance Arbitrary Stage where + arbitrary = elements [minBound .. maxBound] + + shrink stage = + [stage' | stage' <- [minBound .. maxBound], stage' /= stage] + instance ArbitraryOrd pn => ArbitraryOrd (Variable pn) instance ArbitraryOrd a => ArbitraryOrd (P.Qualified a) instance ArbitraryOrd P.PackagePath @@ -633,6 +640,7 @@ instance ArbitraryOrd ShortText where arbitraryCompare = do strc <- arbitraryCompare pure $ \l r -> strc (fromShortText l) (fromShortText r) +instance ArbitraryOrd Stage deriving instance Generic (Variable pn) deriving instance Generic (P.Qualified a) From e7edc74f38ec317e68367833bb3e68792df4bdda Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 2 Apr 2025 14:43:52 +0800 Subject: [PATCH 07/54] feat(cabal-install): introduce ProjectConfigToolchain --- .../Distribution/Solver/Types/Toolchain.hs | 3 + cabal-install/cabal-install.cabal | 1 + .../parser-tests/Tests/ParserTests.hs | 7 +- .../src/Distribution/Client/CmdInstall.hs | 14 ++-- .../src/Distribution/Client/CmdPath.hs | 18 ++--- .../src/Distribution/Client/ProjectConfig.hs | 1 + .../Client/ProjectConfig/FieldGrammar.hs | 22 ++++-- .../Client/ProjectConfig/Legacy.hs | 17 ++--- .../Distribution/Client/ProjectConfig/Lens.hs | 29 ++++++-- .../Client/ProjectConfig/Parsec.hs | 2 +- .../Client/ProjectConfig/Types.hs | 23 +++++- .../Distribution/Client/ProjectPlanning.hs | 74 ++++++++++--------- .../src/Distribution/Client/ScriptUtils.hs | 10 ++- .../src/Distribution/Client/Toolchain.hs | 65 ++++++++++++++++ cabal-install/tests/IntegrationTests2.hs | 3 +- .../Distribution/Client/ProjectConfig.hs | 26 +++++-- .../Distribution/Client/TreeDiffInstances.hs | 1 + 17 files changed, 226 insertions(+), 90 deletions(-) create mode 100644 cabal-install/src/Distribution/Client/Toolchain.hs diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs b/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs index a69963f3a56..6ee663795f4 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs @@ -23,6 +23,9 @@ data Toolchain = Toolchain { toolchainPlatform :: Platform , toolchainCompiler :: Compiler , toolchainProgramDb :: ProgramDb + -- NOTE: actually the solver does not care about package dbs, perhaps it's better + -- to have a separate Toolchain type for project planning. + , toolchainPackageDBs :: PackageDBStackCWD } deriving (Show, Generic) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index c6eafc40c31..5aedd0743a8 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -216,6 +216,7 @@ library Distribution.Client.TargetProblem Distribution.Client.TargetSelector Distribution.Client.Targets + Distribution.Client.Toolchain Distribution.Client.Types Distribution.Client.Types.AllowNewer Distribution.Client.Types.BuildResults diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 34b65edcb5e..7079f2119b9 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -180,6 +180,7 @@ testProjectConfigShared = do assertConfigEquals expected config legacy (projectConfigShared . snd . condTreeData) where expected = ProjectConfigShared{..} + projectConfigToolchain = ProjectConfigToolchain{..} projectConfigDistDir = toFlag "something" projectConfigConfigFile = mempty -- cli only projectConfigProjectFileParser = mempty -- cli only @@ -189,9 +190,13 @@ testProjectConfigShared = do projectConfigHcFlavor = toFlag GHCJS projectConfigHcPath = toFlag "/some/path/to/compiler" projectConfigHcPkg = toFlag "/some/path/to/ghc-pkg" + projectConfigPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")] + projectConfigBuildHcFlavor = toFlag GHCJS + projectConfigBuildHcPath = toFlag "/some/path/to/compiler" + projectConfigBuildHcPkg = toFlag "/some/path/to/ghc-pkg" + projectConfigBuildPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")] projectConfigHaddockIndex = toFlag $ toPathTemplate "/path/to/haddock-index" projectConfigInstallDirs = mempty -- tested below in testInstallDirs - projectConfigPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")] projectConfigRemoteRepos = mempty -- tested below in testRemoteRepos projectConfigLocalNoIndexRepos = mempty -- tested below in testLocalNoIndexRepos projectConfigActiveRepos = Flag (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge, ActiveRepo (RepoName "my-repository") CombineStrategyOverride]) diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 3884bb056e9..b0c1dd236ef 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -65,7 +65,8 @@ import Distribution.Client.NixStyleOptions , nixStyleOptions ) import Distribution.Client.ProjectConfig - ( ProjectPackageLocation (..) + ( ProjectConfigToolchain (..) + , ProjectPackageLocation (..) , fetchAndReadSourcePackages , projectConfigWithBuilderRepoContext , resolveBuildTimeSettings @@ -410,12 +411,15 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project } , projectConfigShared = ProjectConfigShared - { projectConfigHcFlavor - , projectConfigHcPath - , projectConfigHcPkg + { projectConfigToolchain = + ProjectConfigToolchain + { projectConfigHcFlavor + , projectConfigHcPath + , projectConfigHcPkg + , projectConfigPackageDBs + } , projectConfigStoreDir , projectConfigProgPathExtra - , projectConfigPackageDBs } , projectConfigLocalPackages = PackageConfig diff --git a/cabal-install/src/Distribution/Client/CmdPath.hs b/cabal-install/src/Distribution/Client/CmdPath.hs index 6307cc30c64..cfb23c376da 100644 --- a/cabal-install/src/Distribution/Client/CmdPath.hs +++ b/cabal-install/src/Distribution/Client/CmdPath.hs @@ -46,6 +46,9 @@ import Distribution.Client.ScriptUtils import Distribution.Client.Setup ( yesNoOpt ) +import Distribution.Client.Toolchain + ( Toolchain (..) + ) import Distribution.Client.Utils.Json ( (.=) ) @@ -245,17 +248,10 @@ pathAction flags@NixStyleFlags{extraFlags = pathFlags'} cliTargetStrings globalF if not $ fromFlagOrDefault False (pathCompiler pathFlags) then pure Nothing else do - (compiler, _, progDb) <- - runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ - configureCompiler verbosity (distDirLayout baseCtx) (projectConfig baseCtx) - compilerProg <- requireCompilerProg verbosity compiler - (configuredCompilerProg, _) <- requireProgram verbosity compilerProg progDb - - let compilerInfo' = - mkCompilerInfo configuredCompilerProg compiler $ - cabalStoreDirLayout (cabalDirLayout baseCtx) - - pure $ Just compilerInfo' + toolchain <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ configureCompiler verbosity (distDirLayout baseCtx) (projectConfig baseCtx) + compilerProg <- requireCompilerProg verbosity (toolchainCompiler toolchain) + (configuredCompilerProg, _) <- requireProgram verbosity compilerProg (toolchainProgramDb toolchain) + pure $ Just $ mkCompilerInfo configuredCompilerProg (toolchainCompiler toolchain) paths <- for (fromFlagOrDefault [] $ pathDirectories pathFlags) $ \p -> do t <- getPathLocation verbosity baseCtx p diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index c81b9c16535..e7bdb7afd1a 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -14,6 +14,7 @@ module Distribution.Client.ProjectConfig , ProjectConfigBuildOnly (..) , ProjectConfigShared (..) , ProjectConfigSkeleton + , ProjectConfigToolchain (..) , ProjectConfigProvenance (..) , PackageConfig (..) , MapLast (..) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index f49279f7781..221c3f3691c 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -12,7 +12,14 @@ import qualified Data.Set as Set import Distribution.CabalSpecVersion (CabalSpecVersion (..)) import Distribution.Client.CmdInstall.ClientInstallFlags (clientInstallFlagsGrammar) import qualified Distribution.Client.ProjectConfig.Lens as L -import Distribution.Client.ProjectConfig.Types (PackageConfig (..), ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance (..), ProjectConfigShared (..)) +import Distribution.Client.ProjectConfig.Types + ( PackageConfig (..) + , ProjectConfig (..) + , ProjectConfigBuildOnly (..) + , ProjectConfigProvenance (..) + , ProjectConfigShared (..) + , ProjectConfigToolchain (..) + ) import Distribution.Client.Utils.Parsec import Distribution.Compat.Prelude import Distribution.FieldGrammar @@ -76,12 +83,9 @@ projectConfigSharedFieldGrammar source = <*> optionalFieldDefAla "project-file" (alaFlag FilePathNT) L.projectConfigProjectFile mempty <*> pure mempty -- You can't set the parser type in the project file. <*> optionalFieldDef "ignore-project" L.projectConfigIgnoreProject mempty - <*> optionalFieldDef "compiler" L.projectConfigHcFlavor mempty - <*> optionalFieldDefAla "with-compiler" (alaFlag FilePathNT) L.projectConfigHcPath mempty - <*> optionalFieldDefAla "with-hc-pkg" (alaFlag FilePathNT) L.projectConfigHcPkg mempty + <*> blurFieldGrammar L.projectConfigToolchain projectConfigToolchainFieldGrammar <*> optionalFieldDef "doc-index-file" L.projectConfigHaddockIndex mempty <*> blurFieldGrammar L.projectConfigInstallDirs installDirsGrammar - <*> monoidalFieldAla "package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigPackageDBs <*> pure mempty -- repository stanza for projectConfigRemoteRepos <*> pure mempty -- repository stanza for projectConfigLocalNoIndexRepos <*> monoidalField "active-repositories" L.projectConfigActiveRepos @@ -109,6 +113,14 @@ projectConfigSharedFieldGrammar source = <*> monoidalFieldAla "extra-prog-path-shared-only" (alaNubList' FSep FilePathNT) L.projectConfigProgPathExtra <*> optionalFieldDef "multi-repl" L.projectConfigMultiRepl mempty +projectConfigToolchainFieldGrammar :: ParsecFieldGrammar' ProjectConfigToolchain +projectConfigToolchainFieldGrammar = + ProjectConfigToolchain + <$> optionalFieldDef "compiler" L.projectConfigHcFlavor mempty + <*> optionalFieldDefAla "with-compiler" (alaFlag FilePathNT) L.projectConfigHcPath mempty + <*> optionalFieldDefAla "with-hc-pkg" (alaFlag FilePathNT) L.projectConfigHcPkg mempty + <*> monoidalFieldAla "package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigPackageDBs + packageConfigFieldGrammar :: [String] -> ParsecFieldGrammar' PackageConfig packageConfigFieldGrammar knownPrograms = mkPackageConfig diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index fc4faa6a64a..a58e5ef5901 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -380,7 +380,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project modifiesCompiler :: ProjectConfig -> Bool modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg where - isSet f = f (projectConfigShared pc) /= NoFlag + isSet f = f (projectConfigToolchain $ projectConfigShared pc) /= NoFlag sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ProjectParseResult ProjectConfigSkeleton sanityWalkPCS underConditional t@(CondNode (listToMaybe -> c, d) comps) @@ -711,6 +711,7 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags , globalStoreDir = projectConfigStoreDir } = globalFlags + projectConfigToolchain = ProjectConfigToolchain{..} projectConfigPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigPackageDBs_ ConfigFlags @@ -718,10 +719,8 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags , configHcFlavor = projectConfigHcFlavor , configHcPath = projectConfigHcPath , configHcPkg = projectConfigHcPkg - , -- configProgramPathExtra = projectConfigProgPathExtra DELETE ME - configInstallDirs = projectConfigInstallDirs - , -- configUserInstall = projectConfigUserInstall, - configPackageDBs = projectConfigPackageDBs_ + , configInstallDirs = projectConfigInstallDirs + , configPackageDBs = projectConfigPackageDBs_ } = configFlags CommonSetupFlags @@ -962,10 +961,7 @@ convertToLegacySharedConfig ProjectConfig { projectConfigBuildOnly = ProjectConfigBuildOnly{..} , projectConfigShared = ProjectConfigShared{..} - , projectConfigAllPackages = - PackageConfig - { packageConfigDocumentation - } + , projectConfigAllPackages = PackageConfig{..} } = LegacySharedConfig { legacyGlobalFlags = globalFlags @@ -977,6 +973,7 @@ convertToLegacySharedConfig , legacyMultiRepl = projectConfigMultiRepl } where + ProjectConfigToolchain{..} = projectConfigToolchain globalFlags = GlobalFlags { globalVersion = mempty @@ -1083,6 +1080,8 @@ convertToLegacyAllPackageConfig , legacyBenchmarkFlags = mempty } where + ProjectConfigToolchain{..} = projectConfigToolchain + commonFlags = mempty diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index 03164305a62..7b2c63a78d0 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -7,7 +7,16 @@ import Distribution.Client.IndexUtils.ActiveRepos ( ActiveRepos ) import Distribution.Client.IndexUtils.IndexState (TotalIndexState) -import Distribution.Client.ProjectConfig.Types (MapLast, MapMappend, PackageConfig, ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance, ProjectConfigShared) +import Distribution.Client.ProjectConfig.Types + ( MapLast + , MapMappend + , PackageConfig + , ProjectConfig (..) + , ProjectConfigBuildOnly (..) + , ProjectConfigProvenance + , ProjectConfigShared + , ProjectConfigToolchain (..) + ) import qualified Distribution.Client.ProjectConfig.Types as T import Distribution.Client.Targets (UserConstraint) import Distribution.Client.Types.AllowNewer (AllowNewer, AllowOlder) @@ -192,18 +201,26 @@ projectConfigIgnoreProject :: Lens' ProjectConfigShared (Flag Bool) projectConfigIgnoreProject f s = fmap (\x -> s{T.projectConfigIgnoreProject = x}) (f (T.projectConfigIgnoreProject s)) {-# INLINEABLE projectConfigIgnoreProject #-} -projectConfigHcFlavor :: Lens' ProjectConfigShared (Flag CompilerFlavor) +projectConfigToolchain :: Lens' ProjectConfigShared ProjectConfigToolchain +projectConfigToolchain f s = fmap (\x -> s{T.projectConfigToolchain = x}) (f (T.projectConfigToolchain s)) +{-# INLINEABLE projectConfigToolchain #-} + +projectConfigHcFlavor :: Lens' ProjectConfigToolchain (Flag CompilerFlavor) projectConfigHcFlavor f s = fmap (\x -> s{T.projectConfigHcFlavor = x}) (f (T.projectConfigHcFlavor s)) {-# INLINEABLE projectConfigHcFlavor #-} -projectConfigHcPath :: Lens' ProjectConfigShared (Flag FilePath) +projectConfigHcPath :: Lens' ProjectConfigToolchain (Flag FilePath) projectConfigHcPath f s = fmap (\x -> s{T.projectConfigHcPath = x}) (f (T.projectConfigHcPath s)) {-# INLINEABLE projectConfigHcPath #-} -projectConfigHcPkg :: Lens' ProjectConfigShared (Flag FilePath) +projectConfigHcPkg :: Lens' ProjectConfigToolchain (Flag FilePath) projectConfigHcPkg f s = fmap (\x -> s{T.projectConfigHcPkg = x}) (f (T.projectConfigHcPkg s)) {-# INLINEABLE projectConfigHcPkg #-} +projectConfigPackageDBs :: Lens' ProjectConfigToolchain [Maybe PackageDBCWD] +projectConfigPackageDBs f s = fmap (\x -> s{T.projectConfigPackageDBs = x}) (f (T.projectConfigPackageDBs s)) +{-# INLINEABLE projectConfigPackageDBs #-} + projectConfigHaddockIndex :: Lens' ProjectConfigShared (Flag PathTemplate) projectConfigHaddockIndex f s = fmap (\x -> s{T.projectConfigHaddockIndex = x}) (f (T.projectConfigHaddockIndex s)) {-# INLINEABLE projectConfigHaddockIndex #-} @@ -212,10 +229,6 @@ projectConfigInstallDirs :: Lens' ProjectConfigShared (InstallDirs (Flag PathTem projectConfigInstallDirs f s = fmap (\x -> s{T.projectConfigInstallDirs = x}) (f (T.projectConfigInstallDirs s)) {-# INLINEABLE projectConfigInstallDirs #-} -projectConfigPackageDBs :: Lens' ProjectConfigShared [Maybe PackageDBCWD] -projectConfigPackageDBs f s = fmap (\x -> s{T.projectConfigPackageDBs = x}) (f (T.projectConfigPackageDBs s)) -{-# INLINEABLE projectConfigPackageDBs #-} - projectConfigLocalNoIndexRepos :: Lens' ProjectConfigShared (NubList LocalRepo) projectConfigLocalNoIndexRepos f s = fmap (\x -> s{T.projectConfigLocalNoIndexRepos = x}) (f (T.projectConfigLocalNoIndexRepos s)) {-# INLINEABLE projectConfigLocalNoIndexRepos #-} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 90740fc7a93..0576186de29 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -210,7 +210,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project modifiesCompiler :: ProjectConfig -> Bool modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg where - isSet f = f (projectConfigShared pc) /= NoFlag + isSet f = f (projectConfigToolchain (projectConfigShared pc)) /= NoFlag sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ParseResult ProjectFileSource ProjectConfigSkeleton sanityWalkPCS underConditional t@(CondNode (_c, d) comps) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index 751875be403..0e20180800a 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -9,6 +9,7 @@ module Distribution.Client.ProjectConfig.Types , ProjectConfigToParse (..) , ProjectConfigBuildOnly (..) , ProjectConfigShared (..) + , ProjectConfigToolchain (..) , ProjectConfigProvenance (..) , PackageConfig (..) , ProjectFileParser (..) @@ -194,16 +195,13 @@ data ProjectConfigShared = ProjectConfigShared , projectConfigProjectFile :: Flag FilePath , projectConfigProjectFileParser :: Flag ProjectFileParser , projectConfigIgnoreProject :: Flag Bool - , projectConfigHcFlavor :: Flag CompilerFlavor - , projectConfigHcPath :: Flag FilePath - , projectConfigHcPkg :: Flag FilePath + , projectConfigToolchain :: ProjectConfigToolchain , projectConfigHaddockIndex :: Flag PathTemplate , -- Only makes sense for manual mode, not --local mode -- too much control! -- projectConfigUserInstall :: Flag Bool, projectConfigInstallDirs :: InstallDirs (Flag PathTemplate) - , projectConfigPackageDBs :: [Maybe PackageDBCWD] , -- configuration used both by the solver and other phases projectConfigRemoteRepos :: NubList RemoteRepo -- ^ Available Hackage servers. @@ -243,6 +241,14 @@ data ProjectConfigShared = ProjectConfigShared } deriving (Eq, Show, Generic) +data ProjectConfigToolchain = ProjectConfigToolchain + { projectConfigHcFlavor :: Flag CompilerFlavor + , projectConfigHcPath :: Flag FilePath + , projectConfigHcPkg :: Flag FilePath + , projectConfigPackageDBs :: [Maybe PackageDBCWD] + } + deriving (Eq, Show, Generic) + data ProjectFileParser = LegacyParser | ParsecParser @@ -347,6 +353,7 @@ data PackageConfig = PackageConfig instance Binary ProjectConfig instance Binary ProjectConfigBuildOnly +instance Binary ProjectConfigToolchain instance Binary ProjectConfigShared instance Binary ProjectConfigProvenance instance Binary PackageConfig @@ -354,6 +361,7 @@ instance Binary ProjectFileParser instance Structured ProjectConfig instance Structured ProjectConfigBuildOnly +instance Structured ProjectConfigToolchain instance Structured ProjectConfigShared instance Structured ProjectConfigProvenance instance Structured PackageConfig @@ -422,6 +430,13 @@ instance Monoid ProjectConfigBuildOnly where instance Semigroup ProjectConfigBuildOnly where (<>) = gmappend +instance Monoid ProjectConfigToolchain where + mempty = gmempty + mappend = (<>) + +instance Semigroup ProjectConfigToolchain where + (<>) = gmappend + instance Monoid ProjectConfigShared where mempty = gmempty mappend = (<>) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 0626ca5d3f6..62bc636b5ba 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -136,6 +136,7 @@ import Distribution.Client.Setup hiding (cabalVersion, packageName) import Distribution.Client.SetupWrapper import Distribution.Client.Store import Distribution.Client.Targets (userToPackageConstraint) +import Distribution.Client.Toolchain import Distribution.Client.Types import Distribution.Client.Utils (concatMapM, incVersion) @@ -379,9 +380,9 @@ rebuildProjectConfig configPath <- getConfigFilePath verbosity projectConfigConfigFile return ( configPath - , distProjectFileMain distProjectFile - , (projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg) + , distProjectFile "" , projectConfigProjectFileParser + , projectConfigToolchain , progsearchpath , packageConfigProgramPaths , packageConfigProgramPathExtra @@ -400,8 +401,9 @@ rebuildProjectConfig let fetchCompiler = do -- have to create the cache directory before configuring the compiler liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (snd (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) - pure (os, arch, compiler) + Toolchain{toolchainCompiler, toolchainPlatform = Platform arch os} <- + configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) + pure (os, arch, toolchainCompiler) (projectConfig, compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton when (projectConfigDistDir (projectConfigShared projectConfig) /= NoFlag) $ @@ -414,7 +416,7 @@ rebuildProjectConfig return (projectConfig <> cliConfig, localPackages) where - ProjectConfigShared{projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg, projectConfigProjectFileParser, projectConfigIgnoreProject, projectConfigConfigFile} = + ProjectConfigShared{projectConfigProjectFileParser, projectConfigIgnoreProject, projectConfigConfigFile, projectConfigToolchain} = projectConfigShared cliConfig PackageConfig{packageConfigProgramPaths, packageConfigProgramPathExtra} = @@ -504,7 +506,7 @@ configureCompiler :: Verbosity -> DistDirLayout -> ProjectConfig - -> Rebuild (Compiler, Platform, ProgramDb) + -> Rebuild Toolchain configureCompiler verbosity DistDirLayout @@ -513,9 +515,7 @@ configureCompiler ProjectConfig { projectConfigShared = ProjectConfigShared - { projectConfigHcFlavor - , projectConfigHcPath - , projectConfigHcPkg + { projectConfigToolchain , projectConfigProgPathExtra } , projectConfigLocalPackages = @@ -528,7 +528,7 @@ configureCompiler progsearchpath <- liftIO getSystemSearchPath - (hc, plat, hcProgDb) <- + (toolchainCompiler, toolchainPlatform, tempProgDb) <- rerunIfChanged verbosity fileMonitorCompiler @@ -568,12 +568,13 @@ configureCompiler -- auxiliary unconfigured programs to the ProgramDb (e.g. hc-pkg, haddock, ar, ld...). -- -- See Note [Caching the result of configuring the compiler] - finalProgDb <- liftIO $ Cabal.configCompilerProgDb verbosity hc hcProgDb hcPkg - return (hc, plat, finalProgDb) + toolchainProgramDb <- liftIO $ Cabal.configCompilerProgDb verbosity toolchainCompiler tempProgDb hcPkg + let toolchainPackageDBs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs projectConfigToolchain) + return Toolchain{..} where - hcFlavor = flagToMaybe projectConfigHcFlavor - hcPath = flagToMaybe projectConfigHcPath - hcPkg = flagToMaybe projectConfigHcPkg + hcFlavor = flagToMaybe (projectConfigHcFlavor projectConfigToolchain) + hcPath = flagToMaybe (projectConfigHcPath projectConfigToolchain) + hcPkg = flagToMaybe (projectConfigHcPkg projectConfigToolchain) {- Note [Caching the result of configuring the compiler] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -678,12 +679,12 @@ rebuildInstallPlan , progsearchpath ) $ do - compilerEtc <- phaseConfigureCompiler projectConfig - _ <- phaseConfigurePrograms projectConfig compilerEtc + toolchain <- phaseConfigureCompiler projectConfig + _ <- phaseConfigurePrograms projectConfig toolchain (solverPlan, pkgConfigDB, totalIndexState, activeRepos) <- phaseRunSolver projectConfig - compilerEtc + toolchain localPackages (fromMaybe mempty mbInstalledPackages) ( elaboratedPlan @@ -691,7 +692,7 @@ rebuildInstallPlan ) <- phaseElaboratePlan projectConfig - compilerEtc + toolchain pkgConfigDB solverPlan localPackages @@ -721,7 +722,7 @@ rebuildInstallPlan -- phaseConfigureCompiler :: ProjectConfig - -> Rebuild (Compiler, Platform, ProgramDb) + -> Rebuild Toolchain phaseConfigureCompiler = configureCompiler verbosity distDirLayout -- Configuring other programs. @@ -738,16 +739,16 @@ rebuildInstallPlan -- phaseConfigurePrograms :: ProjectConfig - -> (Compiler, Platform, ProgramDb) + -> Toolchain -> Rebuild () - phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do + phaseConfigurePrograms projectConfig toolchain = do -- Users are allowed to specify program locations independently for -- each package (e.g. to use a particular version of a pre-processor -- for some packages). However they cannot do this for the compiler -- itself as that's just not going to work. So we check for this. liftIO $ checkBadPerPackageCompilerPaths - (configuredPrograms compilerprogdb) + (configuredPrograms (toolchainProgramDb toolchain)) (getMapMappend (projectConfigSpecificPackage projectConfig)) -- TODO: [required eventually] find/configure other programs that the @@ -761,7 +762,7 @@ rebuildInstallPlan -- phaseRunSolver :: ProjectConfig - -> (Compiler, Platform, ProgramDb) + -> Toolchain -> [PackageSpecifier UnresolvedSourcePackage] -> InstalledPackageIndex -> Rebuild (SolverInstallPlan, Maybe PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) @@ -770,7 +771,12 @@ rebuildInstallPlan { projectConfigShared , projectConfigBuildOnly } - (compiler, platform, progdb) + Toolchain + { toolchainCompiler = compiler + , toolchainPlatform = platform + , toolchainProgramDb = progdb + } + -- \^ The compiler and platform to use for the solver. localPackages installedPackages = rerunIfChanged @@ -826,7 +832,7 @@ rebuildInstallPlan where corePackageDbs :: PackageDBStackCWD corePackageDbs = - Cabal.interpretPackageDbFlags False (projectConfigPackageDBs projectConfigShared) + Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain projectConfigShared)) withRepoCtx :: (RepoContext -> IO a) -> IO a withRepoCtx = @@ -875,7 +881,7 @@ rebuildInstallPlan -- phaseElaboratePlan :: ProjectConfig - -> (Compiler, Platform, ProgramDb) + -> Toolchain -> Maybe PkgConfigDb -> SolverInstallPlan -> [PackageSpecifier (SourcePackage (PackageLocation loc))] @@ -891,7 +897,7 @@ rebuildInstallPlan , projectConfigSpecificPackage , projectConfigBuildOnly } - (compiler, platform, progdb) + Toolchain{..} pkgConfigDB solverPlan localPackages = do @@ -904,15 +910,15 @@ rebuildInstallPlan (packageLocationsSignature solverPlan) $ getPackageSourceHashes verbosity withRepoCtx solverPlan - defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler + defaultInstallDirs <- liftIO $ userInstallDirTemplates toolchainCompiler let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) (elaboratedPlan, elaboratedShared) <- liftIO . runLogProgress verbosity $ elaborateInstallPlan verbosity - platform - compiler - progdb + toolchainPlatform + toolchainCompiler + toolchainProgramDb pkgConfigDB distDirLayout cabalStoreDirLayout @@ -2279,7 +2285,7 @@ elaborateInstallPlan if shouldBuildInplaceOnly pkg then BuildInplaceOnly OnDisk else BuildAndInstall - elabPackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs sharedPackageConfig) + elabPackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain sharedPackageConfig)) elabBuildPackageDBStack = buildAndRegisterDbs elabRegisterPackageDBStack = buildAndRegisterDbs @@ -2472,7 +2478,7 @@ elaborateInstallPlan corePackageDbs ++ [distPackageDB (compilerId compiler)] - corePackageDbs = storePackageDBStack compiler (projectConfigPackageDBs sharedPackageConfig) + corePackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain sharedPackageConfig)) ++ [storePackageDB storeDirLayout compiler] -- For this local build policy, every package that lives in a local source -- dir (as opposed to a tarball), or depends on such a package, will be diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index c4f2925651e..b92c4c47836 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -83,6 +83,9 @@ import Distribution.Client.TargetSelector ( TargetSelectorProblem (..) , TargetString (..) ) +import Distribution.Client.Toolchain + ( Toolchain (..) + ) import Distribution.Client.Types ( PackageLocation (..) , PackageSpecifier (..) @@ -376,13 +379,14 @@ withContextAndSelectors verbosity noTargets kind flags@NixStyleFlags{..} targetS projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx) - (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (snd (ignoreConditions projectCfgSkeleton) <> projectConfig ctx) + Toolchain{toolchainCompiler, toolchainPlatform = toolchainPlatform@(Platform arch os)} <- + runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx) - (projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compiler)) mempty projectCfgSkeleton + (projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, toolchainCompiler)) mempty projectCfgSkeleton let ctx' = ctx & lProjectConfig %~ (<> projectCfg) - build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' compiler platform + build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' toolchainCompiler toolchainPlatform exePath = build_dir "bin" scriptExeFileName script exePathRel = makeRelative (normalise projectRoot) exePath diff --git a/cabal-install/src/Distribution/Client/Toolchain.hs b/cabal-install/src/Distribution/Client/Toolchain.hs new file mode 100644 index 00000000000..f3c44e76fc8 --- /dev/null +++ b/cabal-install/src/Distribution/Client/Toolchain.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Distribution.Client.Toolchain + ( Stage (..) + , Staged (..) + , Toolchain (..) + , mkProgramDb + , configToolchain + , module Distribution.Solver.Types.Stage + , module Distribution.Solver.Types.Toolchain + ) +where + +import Distribution.Simple.Compiler (interpretPackageDBStack) +import Distribution.Simple.Configure +import Distribution.Simple.Program (ProgArg) +import Distribution.Simple.Program.Db +import Distribution.Simple.Setup +import Distribution.Solver.Types.Stage +import Distribution.Solver.Types.Toolchain +import Distribution.Utils.NubList +import Distribution.Verbosity (Verbosity) + +mkProgramDb + :: Verbosity + -> [FilePath] + -> [(String, FilePath)] + -> [(String, [ProgArg])] + -> IO ProgramDb +mkProgramDb verbosity extraSearchPath extraPaths extraArgs = do + progdb <- prependProgramSearchPath verbosity extraSearchPath [] defaultProgramDb + -- ProgramDb with directly user specified paths + return $ + userSpecifyPaths extraPaths $ + userSpecifyArgss extraArgs progdb + +-- | Configure the toolchain +configToolchain :: ConfigFlags -> IO Toolchain +configToolchain configFlags@ConfigFlags{..} = do + programDb <- + mkProgramDb + verbosity + (fromNubList configProgramPathExtra) + configProgramPaths + configProgramArgs + + (toolchainCompiler, toolchainPlatform, progdb) <- + configCompilerEx + (flagToMaybe configHcFlavor) + (flagToMaybe configHcPath) + (flagToMaybe configHcPkg) + programDb + verbosity + + -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the + -- future. + toolchainProgramDb <- configureAllKnownPrograms verbosity progdb + let toolchainPackageDBs = interpretPackageDBStack Nothing $ interpretPackageDbFlags False $ configPackageDBs + + return Toolchain{..} + where + -- FIXME + verbosity = fromFlag (configVerbosity configFlags) diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 10ab16806ab..b6d656adb16 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -2312,7 +2312,8 @@ mkProjectConfig (GhcPath ghcPath) = mempty { projectConfigShared = mempty - { projectConfigHcPath = maybeToFlag ghcPath + { projectConfigToolchain = + mempty{projectConfigHcPath = maybeToFlag ghcPath} } , projectConfigBuildOnly = mempty diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 2b98aa05432..73c7188b06f 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -587,6 +587,22 @@ instance Arbitrary ProjectConfigBuildOnly where preShrink_NumJobs = fmap (fmap Positive) postShrink_NumJobs = fmap (fmap getPositive) +instance Arbitrary ProjectConfigToolchain where + arbitrary = do + projectConfigHcFlavor <- arbitrary + projectConfigHcPath <- arbitraryFlag arbitraryShortToken + projectConfigHcPkg <- arbitraryFlag arbitraryShortToken + projectConfigPackageDBs <- shortListOf 2 arbitrary + return ProjectConfigToolchain{..} + + shrink ProjectConfigToolchain{..} = + runShrinker $ + pure ProjectConfigToolchain + <*> shrinker projectConfigHcFlavor + <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath + <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg + <*> shrinker projectConfigPackageDBs + instance Arbitrary ProjectConfigShared where arbitrary = do projectConfigDistDir <- arbitraryFlag arbitraryShortToken @@ -595,12 +611,9 @@ instance Arbitrary ProjectConfigShared where projectConfigProjectFile <- arbitraryFlag arbitraryShortToken projectConfigProjectFileParser <- arbitraryFlag arbitrary projectConfigIgnoreProject <- arbitrary - projectConfigHcFlavor <- arbitrary - projectConfigHcPath <- arbitraryFlag arbitraryShortToken - projectConfigHcPkg <- arbitraryFlag arbitraryShortToken + projectConfigToolchain <- arbitrary projectConfigHaddockIndex <- arbitrary projectConfigInstallDirs <- fixInstallDirs <$> arbitrary - projectConfigPackageDBs <- shortListOf 2 arbitrary projectConfigRemoteRepos <- arbitrary projectConfigLocalNoIndexRepos <- arbitrary projectConfigActiveRepos <- arbitrary @@ -642,12 +655,9 @@ instance Arbitrary ProjectConfigShared where <*> shrinker projectConfigProjectFile <*> shrinker projectConfigProjectFileParser <*> shrinker projectConfigIgnoreProject - <*> shrinker projectConfigHcFlavor - <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath - <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg + <*> shrinker projectConfigToolchain <*> shrinker projectConfigHaddockIndex <*> shrinker projectConfigInstallDirs - <*> shrinker projectConfigPackageDBs <*> shrinker projectConfigRemoteRepos <*> shrinker projectConfigLocalNoIndexRepos <*> shrinker projectConfigActiveRepos diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs index 31b46f46a9d..545e33c0449 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -64,6 +64,7 @@ instance ToExpr ProjectConfig instance ToExpr ProjectConfigBuildOnly instance ToExpr ProjectConfigProvenance instance ToExpr ProjectConfigShared +instance ToExpr ProjectConfigToolchain instance ToExpr ProjectFileParser instance ToExpr RelaxDepMod instance ToExpr RelaxDeps From 039160a39b8dd05cceae99581a7d0271077a7de8 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Fri, 21 Mar 2025 18:11:01 +0800 Subject: [PATCH 08/54] cross-compile: make solver stage-aware Replace `Namespace` in `PackagePath` with `Stage`, so every node in the solver decision tree carries a `Host`/`Build` tag. This allows the solver to maintain separate installed-package indexes, compiler infos, and pkg-config databases for each build stage. - `PackagePath` now holds a `Stage` instead of a `Namespace` (`DefaultNamespace`/`Independent`), eliminating the old namespace concept - `DependencyResolver` and `resolveDependencies` take `Staged` versions of `(CompilerInfo, Platform)`, `InstalledPackageIndex`, and `PkgConfigDb` - Index conversion (`convPIs`, `convIPI'`) iterates over both stages, tagging each installed package with its origin stage - Validation (`Validate.hs`) extracts the stage from each `PackagePath` to select the right extension/language/pkg-config checker - `runSolver`/`solve` signatures updated accordingly --- .../src/Distribution/Solver/Modular.hs | 31 ++-- .../Distribution/Solver/Modular/Builder.hs | 78 ++++----- .../Solver/Modular/ConfiguredConversion.hs | 32 ++-- .../Distribution/Solver/Modular/Dependency.hs | 73 ++++----- .../Distribution/Solver/Modular/Explore.hs | 2 +- .../Solver/Modular/IndexConversion.hs | 90 +++++++---- .../Distribution/Solver/Modular/Message.hs | 6 +- .../Distribution/Solver/Modular/Package.hs | 16 +- .../Distribution/Solver/Modular/Preference.hs | 16 +- .../src/Distribution/Solver/Modular/Solver.hs | 15 +- .../Distribution/Solver/Modular/Validate.hs | 71 ++++++--- .../Solver/Types/ConstraintSource.hs | 5 + .../Solver/Types/DependencyResolver.hs | 12 +- .../Solver/Types/InstSolverPackage.hs | 4 + .../Solver/Types/PackageConstraint.hs | 8 +- .../Distribution/Solver/Types/PackagePath.hs | 71 +++++---- .../Solver/Types/SolverPackage.hs | 4 + .../src/Distribution/Client/Configure.hs | 9 +- .../src/Distribution/Client/Dependency.hs | 149 ++++++++---------- .../src/Distribution/Client/Fetch.hs | 11 +- .../src/Distribution/Client/Freeze.hs | 9 +- cabal-install/src/Distribution/Client/Get.hs | 3 +- .../src/Distribution/Client/Install.hs | 8 +- .../Distribution/Client/ProjectPlanning.hs | 16 +- .../Distribution/Solver/Modular/DSL.hs | 28 ++-- .../Solver/Modular/DSL/TestCaseUtils.hs | 21 +-- .../Distribution/Solver/Modular/QuickCheck.hs | 4 - 27 files changed, 422 insertions(+), 370 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index edcca8e764d..5d80036d0ec 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs @@ -39,6 +39,8 @@ import Distribution.Solver.Modular.IndexConversion ( convPIs ) import Distribution.Solver.Modular.Log ( SolverFailure(..), displayLogMessages ) +import Distribution.Solver.Modular.Message + ( renderSummarizedMessage ) import Distribution.Solver.Modular.Package ( PN ) import Distribution.Solver.Modular.RetryLog @@ -65,25 +67,26 @@ import Distribution.Solver.Types.Progress ( Progress(..), foldProgress ) import Distribution.Solver.Types.SummarizedMessage ( SummarizedMessage(StringMsg) ) -import Distribution.Solver.Types.Variable ( Variable(..) ) -import Distribution.System - ( Platform(..) ) +import Distribution.Solver.Types.Variable + ( Variable(..) ) +import Distribution.Solver.Types.Toolchain + import Distribution.Simple.Setup ( BooleanFlag(..) ) import Distribution.Simple.Utils ( ordNubBy ) -import Distribution.Verbosity -import Distribution.Solver.Modular.Message ( renderSummarizedMessage ) +import Distribution.Verbosity ( normal, verbose ) -- | Ties the two worlds together: classic cabal-install vs. the modular -- solver. Performs the necessary translations before and after. modularResolver :: SolverConfig -> DependencyResolver loc -modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns = - uncurry postprocess <$> -- convert install plan - solve' sc cinfo idx pkgConfigDB pprefs gcs pns - where +modularResolver sc toolchains pkgConfigDbs iidx sidx pprefs pcs pns = do + uncurry postprocess <$> solve' sc cinfo pkgConfigDbs idx pprefs gcs pns + where + cinfo = fst <$> toolchains + -- Indices have to be converted into solver-specific uniform index. - idx = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx + idx = convPIs toolchains gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx -- Constraints have to be converted into a finite map indexed by PN. gcs = M.fromListWith (++) (map pair pcs) where @@ -133,21 +136,21 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns -- complete, i.e., it shows the whole chain of dependencies from the user -- targets to the conflicting packages. solve' :: SolverConfig - -> CompilerInfo + -> Staged CompilerInfo + -> Staged (Maybe PkgConfigDb) -> Index - -> Maybe PkgConfigDb -> (PN -> PackagePreferences) -> Map PN [LabeledPackageConstraint] -> Set PN -> Progress SummarizedMessage String (Assignment, RevDepMap) -solve' sc cinfo idx pkgConfigDB pprefs gcs pns = +solve' sc cinfo pkgConfigDb idx pprefs gcs pns = toProgress $ retry (runSolver printFullLog sc) createErrorMsg where runSolver :: Bool -> SolverConfig -> RetryLog SummarizedMessage SolverFailure (Assignment, RevDepMap) runSolver keepLog sc' = displayLogMessages keepLog $ - solve sc' cinfo idx pkgConfigDB pprefs gcs pns + solve sc' cinfo pkgConfigDb idx pprefs gcs pns createErrorMsg :: SolverFailure -> RetryLog SummarizedMessage String (Assignment, RevDepMap) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs index d12feaf7b1d..2ea62ec4ed9 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs @@ -1,6 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - +{-# LANGUAGE NamedFieldPuns #-} module Distribution.Solver.Modular.Builder ( buildTree , splits -- for testing @@ -37,7 +36,7 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.ComponentDeps import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.Settings +import qualified Distribution.Solver.Types.Stage as Stage -- | All state needed to build and link the search tree. It has a type variable -- because the linking phase doesn't need to know about the state used to build @@ -142,40 +141,42 @@ addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals }) -- If we have already picked a goal, then the choice depends on the kind -- of goal. --- --- For a package, we look up the instances available in the global info, --- and then handle each instance in turn. -addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) = - case M.lookup pn idx of - Nothing -> FailF - (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr) - UnknownPackage - Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) -> - ([], POption i Nothing, bs { next = Instance qpn info })) - (M.toList pis))) - -- TODO: data structure conversion is rather ugly here - --- For a flag, we create only two subtrees, and we create them in the order --- that is indicated by the flag default. -addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) = - FChoiceF qfn rdm gr weak m b (W.fromList - [([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals }), - ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })]) - where - trivial = L.null t && L.null f - weak = WeakOrTrivial $ unWeakOrTrivial w || trivial - --- For a stanza, we also create only two subtrees. The order is initially --- False, True. This can be changed later by constraints (force enabling --- the stanza by replacing the False branch with failure) or preferences --- (try enabling the stanza if possible by moving the True branch first). - -addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) = - SChoiceF qsn rdm gr trivial (W.fromList - [([0], False, bs { next = Goals }), - ([1], True, (extendOpen qpn t bs) { next = Goals })]) - where - trivial = WeakOrTrivial (L.null t) +addChildren bs@(BS { rdeps, index, next = OneGoal goal }) = + case goal of + PkgGoal qpn@(Q (PackagePath s _) pn) gr -> + -- For a package goal, we look up the instances available in the global + -- info, and then handle each instance in turn. + case M.lookup pn index of + Nothing -> FailF + (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr) + UnknownPackage + Just pis -> PChoiceF qpn rdeps gr $ W.fromList + [ ([], POption i Nothing, bs { next = Instance qpn info }) + | (i@(I s' _ver _loc), info) <- M.toList pis + -- Only instances belonging to the same stage are allowed. + , s == s' + ] + -- For a flag, we create only two subtrees, and we create them in the order + -- that is indicated by the flag default. + FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr -> + FChoiceF qfn rdeps gr weak m b $ W.fromList + [ ([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals }) + , ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals }) + ] + where + trivial = L.null t && L.null f + weak = WeakOrTrivial $ unWeakOrTrivial w || trivial + -- For a stanza, we also create only two subtrees. The order is initially + -- False, True. This can be changed later by constraints (force enabling + -- the stanza by replacing the False branch with failure) or preferences + -- (try enabling the stanza if possible by moving the True branch first). + StanzaGoal qsn@(SN qpn _) t gr -> + SChoiceF qsn rdeps gr trivial $ W.fromList + [ ([0], False, bs { next = Goals }) + , ([1], True, (extendOpen qpn t bs) { next = Goals }) + ] + where + trivial = WeakOrTrivial (L.null t) -- For a particular instance, we change the state: we update the scope, -- and furthermore we update the set of goals. @@ -264,8 +265,7 @@ buildTree idx (IndependentGoals ind) igs = where topLevelGoal qpn = PkgGoal qpn UserGoal - qpns | ind = L.map makeIndependent igs - | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs + qpns = L.map (Q (PackagePath Stage.Host QualToplevel)) igs {------------------------------------------------------------------------------- Goals diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs index 0e2e8ad5baa..72eedf3ceaa 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs @@ -6,8 +6,6 @@ import Data.Maybe import Prelude hiding (pi) import Data.Either (partitionEithers) -import Distribution.Package (UnitId, packageId) - import qualified Distribution.Simple.PackageIndex as SI import Distribution.Solver.Modular.Configured @@ -21,41 +19,45 @@ import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Stage (Staged (..)) -- | Converts from the solver specific result @CP QPN@ into -- a 'ResolverPackage', which can then be converted into -- the install plan. -convCP :: SI.InstalledPackageIndex -> +convCP :: Staged SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> CP QPN -> ResolverPackage loc convCP iidx sidx (CP qpi fa es ds) = - case convPI qpi of - Left pi -> PreExisting $ + case qpi of + -- Installed + (PI qpn (I s _ (Inst pi))) -> + PreExisting $ InstSolverPackage { - instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi, + instSolverStage = s, + instSolverQPN = qpn, + instSolverPkgIPI = fromMaybe (error "convCP: lookupUnitId failed") $ SI.lookupUnitId (getStage iidx s) pi, instSolverPkgLibDeps = fmap fst ds', instSolverPkgExeDeps = fmap snd ds' } - Right pi -> Configured $ + -- "In repo" i.e. a source package + (PI qpn@(Q _path pn) (I s v (InRepo _pn))) -> + let pi = PackageIdentifier pn v in + Configured $ SolverPackage { - solverPkgSource = srcpkg, + solverPkgStage = s, + solverPkgQPN = qpn, + solverPkgSource = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi, solverPkgFlags = fa, solverPkgStanzas = es, solverPkgLibDeps = fmap fst ds', solverPkgExeDeps = fmap snd ds' } - where - srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi where ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -}) ds' = fmap (partitionEithers . map convConfId) ds -convPI :: PI QPN -> Either UnitId PackageId -convPI (PI _ (I _ (Inst pi))) = Left pi -convPI pi = Right (packageId (either id id (convConfId pi))) - convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -} -convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) = +convConfId (PI (Q (PackagePath _stage q) pn) (I _stage' v loc)) = case loc of Inst pi -> Left (PreExistingId sourceId pi) _otherwise diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs index fff2dacde4e..8c141222ad1 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs @@ -58,6 +58,7 @@ import Distribution.Solver.Types.PackagePath import Distribution.Types.LibraryName import Distribution.Types.PkgconfigVersionRange import Distribution.Types.UnqualComponentName +import Distribution.Solver.Types.Stage {------------------------------------------------------------------------------- Constrained instances @@ -90,9 +91,10 @@ data FlaggedDep qpn = Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) -- | Dependencies which are conditional on whether or not a stanza -- (e.g., a test suite or benchmark) is enabled. - | Stanza (SN qpn) (TrueFlaggedDeps qpn) - -- | Dependencies which are always enabled, for the component 'comp'. - | Simple (LDep qpn) Component + Stanza (SN qpn) (TrueFlaggedDeps qpn) + | -- | Dependencies which are always enabled, for the component 'comp'. + Simple (LDep qpn) Component + deriving Show -- | Conservatively flatten out flagged dependencies -- @@ -115,15 +117,21 @@ type FalseFlaggedDeps qpn = FlaggedDeps qpn -- depending; having a 'Functor' instance makes bugs where we don't distinguish -- these two far too likely. (By rights 'LDep' ought to have two type variables.) data LDep qpn = LDep (DependencyReason qpn) (Dep qpn) + deriving Show -- | A dependency (constraint) associates a package name with a constrained -- instance. It can also represent other types of dependencies, such as -- dependencies on language extensions. -data Dep qpn = Dep (PkgComponent qpn) CI -- ^ dependency on a package component - | Ext Extension -- ^ dependency on a language extension - | Lang Language -- ^ dependency on a language version - | Pkg PkgconfigName PkgconfigVersionRange -- ^ dependency on a pkg-config package - deriving Functor +data Dep qpn + = -- | dependency on a package component + Dep (PkgComponent qpn) CI + | -- | dependency on a language extension + Ext Extension + | -- | dependency on a language version + Lang Language + | -- | dependency on a pkg-config package + Pkg PkgconfigName PkgconfigVersionRange + deriving (Functor, Show) -- | An exposed component within a package. This type is used to represent -- build-depends and build-tool-depends dependencies. @@ -174,8 +182,8 @@ data QualifyOptions = QO { -- -- NOTE: It's the _dependencies_ of a package that may or may not be independent -- from the package itself. Package flag choices must of course be consistent. -qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps PN -> FlaggedDeps QPN -qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go +qualifyDeps :: QPN -> FlaggedDeps PN -> FlaggedDeps QPN +qualifyDeps (Q pp@(PackagePath s q) pn) = go where go :: FlaggedDeps PN -> FlaggedDeps QPN go = map go1 @@ -197,37 +205,20 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go goLDep (LDep dr dep) comp = LDep (fmap (Q pp) dr) (goD dep comp) goD :: Dep PN -> Component -> Dep QPN - goD (Ext ext) _ = Ext ext - goD (Lang lang) _ = Lang lang - goD (Pkg pkn vr) _ = Pkg pkn vr - goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ = - Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci - goD (Dep dep@(PkgComponent qpn (ExposedLib _)) ci) comp - | qBase qpn = Dep (Q (PackagePath ns (QualBase pn)) <$> dep) ci - | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci - | otherwise = Dep (Q (PackagePath ns inheritedQ ) <$> dep) ci - - -- If P has a setup dependency on Q, and Q has a regular dependency on R, then - -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup - -- dependency on R. We do not do this for the base qualifier however. - -- - -- The inherited qualifier is only used for regular dependencies; for setup - -- and base dependencies we override the existing qualifier. See #3160 for - -- a detailed discussion. - inheritedQ :: Qualifier - inheritedQ = case q of - QualSetup _ -> q - QualExe _ _ -> q - QualToplevel -> q - QualBase _ -> QualToplevel - - -- Should we qualify this goal with the 'Base' package path? - qBase :: PN -> Bool - qBase dep = qoBaseShim && unPackageName dep == "base" - - -- Should we qualify this goal with the 'Setup' package path? - qSetup :: Component -> Bool - qSetup comp = qoSetupIndependent && comp == ComponentSetup + goD (Ext ext) _ = Ext ext + goD (Lang lang) _ = Lang lang + goD (Pkg pkn vr) _ = Pkg pkn vr + + -- In case of executable and setup dependencies, we need to qualify the dependency + -- with the previsous stage (e.g. Host -> Build). + goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _component = + Dep (Q (PackagePath (prevStage s) (QualExe pn qpn)) <$> dep) ci + + goD (Dep dep@(PkgComponent _qpn (ExposedLib _)) ci) ComponentSetup = + Dep (Q (PackagePath (prevStage s) (QualSetup pn)) <$> dep) ci + + goD (Dep dep@(PkgComponent _qpn _) ci) _component = + Dep (Q (PackagePath s q) <$> dep) ci -- | Remove qualifiers from set of dependencies -- diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs index aa3d361a562..1a85feac1b8 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs @@ -268,7 +268,7 @@ exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx -- Skipping it is an optimization. If false, it returns a new conflict set -- to be merged with the previous one. couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet - couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts = + couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I _stage v _) _) conflicts = let (PInfo deps _ _ _) = idx M.! pn M.! i qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs index f150235631f..83d3d51ce12 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs @@ -34,6 +34,7 @@ import Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackageIndex as CI import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Stage (Stage(..), Staged(..), stages) import Distribution.Solver.Modular.Dependency as D import Distribution.Solver.Modular.Flag as F @@ -56,24 +57,31 @@ import qualified Distribution.Types.BuildInfo.Lens as L -- resolving these situations. However, the right thing to do is to -- fix the problem there, so for now, shadowing is only activated if -- explicitly requested. -convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] - -> ShadowPkgs -> StrongFlags -> SolveExecutables - -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) - -> Index -convPIs os arch comp constraints sip strfl solveExes iidx sidx = +convPIs + :: Staged (CompilerInfo, Platform) + -> Map PN [LabeledPackageConstraint] + -> ShadowPkgs + -> StrongFlags + -> SolveExecutables + -> Staged SI.InstalledPackageIndex + -> CI.PackageIndex (SourcePackage loc) + -> Index +convPIs toolchains' constraints sip strfl solveExes iidx sidx = mkIndex $ - convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx + convIPI' sip iidx ++ convSPI' toolchains' constraints strfl solveExes sidx -- | Convert a Cabal installed package index to the simpler, -- more uniform index format of the solver. -convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)] -convIPI' (ShadowPkgs sip) idx = +convIPI' :: ShadowPkgs -> Staged SI.InstalledPackageIndex -> [(PN, I, PInfo)] +convIPI' (ShadowPkgs sip) sipi = -- apply shadowing whenever there are multiple installed packages with -- the same version - [ maybeShadow (convIP idx pkg) + [ maybeShadow (convIP stage idx pkg) -- IMPORTANT to get internal libraries. See -- Note [Index conversion with internal libraries] - | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx + | stage <- stages + , let idx = getStage sipi stage + , (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ] where @@ -83,16 +91,16 @@ convIPI' (ShadowPkgs sip) idx = shadow x = x -- | Extract/recover the package ID from an installed package info, and convert it to a solver's I. -convId :: IPI.InstalledPackageInfo -> (PN, I) -convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi) +convId :: Stage -> IPI.InstalledPackageInfo -> (PN, I) +convId stage ipi = (pn, I stage ver $ Inst $ IPI.installedUnitId ipi) where MungedPackageId mpn ver = mungedId ipi -- HACK. See Note [Index conversion with internal libraries] pn = encodeCompatPackageName mpn -- | Convert a single installed package into the solver-specific format. -convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo) -convIP idx ipi = - case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of +convIP :: Stage -> SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo) +convIP stage idx ipi = + case traverse (convIPId stage (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of Left u -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u))) Right fds -> (pn, i, PInfo fds components M.empty Nothing) where @@ -104,7 +112,7 @@ convIP idx ipi = , compIsBuildable = IsBuildable True } - (pn, i) = convId ipi + (pn, i) = convId stage ipi -- 'sourceLibName' is unreliable, but for now we only really use this for -- primary libs anyways @@ -144,41 +152,54 @@ convIP idx ipi = -- May return Nothing if the package can't be found in the index. That -- indicates that the original package having this dependency is broken -- and should be ignored. -convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN) -convIPId dr comp idx ipid = +convIPId :: Stage -> DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN) +convIPId stage dr comp idx ipid = case SI.lookupUnitId idx ipid of Nothing -> Left ipid - Just ipi -> let (pn, i) = convId ipi - name = ExposedLib LMainLibName -- TODO: Handle sub-libraries. + Just ipi -> let (pn, i) = convId stage ipi + name = ExposedLib LMainLibName -- TODO: Handle sub-libraries. in Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp) -- NB: something we pick up from the -- InstalledPackageIndex is NEVER an executable -- | Convert a cabal-install source package index to the simpler, -- more uniform index format of the solver. -convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] - -> StrongFlags -> SolveExecutables - -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)] -convSPI' os arch cinfo constraints strfl solveExes = - L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages +-- NOTE: The package description of source package can depent on the platform +-- and compiler version. Here we decide to convert a single source package +-- into multiple index entries, one for each stage, where the conditionals are +-- resolved. This choice might incour in high memory consumption and it might +-- be worth looking for a different approach. +convSPI' + :: Staged (CompilerInfo, Platform) + -> Map PN [LabeledPackageConstraint] + -> StrongFlags + -> SolveExecutables + -> CI.PackageIndex (SourcePackage loc) + -> [(PN, I, PInfo)] +convSPI' toolchains constraints strfl solveExes sidx = + concat $ + [ map (convSP stage os arch cinfo constraints strfl solveExes) (CI.allPackages sidx) + | stage <- stages + , let (cinfo, Platform arch os) = getStage toolchains stage + ] -- | Convert a single source package into the solver-specific format. -convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] +convSP :: Stage -> OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo) -convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = - let i = I pv InRepo +convSP stage os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = + let i = I stage pv (InRepo pn) pkgConstraints = fromMaybe [] $ M.lookup pn constraints - in (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd) + in (pn, i, convGPD stage os arch cinfo pkgConstraints strfl solveExes pn gpd) -- We do not use 'flattenPackageDescription' or 'finalizePD' -- from 'Distribution.PackageDescription.Configuration' here, because we -- want to keep the condition tree, but simplify much of the test. -- | Convert a generic package description to a solver-specific 'PInfo'. -convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] +convGPD :: Stage -> OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription -> PInfo -convGPD os arch cinfo constraints strfl solveExes pn +convGPD stage os arch cinfo constraints strfl solveExes pn (GenericPackageDescription pkg scannedVersion flags mlib sub_libs flibs exes tests benchs) = let fds = flagInfo strfl flags @@ -236,7 +257,7 @@ convGPD os arch cinfo constraints strfl solveExes pn , compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False } - testCondition = testConditionForComponent os arch cinfo constraints + testCondition = testConditionForComponent stage os arch cinfo constraints isPrivate LibraryVisibilityPrivate = True isPrivate LibraryVisibilityPublic = False @@ -249,14 +270,15 @@ convGPD os arch cinfo constraints strfl solveExes pn -- before dependency solving. Additionally, this function only considers flags -- that are set by unqualified flag constraints, and it doesn't check the -- intra-package dependencies of a component. -testConditionForComponent :: OS +testConditionForComponent :: Stage + -> OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] -> (a -> Bool) -> CondTree ConfVar a -> Maybe Bool -testConditionForComponent os arch cinfo constraints p tree = +testConditionForComponent _stage os arch cinfo constraints p tree = case go $ extractCondition p tree of Lit True -> Just True Lit False -> Just False diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs index 5dbcce9194c..5f17428c8bd 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 - ( PI(PI), showI, showPI ) + ( showI ) import Distribution.Solver.Modular.Tree ( FailReason(..), POption(..), ConflictingDep(..) ) import Distribution.Solver.Modular.Version @@ -262,8 +262,8 @@ data MergedPackageConflict = MergedPackageConflict { showOption :: QPN -> POption -> String showOption qpn@(Q _pp pn) (POption i linkedTo) = case linkedTo of - Nothing -> showPI (PI qpn i) -- Consistent with prior to POption - Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i) + Nothing -> showQPN qpn ++ " == " ++ showI i + Just pp' -> showQPN qpn ++ " ~> " ++ showQPN (Q pp' pn) -- | Shows a mixed list of instances and versions in a human-friendly way, -- abbreviated. diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs index 876ac2d790c..0121e596e65 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs @@ -27,6 +27,7 @@ import Distribution.Pretty (prettyShow) import Distribution.Solver.Modular.Version import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.Stage (Stage, showStage) -- | A package name. type PN = PackageName @@ -49,22 +50,17 @@ type PId = UnitId -- package instance via its 'PId'. -- -- TODO: More information is needed about the repo. -data Loc = Inst PId | InRepo +data Loc = Inst PId | InRepo PackageName deriving (Eq, Ord, Show) -- | Instance. A version number and a location. -data I = I Ver Loc +data I = I Stage Ver Loc deriving (Eq, Ord, Show) -- | String representation of an instance. showI :: I -> String -showI (I v InRepo) = showVer v -showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid - where - extractPackageAbiHash xs = - case first reverse $ break (=='-') $ reverse (prettyShow xs) of - (ys, []) -> ys - (ys, _) -> '-' : ys +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] -- | Package instance. A package name and an instance. data PI qpn = PI qpn I @@ -75,7 +71,7 @@ showPI :: PI QPN -> String showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i instI :: I -> Bool -instI (I _ (Inst _)) = True +instI (I _ _ (Inst _)) = True instI _ = False instUid :: UnitId -> I -> Bool diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs index e33eb09524f..9dad77e15f3 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs @@ -72,7 +72,7 @@ addWeight :: (PN -> [Ver] -> POption -> Weight) -> EndoTreeTrav d c addWeight f = addWeights [f] version :: POption -> Ver -version (POption (I v _) _) = v +version (POption (I _ v _) _) = v -- | Prefer to link packages whenever possible. preferLinked :: EndoTreeTrav d c @@ -139,7 +139,7 @@ preferPackagePreferences pcs = -- Prefer installed packages over non-installed packages. installed :: POption -> Weight - installed (POption (I _ (Inst _)) _) = 0 + installed (POption (I _ _ (Inst _)) _) = 0 installed _ = 1 -- | Traversal that tries to establish package stanza enable\/disable @@ -184,7 +184,7 @@ processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint s else r where go :: I -> PackageProperty -> Tree d c - go (I v _) (PackagePropertyVersion vr) + go (I _ v _) (PackagePropertyVersion vr) | checkVR vr v = r | otherwise = Fail c (GlobalConstraintVersion vr src) go _ PackagePropertyInstalled @@ -341,10 +341,10 @@ avoidReinstalls p = go | otherwise = PChoiceF qpn rdm gr cs where disableReinstalls = - let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ] + let installed = [ v | (_, POption (I _ v (Inst _)) _, _) <- W.toList cs ] in W.mapWithKey (notReinstall installed) cs - notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs = + notReinstall vs (POption (I _ v (InRepo _pn)) _) _ | v `elem` vs = Fail (varToConflictSet (P qpn)) CannotReinstall notReinstall _ _ x = x @@ -423,9 +423,9 @@ deferSetupExeChoices = go go x = x noSetupOrExe :: Goal QPN -> Bool - noSetupOrExe (Goal (P (Q (PackagePath _ns (QualSetup _)) _)) _) = False - noSetupOrExe (Goal (P (Q (PackagePath _ns (QualExe _ _)) _)) _) = False - noSetupOrExe _ = True + noSetupOrExe (Goal (P (Q (PackagePath _ (QualSetup _)) _)) _) = False + noSetupOrExe (Goal (P (Q (PackagePath _ (QualExe _ _)) _)) _) = False + noSetupOrExe _ = True -- | Transformation that tries to avoid making weak flag choices early. -- Weak flags are trivial flags (not influencing dependencies) or such diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs index d16fb37af37..71e7611fbac 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs @@ -44,11 +44,12 @@ import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.PSQ as PSQ import Distribution.Simple.Setup (BooleanFlag(..)) +import Distribution.Solver.Types.Stage (Staged, Stage(..)) #ifdef DEBUG_TRACETREE import qualified Distribution.Solver.Modular.ConflictSet as CS import qualified Distribution.Solver.Modular.WeightedPSQ as W -import qualified Distribution.Deprecated.Text as T +import Distribution.Solver.Modular.Version (showVer) import Debug.Trace.Tree (gtraceJson) import Debug.Trace.Tree.Simple @@ -89,14 +90,14 @@ newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool -- before exploration. -- solve :: SolverConfig -- ^ solver parameters - -> CompilerInfo + -> Staged CompilerInfo + -> Staged (Maybe PkgConfigDb) -> Index -- ^ all available packages as an index - -> Maybe PkgConfigDb -- ^ available pkg-config pkgs -> (PN -> PackagePreferences) -- ^ preferences -> M.Map PN [LabeledPackageConstraint] -- ^ global constraints -> S.Set PN -- ^ global goals -> RetryLog Message SolverFailure (Assignment, RevDepMap) -solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = +solve sc cinfo pkgConfigDB idx userPrefs userConstraints userGoals = explorePhase . traceTree "cycles.json" id . detectCycles . @@ -137,7 +138,7 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = P.enforceManualFlags userConstraints validationCata = P.enforceSingleInstanceRestriction . validateLinking idx . - validateTree cinfo idx pkgConfigDB + validateTree cinfo pkgConfigDB idx prunePhase = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) . (case onlyConstrained sc of OnlyConstrainedAll -> @@ -203,7 +204,7 @@ instance GSimpleTree (Tree d c) where -- Show package choice goP :: QPN -> POption -> Tree d c -> (String, SimpleTree) - goP _ (POption (I ver _loc) Nothing) subtree = (T.display ver, go subtree) + goP _ (POption (I _stage ver _loc) Nothing) subtree = (showVer ver, go subtree) goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree) -- Show flag or stanza choice @@ -250,5 +251,5 @@ _removeGR = trav go dummy = DependencyGoal $ DependencyReason - (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$")) + (Q (PackagePath Host QualToplevel) (mkPackageName "$")) M.empty S.empty diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs index ed01234bdba..6cbe81424e7 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs @@ -35,6 +35,7 @@ import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) import Distribution.Types.LibraryName import Distribution.Types.PkgconfigVersionRange +import Distribution.Solver.Types.Stage (Staged (..), Stage (..)) -- In practice, most constraints are implication constraints (IF we have made -- a number of choices, THEN we also have to ensure that). We call constraints @@ -88,9 +89,9 @@ import Distribution.Types.PkgconfigVersionRange -- | The state needed during validation. data ValidateState = VS { - supportedExt :: Extension -> Bool, - supportedLang :: Language -> Bool, - presentPkgs :: Maybe (PkgconfigName -> PkgconfigVersionRange -> Bool), + supportedExt :: Stage -> Extension -> Bool, + supportedLang :: Stage -> Language -> Bool, + presentPkgs :: Stage -> Maybe (PkgconfigName -> PkgconfigVersionRange -> Bool), index :: Index, -- Saved, scoped, dependencies. Every time 'validate' makes a package choice, @@ -191,7 +192,7 @@ validate = go -- What to do for package nodes ... goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) - goP qpn@(Q _pp pn) (POption i _) r = do + goP qpn@(Q (PackagePath _stage _) pn) (POption i _mpp) r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages @@ -202,6 +203,7 @@ validate = go 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 -- qualify the deps in the current scope let qdeps = qualifyDeps qo qpn deps @@ -209,8 +211,8 @@ validate = go -- plus the dependency information we have for that instance let newactives = extractAllDeps pfa psa qdeps -- We now try to extend the partial assignment with the new active constraints. - let mnppa = extend extSupported langSupported pkgPresent newactives - =<< extendWithPackageChoice (PI qpn i) ppa + let mnppa = extend (extSupported stage) (langSupported stage) (pkgPresent stage) newactives + =<< extendWithPackageChoice (PI qpn i) ppa -- In case we continue, we save the scoped dependencies let nsvd = M.insert qpn qdeps svd case mfr of @@ -235,7 +237,7 @@ validate = go -- What to do for flag nodes ... goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goF qfn@(FN qpn _f) b r = do + goF qfn@(FN qpn@(Q (PackagePath stage _) _) _f) b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages @@ -257,7 +259,7 @@ validate = go let newactives = extractNewDeps (F qfn) b npfa psa qdeps mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives -- As in the package case, we try to extend the partial assignment. - let mnppa = extend extSupported langSupported pkgPresent newactives ppa + let mnppa = extend (extSupported stage) (langSupported stage) (pkgPresent stage) newactives ppa case liftM2 (,) mnppa mNewRequiredComps of Left (c, fr) -> return (Fail c fr) -- inconsistency found Right (nppa, rComps') -> @@ -265,7 +267,7 @@ validate = go -- What to do for stanza nodes (similar to flag nodes) ... goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goS qsn@(SN qpn _f) b r = do + goS qsn@(SN qpn@(Q (PackagePath stage _) _) _f) b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages @@ -287,7 +289,7 @@ validate = go let newactives = extractNewDeps (S qsn) b pfa npsa qdeps mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives -- As in the package case, we try to extend the partial assignment. - let mnppa = extend extSupported langSupported pkgPresent newactives ppa + let mnppa = extend (extSupported stage) (langSupported stage) (pkgPresent stage) newactives ppa case liftM2 (,) mnppa mNewRequiredComps of Left (c, fr) -> return (Fail c fr) -- inconsistency found Right (nppa, rComps') -> @@ -331,7 +333,14 @@ checkComponentsInNewPackage required qpn providedComps = -- | We try to extract as many concrete dependencies from the given flagged -- dependencies as possible. We make use of all the flag knowledge we have -- already acquired. -extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] +extractAllDeps + :: FAssignment + -- ^ current flag assignments + -> SAssignment + -- ^ current stanza assignments + -> FlaggedDeps QPN + -- ^ conditional dependencies + -> [LDep QPN] extractAllDeps fa sa deps = do d <- deps case d of @@ -348,7 +357,19 @@ extractAllDeps fa sa deps = do -- | We try to find new dependencies that become available due to the given -- flag or stanza choice. We therefore look for the choice in question, and then call -- 'extractAllDeps' for everything underneath. -extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] +extractNewDeps + :: Var QPN + -- ^ the variable (package, flag or stanza) + -> Bool + -- ^ the variable value + -> FAssignment + -- ^ current flag assignments + -> SAssignment + -- ^ current stanza assignments + -> FlaggedDeps QPN + -- ^ conditional dependencies + -> [LDep QPN] + -- ^ dependencies with a reason extractNewDeps v b fa sa = go where go :: FlaggedDeps QPN -> [LDep QPN] @@ -452,14 +473,14 @@ merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) -merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr)) +merge (MergedDepFixed comp1 vs1 i@(I _ v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr)) | checkVR vr v = Right $ MergedDepFixed comp1 vs1 i | otherwise = Left ( createConflictSetForVersionConflict p v vs1 vr vs2 , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) -merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I v _))) = +merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I _ v _))) = go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ... where go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep @@ -563,15 +584,13 @@ extendRequiredComponents eqpn available = foldM extendSingle -- | Interface. -validateTree :: CompilerInfo -> Index -> Maybe PkgConfigDb -> Tree d c -> Tree d c -validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS { - supportedExt = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported - (\ es -> let s = S.fromList es in (`S.member` s)) - (compilerInfoExtensions cinfo) - , supportedLang = maybe (const True) - (flip L.elem) -- use list lookup because language list is small and no Ord instance - (compilerInfoLanguages cinfo) - , presentPkgs = pkgConfigPkgIsPresent <$> pkgConfigDb +validateTree :: Staged CompilerInfo -> Staged (Maybe PkgConfigDb) -> Index -> Tree d c -> Tree d c +validateTree cinfo pkgConfigDb idx t = runValidate (validate t) VS + { -- if compiler has no list of extensions, we assume everything is supported + supportedExt = maybe (const True) (flip S.member) . getStage extSet + , -- if compiler has no list of extensions, we assume everything is supported + supportedLang = maybe (const True) (flip S.member) . getStage langSet + , presentPkgs = fmap pkgConfigPkgIsPresent . getStage pkgConfigDb , index = idx , saved = M.empty , pa = PA M.empty M.empty M.empty @@ -579,3 +598,9 @@ validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS { , requiredComponents = M.empty , qualifyOptions = defaultQualifyOptions idx } + where + extSet :: Staged (Maybe (S.Set Extension)) + extSet = fmap (fmap S.fromList . compilerInfoExtensions) cinfo + + langSet :: Staged (Maybe (S.Set Language)) + langSet = fmap (fmap S.fromList . compilerInfoLanguages) cinfo diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs index 4244a080064..25cc04c393b 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs @@ -60,6 +60,9 @@ data ConstraintSource = -- | An internal constraint due to compatibility issues with the Setup.hs -- command line interface requires a maximum upper bound on Cabal | ConstraintSetupCabalMaxVersion + + -- | TODO + | ConstraintHideInstalledPackagesSpecificBySourcePackageId deriving (Show, Eq, Generic) instance Binary ConstraintSource @@ -95,3 +98,5 @@ instance Pretty ConstraintSource where text "minimum version of Cabal used by Setup.hs" ConstraintSetupCabalMaxVersion -> text "maximum version of Cabal used by Setup.hs" + ConstraintHideInstalledPackagesSpecificBySourcePackageId -> + text "HideInstalledPackagesSpecificBySourcePackageId" diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs index 956a4e14849..d58dfe49af3 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs @@ -15,7 +15,10 @@ import Distribution.Solver.Types.Progress ( Progress ) import Distribution.Solver.Types.ResolverPackage ( ResolverPackage ) -import Distribution.Solver.Types.SourcePackage ( SourcePackage ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage ) +import Distribution.Solver.Types.Stage + ( Staged ) import Distribution.Solver.Types.SummarizedMessage ( SummarizedMessage(..) ) import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) @@ -31,11 +34,10 @@ import Distribution.System ( Platform ) -- solving the package dependency problem and we want to make it easy to swap -- in alternatives. -- -type DependencyResolver loc = Platform - -> CompilerInfo - -> InstalledPackageIndex +type DependencyResolver loc = Staged (CompilerInfo, Platform) + -> Staged (Maybe PkgConfigDb) + -> Staged InstalledPackageIndex -> PackageIndex (SourcePackage loc) - -> Maybe PkgConfigDb -> (PackageName -> PackagePreferences) -> [LabeledPackageConstraint] -> Set PackageName diff --git a/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs index 871a0dd15a9..b2358bca348 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs @@ -8,7 +8,9 @@ import Prelude () import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) ) import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import Distribution.Solver.Types.PackagePath (QPN) import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.Stage (Stage) import Distribution.Types.MungedPackageId import Distribution.Types.PackageId import Distribution.Types.MungedPackageName @@ -17,6 +19,8 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo) -- | An 'InstSolverPackage' is a pre-existing installed package -- specified by the dependency solver. data InstSolverPackage = InstSolverPackage { + instSolverStage :: Stage, + instSolverQPN :: QPN, instSolverPkgIPI :: InstalledPackageInfo, instSolverPkgLibDeps :: ComponentDeps [SolverId], instSolverPkgExeDeps :: ComponentDeps [SolverId] diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index 9b5db378b6a..dc5b685ff61 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -68,15 +68,13 @@ scopeToPackageName (ScopeAnySetupQualifier pn) = pn scopeToPackageName (ScopeAnyQualifier pn) = pn constraintScopeMatches :: ConstraintScope -> QPN -> Bool -constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') = - let namespaceMatches DefaultNamespace = True - namespaceMatches (Independent namespacePn) = pn == namespacePn - in namespaceMatches ns && q == QualToplevel && pn == pn' +constraintScopeMatches (ScopeTarget pn) (Q (PackagePath _ q) pn') = + q == QualToplevel && pn == pn' constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') = q == q' && pn == pn' constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') = let setup (PackagePath _ (QualSetup _)) = True - setup _ = False + setup _ = False in setup pp && pn == pn' constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn' diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs index 4fc4df25f97..84bc59bb402 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} module Distribution.Solver.Types.PackagePath ( PackagePath(..) , Namespace(..) @@ -12,31 +14,19 @@ module Distribution.Solver.Types.PackagePath import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Package (PackageName) -import Distribution.Pretty (pretty, flatStyle) +import Distribution.Pretty (pretty, flatStyle, Pretty) import qualified Text.PrettyPrint as Disp +import Distribution.Solver.Types.Stage (Stage) --- | A package path consists of a namespace and a package path inside that --- namespace. -data PackagePath = PackagePath Namespace Qualifier - deriving (Eq, Ord, Show) +data PackagePath = PackagePath Stage Qualifier + deriving (Eq, Ord, Show, Generic) --- | Top-level namespace --- --- Package choices in different namespaces are considered completely independent --- by the solver. -data Namespace = - -- | The default namespace - DefaultNamespace - - -- | A namespace for a specific build target - | Independent PackageName - deriving (Eq, Ord, Show) - --- | Pretty-prints a namespace. The result is either empty or --- ends in a period, so it can be prepended onto a qualifier. -dispNamespace :: Namespace -> Disp.Doc -dispNamespace DefaultNamespace = Disp.empty -dispNamespace (Independent i) = pretty i <<>> Disp.text "." +instance Binary PackagePath +instance Structured PackagePath + +instance Pretty PackagePath where + pretty (PackagePath stage qualifier) = + pretty stage <<>> Disp.text ":" <<>> pretty qualifier -- | Qualifier of a package within a namespace (see 'PackagePath') data Qualifier = @@ -68,7 +58,17 @@ data Qualifier = -- tracked only @pn2@, that would require us to pick only one -- version of an executable over the entire install plan.) | QualExe PackageName PackageName - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Binary Qualifier +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" -- | Pretty-prints a qualifier. The result is either empty or -- ends in a period, so it can be prepended onto a package name. @@ -79,23 +79,32 @@ data Qualifier = -- is the qualifier and @"base"@ is the actual dependency (which, for the -- 'Base' qualifier, will always be @base@). dispQualifier :: Qualifier -> Disp.Doc -dispQualifier QualToplevel = Disp.empty -dispQualifier (QualSetup pn) = pretty pn <<>> Disp.text ":setup." -dispQualifier (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>> - pretty pn2 <<>> Disp.text ":exe." -dispQualifier (QualBase pn) = pretty pn <<>> Disp.text "." +dispQualifier QualToplevel = mempty +dispQualifier (QualBase pn) = pretty pn <> Disp.text "." +dispQualifier (QualSetup pn) = pretty pn <> Disp.text ":setup." +dispQualifier (QualExe pn pn2) = + pretty pn + <> Disp.text ":" + <> pretty pn2 + <> Disp.text ":exe." -- | A qualified entity. Pairs a package path with the entity. data Qualified a = Q PackagePath a - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance (Binary a) => Binary (Qualified a) +instance (Structured a) => Structured (Qualified a) -- | Qualified package name. type QPN = Qualified PackageName +instance Pretty (Qualified PackageName) where + pretty (Q (PackagePath stage qual) pn) = + pretty stage <<>> Disp.colon <<>> dispQualifier qual <<>> pretty pn + -- | Pretty-prints a qualified package name. dispQPN :: QPN -> Disp.Doc -dispQPN (Q (PackagePath ns qual) pn) = - dispNamespace ns <<>> dispQualifier qual <<>> pretty pn +dispQPN = pretty -- | String representation of a qualified package name. showQPN :: QPN -> String diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs index 186f140aefe..f170542ac19 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs @@ -12,6 +12,8 @@ import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Stage ( Stage ) +import Distribution.Solver.Types.PackagePath ( QPN ) -- | A 'SolverPackage' is a package specified by the dependency solver. -- It will get elaborated into a 'ConfiguredPackage' or even an @@ -21,6 +23,8 @@ import Distribution.Solver.Types.SourcePackage -- but for symmetry we have the parameter. (Maybe it can be removed.) -- data SolverPackage loc = SolverPackage { + solverPkgStage :: Stage, + solverPkgQPN :: QPN, solverPkgSource :: SourcePackage loc, solverPkgFlags :: FlagAssignment, solverPkgStanzas :: OptionalStanzaSet, diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index 6b396d0eb0c..5c77dff570e 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -68,6 +68,7 @@ import Distribution.Solver.Types.PkgConfigDb ) import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Client.SavedFlags (readCommandFlags, writeCommandFlags) import Distribution.Package @@ -463,14 +464,18 @@ planLocalPackage . setSolveExecutables (SolveExecutables False) . setSolverVerbosity (verbosityLevel verbosity) $ standardInstallPolicy - installedPkgIndex -- NB: We pass in an *empty* source package database, -- because cabal configure assumes that all dependencies -- have already been installed (SourcePackageDb mempty packagePrefs) [SpecificSourcePackage localPkg] - return (resolveDependencies platform (compilerInfo comp) pkgConfigDb resolverParams) + return $ + resolveDependencies + (Stage.always (compilerInfo comp, platform)) + (Stage.always pkgConfigDb) + (Stage.always installedPkgIndex) + resolverParams -- | Call an installer for an 'SourcePackage' but override the configure -- flags with the ones given by the 'ReadyPackage'. In particular the diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 1244308b881..27a43e7c6d1 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -160,6 +160,7 @@ import Distribution.Solver.Types.SolverPackage ( SolverPackage (SolverPackage) ) import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Toolchain import Distribution.Solver.Types.Variable import Control.Exception @@ -186,7 +187,7 @@ data DepResolverParams = DepResolverParams , depResolverConstraints :: [LabeledPackageConstraint] , depResolverPreferences :: [PackagePreference] , depResolverPreferenceDefault :: PackagesPreferenceDefault - , depResolverInstalledPkgIndex :: InstalledPackageIndex + , depResolverInstalledPkgIndex :: InstalledPackageIndex -> InstalledPackageIndex , depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage , depResolverReorderGoals :: ReorderGoals , depResolverCountConflicts :: CountConflicts @@ -282,16 +283,15 @@ showPackagePreference (PackageStanzasPreference pn st) = prettyShow pn ++ " " ++ show st basicDepResolverParams - :: InstalledPackageIndex - -> PackageIndex.PackageIndex UnresolvedSourcePackage + :: PackageIndex.PackageIndex UnresolvedSourcePackage -> DepResolverParams -basicDepResolverParams installedPkgIndex sourcePkgIndex = +basicDepResolverParams sourcePkgIndex = DepResolverParams { depResolverTargets = Set.empty , depResolverConstraints = [] , depResolverPreferences = [] , depResolverPreferenceDefault = PreferLatestForSelected - , depResolverInstalledPkgIndex = installedPkgIndex + , depResolverInstalledPkgIndex = id , depResolverSourcePkgIndex = sourcePkgIndex , depResolverReorderGoals = ReorderGoals False , depResolverCountConflicts = CountConflicts True @@ -514,10 +514,8 @@ hideInstalledPackagesSpecificBySourcePackageId pkgids params = -- TODO: this should work using exclude constraints instead params { depResolverInstalledPkgIndex = - foldl' - (flip InstalledPackageIndex.deleteSourcePackageId) - (depResolverInstalledPkgIndex params) - pkgids + (\idx -> foldl' (flip InstalledPackageIndex.deleteSourcePackageId) idx pkgids) + . depResolverInstalledPkgIndex params } hideInstalledPackagesAllVersions @@ -528,10 +526,8 @@ hideInstalledPackagesAllVersions pkgnames params = -- TODO: this should work using exclude constraints instead params { depResolverInstalledPkgIndex = - foldl' - (flip InstalledPackageIndex.deletePackageName) - (depResolverInstalledPkgIndex params) - pkgnames + (\idx -> foldl' (flip InstalledPackageIndex.deletePackageName) idx pkgnames) + . depResolverInstalledPkgIndex params } -- | Remove upper bounds in dependencies using the policy specified by the @@ -765,12 +761,10 @@ reinstallTargets params = -- | A basic solver policy on which all others are built. basicInstallPolicy - :: InstalledPackageIndex - -> SourcePackageDb + :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams basicInstallPolicy - installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs) pkgSpecifiers = addPreferences @@ -786,7 +780,6 @@ basicInstallPolicy . addSourcePackages [pkg | SpecificSourcePackage pkg <- pkgSpecifiers] $ basicDepResolverParams - installedPkgIndex sourcePkgIndex -- | The policy used by all the standard commands, install, fetch, freeze etc @@ -794,14 +787,12 @@ basicInstallPolicy -- -- It extends the 'basicInstallPolicy' with a policy on setup deps. standardInstallPolicy - :: InstalledPackageIndex - -> SourcePackageDb + :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams -standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers = - addDefaultSetupDependencies setImplicitSetupInfo mkDefaultSetupDeps $ +standardInstallPolicy sourcePkgDb pkgSpecifiers = + addDefaultSetupDependencies mkDefaultSetupDeps $ basicInstallPolicy - installedPkgIndex sourcePkgDb pkgSpecifiers where @@ -847,49 +838,46 @@ runSolver = modularResolver -- a 'Progress' structure that can be unfolded to provide progress information, -- logging messages and the final result or an error. resolveDependencies - :: Platform - -> CompilerInfo - -> Maybe PkgConfigDb + :: Staged (CompilerInfo, Platform) + -> Staged (Maybe PkgConfigDb) + -> Staged InstalledPackageIndex -> DepResolverParams -> Progress String String SolverInstallPlan -resolveDependencies platform comp pkgConfigDB params = do - step (showDepResolverParams finalparams) - pkgs <- - formatProgress $ - runSolver - ( SolverConfig - reordGoals - cntConflicts - fineGrained - minimize - indGoals - noReinstalls - shadowing - strFlags - onlyConstrained_ - maxBkjumps - enableBj - solveExes - order - verbosity - (PruneAfterFirstSuccess False) - ) - platform - comp - installedPkgIndex - sourcePkgIndex - pkgConfigDB - preferences - constraints - targets - validateSolverResult platform comp indGoals pkgs +resolveDependencies toolchains pkgConfigDB installedPkgIndex params = + Step (showDepResolverParams finalparams) $ + fmap (validateSolverResult toolchains) $ + formatProgress $ + runSolver + ( SolverConfig + reordGoals + cntConflicts + fineGrained + minimize + noReinstalls + shadowing + strFlags + onlyConstrained_ + maxBkjumps + enableBj + solveExes + order + verbosity + (PruneAfterFirstSuccess False) + ) + toolchains + pkgConfigDB + (fmap installedPkgIndexM installedPkgIndex) + sourcePkgIndex + preferences + constraints + targets where finalparams@( DepResolverParams targets constraints prefs defpref - installedPkgIndex + installedPkgIndexM sourcePkgIndex reordGoals cntConflicts @@ -979,17 +967,15 @@ interpretPackagesPreference selected defaultPref prefs = -- | Make an install plan from the output of the dep resolver. -- It checks that the plan is valid, or it's an error in the dep resolver. validateSolverResult - :: Platform - -> CompilerInfo - -> IndependentGoals + :: Staged (CompilerInfo, Platform) -> [ResolverPackage UnresolvedPkgLoc] - -> Progress String String SolverInstallPlan -validateSolverResult platform comp indepGoals pkgs = - case planPackagesProblems platform comp pkgs of - [] -> case SolverInstallPlan.new indepGoals graph of - Right plan -> return plan - Left problems -> fail (formatPlanProblems problems) - problems -> fail (formatPkgProblems problems) + -> SolverInstallPlan +validateSolverResult toolchains pkgs = + case planPackagesProblems toolchains pkgs of + [] -> case SolverInstallPlan.new graph of + Right plan -> plan + Left problems -> error (formatPlanProblems problems) + problems -> error (formatPkgProblems problems) where graph :: Graph.Graph (ResolverPackage UnresolvedPkgLoc) graph = Graph.fromDistinctList pkgs @@ -1030,14 +1016,13 @@ showPlanPackageProblem (DuplicatePackageSolverId pid dups) = ++ " duplicate instances." planPackagesProblems - :: Platform - -> CompilerInfo + :: Staged (CompilerInfo, Platform) -> [ResolverPackage UnresolvedPkgLoc] -> [PlanPackageProblem] -planPackagesProblems platform cinfo pkgs = +planPackagesProblems toolchains pkgs = [ InvalidConfiguredPackage pkg packageProblems | Configured pkg <- pkgs - , let packageProblems = configuredPackageProblems platform cinfo pkg + , let packageProblems = configuredPackageProblems toolchains pkg , not (null packageProblems) ] ++ [ DuplicatePackageSolverId (Graph.nodeKey aDup) dups @@ -1086,14 +1071,12 @@ showPackageProblem (InvalidDep dep pkgid) = -- in the configuration given by the flag assignment, all the package -- dependencies are satisfied by the specified packages. configuredPackageProblems - :: Platform - -> CompilerInfo + :: Staged (CompilerInfo, Platform) -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] configuredPackageProblems - platform - cinfo - (SolverPackage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') = + toolchains + (SolverPackage stage _qpn pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') = [ DuplicateFlag flag | flag <- PD.findDuplicateFlagAssignments specifiedFlags ] @@ -1163,8 +1146,8 @@ configuredPackageProblems specifiedFlags compSpec (const Satisfied) - platform - cinfo + (snd (getStage toolchains stage)) + (fst (getStage toolchains stage)) [] (srcpkgDescription pkg) of Right (resolvedPkg, _) -> @@ -1203,6 +1186,7 @@ configuredPackageProblems -- It simply means preferences for installed packages will be ignored. resolveWithoutDependencies :: DepResolverParams + -> InstalledPackageIndex -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] resolveWithoutDependencies ( DepResolverParams @@ -1210,7 +1194,7 @@ resolveWithoutDependencies constraints prefs defpref - installedPkgIndex + installedPkgIndexM sourcePkgIndex _reorderGoals _countConflicts @@ -1227,7 +1211,8 @@ resolveWithoutDependencies _onlyConstrained _order _verbosity - ) = + ) + installedPkgIndex = collectEithers $ map selectPackage (Set.toList targets) where selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage @@ -1252,6 +1237,7 @@ resolveWithoutDependencies bestByPrefs :: UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering bestByPrefs = comparing $ \pkg -> (installPref pkg, versionPref pkg, packageVersion pkg) + installPref :: UnresolvedSourcePackage -> Bool installPref = case preferInstalled of Preference.PreferLatest -> const False @@ -1260,8 +1246,9 @@ resolveWithoutDependencies not . null . InstalledPackageIndex.lookupSourcePackageId - installedPkgIndex + (installedPkgIndexM installedPkgIndex) . packageId + versionPref :: Package a => a -> Int versionPref pkg = length . filter (packageVersion pkg `withinRange`) $ diff --git a/cabal-install/src/Distribution/Client/Fetch.hs b/cabal-install/src/Distribution/Client/Fetch.hs index 13c6f23415e..2f4ab5f5cff 100644 --- a/cabal-install/src/Distribution/Client/Fetch.hs +++ b/cabal-install/src/Distribution/Client/Fetch.hs @@ -38,6 +38,7 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, readPkgConfigDb) import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Client.Errors import Distribution.Package @@ -175,9 +176,9 @@ planPackages installPlan <- foldProgress logMsg (dieWithException verbosity . PlanPackages . show) return $ resolveDependencies - platform - (compilerInfo comp) - pkgConfigDb + (Stage.always (compilerInfo comp, platform)) + (Stage.always pkgConfigDb) + (Stage.always installedPkgIndex) resolverParams -- The packages we want to fetch are those packages the 'InstallPlan' @@ -189,7 +190,7 @@ planPackages ] | otherwise = either (dieWithException verbosity . PlanPackages . unlines . map show) return $ - resolveWithoutDependencies resolverParams + resolveWithoutDependencies resolverParams installedPkgIndex where resolverParams :: DepResolverParams resolverParams = @@ -221,7 +222,7 @@ planPackages -- already installed. Since we want to get the source packages of -- things we might have installed (but not have the sources for). . reinstallTargets - $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + $ standardInstallPolicy sourcePkgDb pkgSpecifiers includeDependencies = fromFlag (fetchDeps fetchFlags) logMsg message rest = debug verbosity message >> rest diff --git a/cabal-install/src/Distribution/Client/Freeze.hs b/cabal-install/src/Distribution/Client/Freeze.hs index 94c27746920..868646b6080 100644 --- a/cabal-install/src/Distribution/Client/Freeze.hs +++ b/cabal-install/src/Distribution/Client/Freeze.hs @@ -52,6 +52,7 @@ import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb import Distribution.Solver.Types.SolverId +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Client.Errors import Distribution.Package @@ -213,9 +214,9 @@ planPackages installPlan <- foldProgress logMsg (dieWithException verbosity . FreezeException) return $ resolveDependencies - platform - (compilerInfo comp) - pkgConfigDb + (Stage.always (compilerInfo comp, platform)) + (Stage.always pkgConfigDb) + (Stage.always installedPkgIndex) resolverParams return $ pruneInstallPlan installPlan pkgSpecifiers @@ -246,7 +247,7 @@ planPackages in LabeledPackageConstraint pc ConstraintSourceFreeze | pkgSpecifier <- pkgSpecifiers ] - $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + $ standardInstallPolicy sourcePkgDb pkgSpecifiers logMsg message rest = debug verbosity message >> rest diff --git a/cabal-install/src/Distribution/Client/Get.hs b/cabal-install/src/Distribution/Client/Get.hs index 44de794c878..2df320aef77 100644 --- a/cabal-install/src/Distribution/Client/Get.hs +++ b/cabal-install/src/Distribution/Client/Get.hs @@ -125,6 +125,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do either (dieWithException verbosity . PkgSpecifierException . map show) return $ resolveWithoutDependencies (resolverParams sourcePkgDb pkgSpecifiers) + mempty unless (null prefix) $ createDirectoryIfMissing True prefix @@ -143,7 +144,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do resolverParams :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams resolverParams sourcePkgDb pkgSpecifiers = -- TODO: add command-line constraint and preference args for unpack - standardInstallPolicy mempty sourcePkgDb pkgSpecifiers + standardInstallPolicy sourcePkgDb pkgSpecifiers onlyPkgDescr = fromFlagOrDefault False (getOnlyPkgDescr getFlags) diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index df030e7a515..4ffdf31e821 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -143,6 +143,7 @@ import Distribution.Solver.Types.PkgConfigDb ) import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage as SourcePackage +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Client.ProjectConfig import Distribution.Client.Utils @@ -585,9 +586,9 @@ planPackages pkgConfigDb pkgSpecifiers = resolveDependencies - platform - (compilerInfo comp) - pkgConfigDb + (Stage.always (compilerInfo comp, platform)) + (Stage.always pkgConfigDb) + (Stage.always installedPkgIndex) resolverParams >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return where @@ -650,7 +651,6 @@ planPackages -- doesn't understand how to install them . setSolveExecutables (SolveExecutables False) $ standardInstallPolicy - installedPkgIndex sourcePkgDb pkgSpecifiers diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 62bc636b5ba..11f887e081c 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -165,6 +165,7 @@ import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.ModuleName import Distribution.Package @@ -716,7 +717,7 @@ rebuildInstallPlan newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile -- Configure the compiler we're using. - -- + -- This is moderately expensive and doesn't change that often so we cache -- it independently. -- @@ -1317,9 +1318,9 @@ planPackages localPackages pkgStanzasEnable = resolveDependencies - platform - (compilerInfo comp) - pkgConfigDB + (Stage.always (compilerInfo comp, platform)) + (Stage.always pkgConfigDB) + (Stage.always installedPkgIndex) resolverParams where -- TODO: [nice to have] disable multiple instances restriction in @@ -1440,7 +1441,6 @@ planPackages -- Note: we don't use the standardInstallPolicy here, since that uses -- its own addDefaultSetupDependencies that is not appropriate for us. basicInstallPolicy - installedPkgIndex sourcePkgDb localPackages @@ -1703,7 +1703,7 @@ elaborateInstallPlan :: (SolverId -> [ElaboratedPlanPackage]) -> SolverPackage UnresolvedPkgLoc -> LogProgress [ElaboratedConfiguredPackage] - elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) = + elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ _ _ deps0 exe_deps0) = case mkComponentsGraph (elabEnabledSpec elab0) pd of Right g -> do let src_comps = componentsGraphToList g @@ -2086,6 +2086,8 @@ elaborateInstallPlan elaborateSolverToPackage pkgWhyNotPerComponent pkg@( SolverPackage + _stage + _qpn (SourcePackage pkgid _gpd _srcloc _descOverride) _flags _stanzas @@ -2190,6 +2192,8 @@ elaborateInstallPlan -> (ElaboratedConfiguredPackage, LogProgress ()) elaborateSolverToCommon pkg@( SolverPackage + _stage + _qpn (SourcePackage pkgid gdesc srcloc descOverride) flags stanzas diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index bf99906f6bd..d80598797b9 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -100,6 +100,7 @@ import qualified Distribution.Solver.Types.PkgConfigDb as PC import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Solver.Types.Variable import Distribution.Types.UnitId (UnitId) @@ -832,7 +833,11 @@ exResolve prefs verbosity enableAllTests = - resolveDependencies C.buildPlatform compiler pkgConfigDb params + resolveDependencies + (Stage.always (compiler, C.buildPlatform)) + (Stage.always pkgConfigDb) + (Stage.always instIdx) + params where defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag compiler = @@ -866,17 +871,16 @@ exResolve setCountConflicts countConflicts $ setFineGrainedConflicts fineGrainedConflicts $ setMinimizeConflictSet minimizeConflictSet $ - setIndependentGoals indepGoals $ - (if asBool prefOldest then setPreferenceDefault PreferAllOldest else id) $ - setReorderGoals reorder $ - setMaxBackjumps mbj $ - setAllowBootLibInstalls allowBootLibInstalls $ - setOnlyConstrained onlyConstrained $ - setEnableBackjumping enableBj $ - setSolveExecutables solveExes $ - setGoalOrder goalOrder $ - setSolverVerbosity (C.verbosityLevel verbosity) $ - standardInstallPolicy instIdx avaiIdx targets' + (if asBool prefOldest then setPreferenceDefault PreferAllOldest else id) $ + setReorderGoals reorder $ + setMaxBackjumps mbj $ + setAllowBootLibInstalls allowBootLibInstalls $ + setOnlyConstrained onlyConstrained $ + setEnableBackjumping enableBj $ + setSolveExecutables solveExes $ + setGoalOrder goalOrder $ + setSolverVerbosity verbosity $ + standardInstallPolicy avaiIdx targets' toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown toConstraint (ExVersionConstraint scope v) = 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 757aff758db..f0112ab71aa 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs @@ -51,6 +51,7 @@ import Distribution.Client.Dependency (foldProgress) import qualified Distribution.Solver.Types.PackagePath as P import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..), pkgConfigDbFromList) import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.Stage import Distribution.Solver.Types.Variable import Distribution.Types.UnitId (UnitId, mkUnitId) import UnitTests.Distribution.Solver.Modular.DSL @@ -323,20 +324,10 @@ runTest SolverTest{..} = withFrozenCallStack $ askOption $ \(OptionShowSolverLog toQPN q pn = P.Q pp (C.mkPackageName pn) where pp = case q of - QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel - QualIndep p -> - P.PackagePath - (P.Independent $ C.mkPackageName p) - P.QualToplevel + QualNone -> P.PackagePath Host P.QualToplevel QualSetup s -> - P.PackagePath - P.DefaultNamespace - (P.QualSetup (C.mkPackageName s)) - QualIndepSetup p s -> - P.PackagePath - (P.Independent $ C.mkPackageName p) - (P.QualSetup (C.mkPackageName s)) + P.PackagePath Host (P.QualSetup (C.mkPackageName s)) + QualIndepSetup _ s -> + P.PackagePath Host (P.QualSetup (C.mkPackageName s)) QualExe p1 p2 -> - P.PackagePath - P.DefaultNamespace - (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2)) + P.PackagePath Host (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2)) diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index cbf15810149..91603973b90 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -643,10 +643,6 @@ instance ArbitraryOrd ShortText where instance ArbitraryOrd Stage deriving instance Generic (Variable pn) -deriving instance Generic (P.Qualified a) -deriving instance Generic P.PackagePath -deriving instance Generic P.Namespace -deriving instance Generic P.Qualifier randomSubset :: Int -> [a] -> Gen [a] randomSubset n xs = take n <$> shuffle xs From e88379f428e474f2fdf50ff84262f7685ac83b14 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 24 Jul 2025 10:57:01 +0800 Subject: [PATCH 09/54] refactor(cabal-install): don't check for compiler support before using jsem This is a user problem. User should not enable jsem on a compiler that does not support it. This change also avoid us to pass the compiler all the way down. A better approach to restore this functionality would be to defer the application of the parallel strategy. --- .../src/Distribution/Client/CmdInstall.hs | 1 - .../src/Distribution/Client/JobControl.hs | 19 ++----------------- .../Distribution/Client/ProjectBuilding.hs | 2 +- .../src/Distribution/Client/ProjectConfig.hs | 7 +------ .../Distribution/Client/ProjectPlanning.hs | 11 ++++------- 5 files changed, 8 insertions(+), 32 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index b0c1dd236ef..c7b73e42e94 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -472,7 +472,6 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project fetchAndReadSourcePackages verbosity distDirLayout - (Just compiler) (projectConfigShared config) (projectConfigBuildOnly config) [ProjectPackageRemoteTarball uri | uri <- uris] diff --git a/cabal-install/src/Distribution/Client/JobControl.hs b/cabal-install/src/Distribution/Client/JobControl.hs index 280916fdf6c..d37397987d3 100644 --- a/cabal-install/src/Distribution/Client/JobControl.hs +++ b/cabal-install/src/Distribution/Client/JobControl.hs @@ -50,7 +50,6 @@ import Control.Monad (forever, replicateM_) import Distribution.Client.Compat.Semaphore import Distribution.Client.Utils (numberOfProcessors) import Distribution.Compat.Stack -import Distribution.Simple.Compiler import Distribution.Simple.Utils import Distribution.Types.ParStrat import System.Semaphore @@ -277,29 +276,15 @@ criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act newJobControlFromParStrat :: Verbosity - -> Maybe Compiler - -- ^ The compiler, used to determine whether Jsem is supported. - -- When Nothing, Jsem is assumed to be unsupported. -> ParStratInstall -- ^ The parallel strategy -> Maybe Int -- ^ A cap on the number of jobs (e.g. to force a maximum of 2 concurrent downloads despite a -j8 parallel strategy) -> IO (JobControl IO a) -newJobControlFromParStrat verbosity mcompiler parStrat numJobsCap = case parStrat of +newJobControlFromParStrat verbosity parStrat numJobsCap = case parStrat of Serial -> newSerialJobControl NumJobs n -> newParallelJobControl (capJobs (fromMaybe numberOfProcessors n)) - UseSem n -> - case mcompiler of - Just compiler - | jsemSupported compiler -> - newSemaphoreJobControl verbosity (capJobs n) - | otherwise -> - do - warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control." - newParallelJobControl (capJobs n) - Nothing -> - -- Don't warn in the Nothing case, as there isn't really a "selected" compiler. - newParallelJobControl (capJobs n) + UseSem n -> newSemaphoreJobControl verbosity (capJobs n) where capJobs n = min (fromMaybe maxBound numJobsCap) n diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 97b3de3b177..46ec3d452e2 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -369,7 +369,7 @@ rebuildTargets -- Concurrency control: create the job controller and concurrency limits -- for downloading, building and installing. - withJobControl (newJobControlFromParStrat verbosity (Just compiler) buildSettingNumJobs Nothing) $ \jobControl -> do + withJobControl (newJobControlFromParStrat verbosity buildSettingNumJobs Nothing) $ \jobControl -> do -- Before traversing the install plan, preemptively find all packages that -- will need to be downloaded and start downloading them. asyncDownloadPackages diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index e7bdb7afd1a..a96fa4a0926 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -1401,7 +1401,6 @@ mplusMaybeT ma mb = do fetchAndReadSourcePackages :: Verbosity -> DistDirLayout - -> Maybe Compiler -> ProjectConfigShared -> ProjectConfigBuildOnly -> [ProjectPackageLocation] @@ -1409,7 +1408,6 @@ fetchAndReadSourcePackages fetchAndReadSourcePackages verbosity distDirLayout - compiler projectConfigShared projectConfigBuildOnly pkgLocations = do @@ -1446,7 +1444,6 @@ fetchAndReadSourcePackages syncAndReadSourcePackagesRemoteRepos verbosity distDirLayout - compiler projectConfigShared projectConfigBuildOnly (fromFlag (projectConfigOfflineMode projectConfigBuildOnly)) @@ -1566,7 +1563,6 @@ fetchAndReadSourcePackageRemoteTarball syncAndReadSourcePackagesRemoteRepos :: Verbosity -> DistDirLayout - -> Maybe Compiler -> ProjectConfigShared -> ProjectConfigBuildOnly -> Bool @@ -1575,7 +1571,6 @@ syncAndReadSourcePackagesRemoteRepos syncAndReadSourcePackagesRemoteRepos verbosity DistDirLayout{distDownloadSrcDirectory} - compiler ProjectConfigShared { projectConfigProgPathExtra } @@ -1610,7 +1605,7 @@ syncAndReadSourcePackagesRemoteRepos concat <$> rerunConcurrentlyIfChanged verbosity - (newJobControlFromParStrat verbosity compiler parStrat (Just maxNumFetchJobs)) + (newJobControlFromParStrat verbosity parStrat (Just maxNumFetchJobs)) [ ( monitor , repoGroup' , do diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 11f887e081c..6d7fc84f381 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -406,11 +406,11 @@ rebuildProjectConfig configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) pure (os, arch, toolchainCompiler) - (projectConfig, compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton - when (projectConfigDistDir (projectConfigShared projectConfig) /= NoFlag) $ + (projectConfig, _compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton + when (projectConfigDistDir (projectConfigShared $ projectConfig) /= NoFlag) $ liftIO $ warn verbosity "The builddir option is not supported in project and config files. It will be ignored." - localPackages <- phaseReadLocalPackages compiler (projectConfig <> cliConfig) + localPackages <- phaseReadLocalPackages (projectConfig <> cliConfig) return (projectConfig, localPackages) informAboutConfigFiles projectConfig @@ -438,11 +438,9 @@ rebuildProjectConfig -- NOTE: These are all packages mentioned in the project configuration. -- Whether or not they will be considered local to the project will be decided by `shouldBeLocal`. phaseReadLocalPackages - :: Maybe Compiler - -> ProjectConfig + :: ProjectConfig -> Rebuild [PackageSpecifier UnresolvedSourcePackage] phaseReadLocalPackages - compiler projectConfig@ProjectConfig { projectConfigShared , projectConfigBuildOnly @@ -457,7 +455,6 @@ rebuildProjectConfig fetchAndReadSourcePackages verbosity distDirLayout - compiler projectConfigShared projectConfigBuildOnly pkgLocations From 786330d242b1cecfb9db02d2688aa6e758655ae0 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 20 Mar 2025 15:21:45 +0800 Subject: [PATCH 10/54] feat(cabal-install): add build compiler option --- .../src/Distribution/Client/Config.hs | 4 ++++ .../Client/ProjectConfig/FieldGrammar.hs | 4 ++++ .../Client/ProjectConfig/Legacy.hs | 9 +++++++++ .../Distribution/Client/ProjectConfig/Lens.hs | 16 +++++++++++++++ .../Client/ProjectConfig/Types.hs | 4 ++++ .../src/Distribution/Client/Setup.hs | 20 ++++++++++++++++++- .../Distribution/Client/ProjectConfig.hs | 8 ++++++++ 7 files changed, 64 insertions(+), 1 deletion(-) diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index b42cfee9916..3a54dd3fbe8 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -578,6 +578,10 @@ instance Semigroup SavedConfig where combineMonoid savedConfigureExFlags configAllowOlder , configWriteGhcEnvironmentFilesPolicy = combine configWriteGhcEnvironmentFilesPolicy + , configBuildHcFlavor = combine configBuildHcFlavor + , configBuildHcPath = combine configBuildHcPath + , configBuildHcPkg = combine configBuildHcPkg + , configBuildPackageDBs = lastNonEmpty configBuildPackageDBs } where combine = combine' savedConfigureExFlags diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index 221c3f3691c..1422900fdd0 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -120,6 +120,10 @@ projectConfigToolchainFieldGrammar = <*> optionalFieldDefAla "with-compiler" (alaFlag FilePathNT) L.projectConfigHcPath mempty <*> optionalFieldDefAla "with-hc-pkg" (alaFlag FilePathNT) L.projectConfigHcPkg mempty <*> monoidalFieldAla "package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigPackageDBs + <*> optionalFieldDef "build-compiler" L.projectConfigBuildHcFlavor mempty + <*> optionalFieldDefAla "with-build-compiler" (alaFlag FilePathNT) L.projectConfigBuildHcPath mempty + <*> optionalFieldDefAla "with-build-hc-pkg" (alaFlag FilePathNT) L.projectConfigBuildHcPkg mempty + <*> monoidalFieldAla "build-package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigBuildPackageDBs packageConfigFieldGrammar :: [String] -> ParsecFieldGrammar' PackageConfig packageConfigFieldGrammar knownPrograms = diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index a58e5ef5901..e8f77515616 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -713,6 +713,7 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectConfigToolchain = ProjectConfigToolchain{..} projectConfigPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigPackageDBs_ + projectConfigBuildPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigBuildPackageDBs_ ConfigFlags { configCommonFlags = commonFlags @@ -738,6 +739,10 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags , configAllowNewer = projectConfigAllowNewer , configWriteGhcEnvironmentFilesPolicy = projectConfigWriteGhcEnvironmentFilesPolicy + , configBuildHcFlavor = projectConfigBuildHcFlavor + , configBuildHcPath = projectConfigBuildHcPath + , configBuildHcPkg = projectConfigBuildHcPkg + , configBuildPackageDBs = projectConfigBuildPackageDBs_ } = configExFlags InstallFlags @@ -1018,6 +1023,10 @@ convertToLegacySharedConfig , configAllowNewer = projectConfigAllowNewer , configWriteGhcEnvironmentFilesPolicy = projectConfigWriteGhcEnvironmentFilesPolicy + , configBuildHcFlavor = projectConfigBuildHcFlavor + , configBuildHcPath = projectConfigBuildHcPath + , configBuildHcPkg = projectConfigBuildHcPkg + , configBuildPackageDBs = fmap (fmap (fmap unsafeMakeSymbolicPath)) projectConfigBuildPackageDBs } installFlags = diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index 7b2c63a78d0..fcbdbcbae88 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -221,6 +221,22 @@ projectConfigPackageDBs :: Lens' ProjectConfigToolchain [Maybe PackageDBCWD] projectConfigPackageDBs f s = fmap (\x -> s{T.projectConfigPackageDBs = x}) (f (T.projectConfigPackageDBs s)) {-# INLINEABLE projectConfigPackageDBs #-} +projectConfigBuildHcFlavor :: Lens' ProjectConfigToolchain (Flag CompilerFlavor) +projectConfigBuildHcFlavor f s = fmap (\x -> s{T.projectConfigBuildHcFlavor = x}) (f (T.projectConfigBuildHcFlavor s)) +{-# INLINEABLE projectConfigBuildHcFlavor #-} + +projectConfigBuildHcPath :: Lens' ProjectConfigToolchain (Flag FilePath) +projectConfigBuildHcPath f s = fmap (\x -> s{T.projectConfigBuildHcPath = x}) (f (T.projectConfigBuildHcPath s)) +{-# INLINEABLE projectConfigBuildHcPath #-} + +projectConfigBuildHcPkg :: Lens' ProjectConfigToolchain (Flag FilePath) +projectConfigBuildHcPkg f s = fmap (\x -> s{T.projectConfigBuildHcPkg = x}) (f (T.projectConfigBuildHcPkg s)) +{-# INLINEABLE projectConfigBuildHcPkg #-} + +projectConfigBuildPackageDBs :: Lens' ProjectConfigToolchain [Maybe PackageDBCWD] +projectConfigBuildPackageDBs f s = fmap (\x -> s{T.projectConfigBuildPackageDBs = x}) (f (T.projectConfigBuildPackageDBs s)) +{-# INLINEABLE projectConfigBuildPackageDBs #-} + projectConfigHaddockIndex :: Lens' ProjectConfigShared (Flag PathTemplate) projectConfigHaddockIndex f s = fmap (\x -> s{T.projectConfigHaddockIndex = x}) (f (T.projectConfigHaddockIndex s)) {-# INLINEABLE projectConfigHaddockIndex #-} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index 0e20180800a..7dc5b714f69 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -246,6 +246,10 @@ data ProjectConfigToolchain = ProjectConfigToolchain , projectConfigHcPath :: Flag FilePath , projectConfigHcPkg :: Flag FilePath , projectConfigPackageDBs :: [Maybe PackageDBCWD] + , projectConfigBuildHcFlavor :: Flag CompilerFlavor + , projectConfigBuildHcPath :: Flag FilePath + , projectConfigBuildHcPkg :: Flag FilePath + , projectConfigBuildPackageDBs :: [Maybe PackageDBCWD] } deriving (Eq, Show, Generic) diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index c2651a33331..f1349844489 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -164,7 +164,7 @@ import Distribution.ReadE ) import Distribution.Simple.Command hiding (boolOpt, boolOpt') import qualified Distribution.Simple.Command as Command -import Distribution.Simple.Compiler (Compiler, PackageDB, PackageDBStack) +import Distribution.Simple.Compiler (Compiler, CompilerFlavor (..), PackageDB, PackageDBStack) import Distribution.Simple.Configure ( computeEffectiveProfiling , configCompilerAuxEx @@ -915,6 +915,10 @@ data ConfigExFlags = ConfigExFlags , configAllowOlder :: Maybe AllowOlder , configWriteGhcEnvironmentFilesPolicy :: Flag WriteGhcEnvironmentFilesPolicy + , configBuildHcFlavor :: Flag CompilerFlavor + , configBuildHcPath :: Flag FilePath + , configBuildHcPkg :: Flag FilePath + , configBuildPackageDBs :: [Maybe PackageDB] } deriving (Eq, Show, Generic) @@ -1042,6 +1046,20 @@ configureExOptions _showOrParseArgs src = writeGhcEnvironmentFilesPolicyParser writeGhcEnvironmentFilesPolicyPrinter ) + , option + "W" + ["with-build-compiler", "with-build-hc"] + "give the path to the compiler for the build stage" + configBuildHcPath + (\v flags -> flags{configBuildHcPath = v}) + (reqArgFlag "PATH") + , option + "" + ["with-build-hc-pkg"] + "give the path to the package tool for the build stage" + configBuildHcPkg + (\v flags -> flags{configBuildHcPkg = v}) + (reqArgFlag "PATH") ] writeGhcEnvironmentFilesPolicyParser :: ReadE (Flag WriteGhcEnvironmentFilesPolicy) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 73c7188b06f..6a68d366507 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -593,6 +593,10 @@ instance Arbitrary ProjectConfigToolchain where projectConfigHcPath <- arbitraryFlag arbitraryShortToken projectConfigHcPkg <- arbitraryFlag arbitraryShortToken projectConfigPackageDBs <- shortListOf 2 arbitrary + projectConfigBuildHcFlavor <- arbitrary + projectConfigBuildHcPath <- arbitraryFlag arbitraryShortToken + projectConfigBuildHcPkg <- arbitraryFlag arbitraryShortToken + projectConfigBuildPackageDBs <- shortListOf 2 arbitrary return ProjectConfigToolchain{..} shrink ProjectConfigToolchain{..} = @@ -602,6 +606,10 @@ instance Arbitrary ProjectConfigToolchain where <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg <*> shrinker projectConfigPackageDBs + <*> shrinker projectConfigBuildHcFlavor + <*> shrinkerAla (fmap NonEmpty) projectConfigBuildHcPath + <*> shrinkerAla (fmap NonEmpty) projectConfigBuildHcPkg + <*> shrinker projectConfigBuildPackageDBs instance Arbitrary ProjectConfigShared where arbitrary = do From ecc7c12dee5b66cfcaf9e5da16fed61e49c3194a Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Fri, 21 Mar 2025 18:11:01 +0800 Subject: [PATCH 11/54] cross-compile: replace flat compiler/platform fields with Toolchains in ElaboratedSharedConfig `ElaboratedSharedConfig` now holds `pkgConfigToolchains :: Toolchains` (a `Staged Toolchain`) instead of flat `pkgConfigPlatform`, `pkgConfigCompiler`, and `pkgConfigCompilerProgs` fields. Each `ElaboratedConfiguredPackage` gains an `elabStage :: Stage` field indicating whether it is a host or build artifact. A new `ProjectPlanning/Stage.hs` module introduces `WithStage` (a package wrapped with a `Stage` tag) and the `HasStage` typeclass, used to annotate install-plan nodes with their build stage. All command modules (`CmdExec`, `CmdHaddock`, `CmdHaddockProject`, `CmdListBin`, `CmdPath`, `CmdRepl`) and internal build infrastructure (`SetupWrapper`, `ProjectOrchestration`, `ProjectBuilding`) are updated to call `getStage (pkgConfigToolchains shared) (elabStage pkg)` in place of the old direct field access, so the correct compiler and program database are used for each stage. --- cabal-install/cabal-install.cabal | 1 + .../src/Distribution/Client/CmdExec.hs | 24 +- .../src/Distribution/Client/CmdGenBounds.hs | 1 - .../src/Distribution/Client/CmdHaddock.hs | 24 +- .../Distribution/Client/CmdHaddockProject.hs | 108 +-- .../src/Distribution/Client/CmdListBin.hs | 5 +- .../src/Distribution/Client/CmdPath.hs | 18 +- .../src/Distribution/Client/CmdRepl.hs | 21 +- .../src/Distribution/Client/InstallPlan.hs | 21 + .../Distribution/Client/ProjectBuilding.hs | 85 ++- .../Client/ProjectBuilding/UnpackedPackage.hs | 38 +- .../Client/ProjectOrchestration.hs | 137 ++-- .../Distribution/Client/ProjectPlanOutput.hs | 71 +- .../Distribution/Client/ProjectPlanning.hs | 634 ++++++++++-------- .../Client/ProjectPlanning/Stage.hs | 48 ++ .../Client/ProjectPlanning/Types.hs | 26 +- .../src/Distribution/Client/ScriptUtils.hs | 39 +- .../src/Distribution/Client/SetupWrapper.hs | 596 +++++++++------- .../src/Distribution/Client/Toolchain.hs | 59 +- cabal-install/tests/IntegrationTests2.hs | 20 +- 20 files changed, 1169 insertions(+), 807 deletions(-) create mode 100644 cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 5aedd0743a8..afc02f636ad 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -194,6 +194,7 @@ library Distribution.Client.ProjectPlanOutput Distribution.Client.ProjectPlanning Distribution.Client.ProjectPlanning.SetupPolicy + Distribution.Client.ProjectPlanning.Stage Distribution.Client.ProjectPlanning.Types Distribution.Client.RebuildMonad Distribution.Client.Reconfigure diff --git a/cabal-install/src/Distribution/Client/CmdExec.hs b/cabal-install/src/Distribution/Client/CmdExec.hs index f750e439341..ac5bdd5ab1b 100644 --- a/cabal-install/src/Distribution/Client/CmdExec.hs +++ b/cabal-install/src/Distribution/Client/CmdExec.hs @@ -1,6 +1,9 @@ ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} -- | -- Module : Distribution.Client.Exec @@ -56,7 +59,8 @@ import Distribution.Client.ProjectPlanning ) import qualified Distribution.Client.ProjectPlanning as Planning import Distribution.Client.ProjectPlanning.Types - ( dataDirsEnvironmentForPlan + ( Toolchain (..) + , dataDirsEnvironmentForPlan ) import Distribution.Client.Setup ( GlobalFlags @@ -104,6 +108,7 @@ import Prelude () import qualified Data.Map as M import qualified Data.Set as S import Distribution.Client.Errors +import Distribution.Solver.Types.Stage execCommand :: CommandUI (NixStyleFlags ()) execCommand = @@ -152,6 +157,12 @@ execAction flags extraArgs globalFlags = do baseCtx (\plan -> return (plan, M.empty)) + let toolchains = pkgConfigToolchains (elaboratedShared buildCtx) + -- We need the compiler and platform to set up the environment. + compilers = toolchainCompiler <$> toolchains + platforms = toolchainPlatform <$> toolchains + progdbs = toolchainProgramDb <$> toolchains + -- We use the build status below to decide what libraries to include in the -- compiler environment, but we don't want to actually build anything. So we -- pass mempty to indicate that nothing happened and we just want the current @@ -166,7 +177,9 @@ execAction flags extraArgs globalFlags = do -- Some dependencies may have executables. Let's put those on the PATH. let extraPaths = pathAdditions baseCtx buildCtx - pkgProgs = pkgConfigCompilerProgs (elaboratedShared buildCtx) + -- NOTE: only build-stage dependencies make sense here + pkgProgs = getStage progdbs Build + -- extraEnvVars = dataDirsEnvironmentForPlan (distDirLayout baseCtx) @@ -181,7 +194,8 @@ execAction flags extraArgs globalFlags = do -- point at the file. -- In case ghc is too old to support environment files, -- we pass the same info as arguments - let compiler = pkgConfigCompiler $ elaboratedShared buildCtx + -- FIXME + let compiler = getStage compilers Host envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler) case extraArgs of [] -> dieWithException verbosity SpecifyAnExecutable @@ -234,7 +248,9 @@ matchCompilerPath elaboratedShared program = programPath program `elem` (programPath <$> configuredCompilers) where - configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared + progdbs = toolchainProgramDb <$> pkgConfigToolchains elaboratedShared + -- FIXME + configuredCompilers = configuredPrograms (getStage progdbs Host) -- | Execute an action with a temporary .ghc.environment file reflecting the -- current environment. The action takes an environment containing the env diff --git a/cabal-install/src/Distribution/Client/CmdGenBounds.hs b/cabal-install/src/Distribution/Client/CmdGenBounds.hs index 6e47fcd6a9c..b19161e3ac9 100644 --- a/cabal-install/src/Distribution/Client/CmdGenBounds.hs +++ b/cabal-install/src/Distribution/Client/CmdGenBounds.hs @@ -18,7 +18,6 @@ import Control.Monad (mapM_) import Distribution.Client.Errors import Distribution.Client.ProjectPlanning hiding (pruneInstallPlanToTargets) -import Distribution.Client.ProjectPlanning.Types import Distribution.Client.Types.ConfiguredId (confInstId) import Distribution.Client.Utils hiding (pvpize) import Distribution.InstalledPackageInfo (InstalledPackageInfo, installedComponentId) diff --git a/cabal-install/src/Distribution/Client/CmdHaddock.hs b/cabal-install/src/Distribution/Client/CmdHaddock.hs index f9be5763b3b..a3cc048e210 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddock.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} @@ -29,8 +30,12 @@ import Distribution.Client.ProjectConfig.Types , ProjectConfig (..) ) import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types ( ElaboratedSharedConfig (..) + , Stage (..) + , Staged (..) + , Toolchain (..) + , getStage ) import Distribution.Client.Setup ( GlobalFlags @@ -160,6 +165,7 @@ haddockAction relFlags targetStrings globalFlags = do projCtx{buildSettings = (buildSettings projCtx){buildSettingHaddockOpen = True}} | otherwise = projCtx + absProjectConfig <- mkConfigAbsolute relProjectConfig let baseCtx = relBaseCtx{projectConfig = absProjectConfig} @@ -192,6 +198,9 @@ haddockAction relFlags targetStrings globalFlags = do printPlan verbosity baseCtx buildCtx + let toolchains = pkgConfigToolchains (elaboratedShared buildCtx) + + -- TODO progs <- reconfigurePrograms verbosity @@ -200,14 +209,19 @@ haddockAction relFlags targetStrings globalFlags = do -- we need to insert 'haddockProgram' before we reconfigure it, -- otherwise 'set . addKnownProgram haddockProgram - . pkgConfigCompilerProgs - . elaboratedShared - $ buildCtx + -- TODO + . toolchainProgramDb + $ getStage toolchains Host + + let toolchains' = Staged $ \case + Host -> (getStage toolchains' Host){toolchainProgramDb = progs} + Build -> getStage toolchains' Build + let buildCtx' = buildCtx { elaboratedShared = (elaboratedShared buildCtx) - { pkgConfigCompilerProgs = progs + { pkgConfigToolchains = toolchains' } } diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index 247eb3e2bd4..dda55d4b8f7 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -39,7 +39,9 @@ import Distribution.Client.ProjectPlanning , TargetAction (..) ) import Distribution.Client.ProjectPlanning.Types - ( elabDistDirParams + ( Toolchain (..) + , elabDistDirParams + , getStage ) import Distribution.Client.ScriptUtils ( AcceptNoTargets (..) @@ -71,18 +73,11 @@ import Distribution.Simple.Flag , pattern Flag , pattern NoFlag ) -import Distribution.Simple.Haddock (createHaddockIndex) + +-- import Distribution.Simple.Haddock (createHaddockIndex) import Distribution.Simple.InstallDirs ( toPathTemplate ) -import Distribution.Simple.Program.Builtin - ( haddockProgram - ) -import Distribution.Simple.Program.Db - ( addKnownProgram - , reconfigurePrograms - , requireProgramVersion - ) import Distribution.Simple.Setup ( HaddockFlags (..) , HaddockProjectFlags (..) @@ -103,8 +98,6 @@ import Distribution.Types.PackageDescription (PackageDescription (benchmarks, su import Distribution.Types.PackageId (pkgName) import Distribution.Types.PackageName (unPackageName) import Distribution.Types.UnitId (unUnitId) -import Distribution.Types.Version (mkVersion) -import Distribution.Types.VersionRange (orLaterVersion) import Distribution.Verbosity as Verbosity ( defaultVerbosityHandles , mkVerbosity @@ -172,24 +165,26 @@ haddockProjectAction flags _extraArgs globalFlags = do pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage] pkgs = matchingPackages elaboratedPlan - progs <- - reconfigurePrograms - verbosity - (haddockProjectProgramPaths flags) - (haddockProjectProgramArgs flags) - -- we need to insert 'haddockProgram' before we reconfigure it, - -- otherwise 'set - . addKnownProgram haddockProgram - . pkgConfigCompilerProgs - $ sharedConfig - let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs} - - _ <- - requireProgramVersion - verbosity - haddockProgram - (orLaterVersion (mkVersion [2, 26, 1])) - progs + -- TODO + -- progs <- + -- reconfigurePrograms + -- verbosity + -- (haddockProjectProgramPaths flags) + -- (haddockProjectProgramArgs flags) + -- -- we need to insert 'haddockProgram' before we reconfigure it, + -- -- otherwise 'set + -- . addKnownProgram haddockProgram + -- . pkgConfigCompilerProgs + -- $ sharedConfig + -- let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs} + let sharedConfig' = sharedConfig + + -- _ <- + -- requireProgramVersion + -- verbosity + -- haddockProgram + -- (orLaterVersion (mkVersion [2, 26, 1])) + -- progs -- -- Build project; we need to build dependencies. @@ -304,10 +299,12 @@ haddockProjectAction flags _extraArgs globalFlags = do False -> do let pkg_descr = elabPkgDescription package unitId = unUnitId (elabUnitId package) + compilers = toolchainCompiler <$> pkgConfigToolchains sharedConfig' + compiler = getStage compilers (elabStage package) packageDir = storePackageDirectory (cabalStoreDirLayout cabalLayout) - (pkgConfigCompiler sharedConfig') + compiler (elabUnitId package) -- TODO: use `InstallDirTemplates` docDir = packageDir "share" "doc" "html" @@ -327,8 +324,8 @@ haddockProjectAction flags _extraArgs globalFlags = do -- generate index, content, etc. -- - let (missingHaddocks, packageInfos') = partitionEithers packageInfos - unless (null missingHaddocks) $ do + let (missingHaddocks, _packageInfos') = partitionEithers packageInfos + when (not (null missingHaddocks)) $ do warn verbosity "missing haddocks for some packages from the store" -- Show the package list if `-v1` is passed; it's usually a long list. -- One needs to add `package` stantza in `cabal.project` file for @@ -336,28 +333,31 @@ haddockProjectAction flags _extraArgs globalFlags = do -- `documentation: True` in the global config). info verbosity (intercalate "\n" missingHaddocks) - let flags' = - flags - { haddockProjectDir = Flag outputDir - , haddockProjectInterfaces = - Flag - [ ( interfacePath - , Just url - , Just url - , visibility - ) - | (url, interfacePath, visibility) <- packageInfos' - ] - , haddockProjectUseUnicode = NoFlag - } - createHaddockIndex - verbosity - (pkgConfigCompilerProgs sharedConfig') - (pkgConfigCompiler sharedConfig') - (pkgConfigPlatform sharedConfig') - Nothing - flags' + warn verbosity "createHaddockIndex not implemented" where + -- let flags' = + -- flags + -- { haddockProjectDir = Flag outputDir + -- , haddockProjectInterfaces = + -- Flag + -- [ ( interfacePath + -- , Just url + -- , Just url + -- , visibility + -- ) + -- | (url, interfacePath, visibility) <- packageInfos' + -- ] + -- , haddockProjectUseUnicode = NoFlag + -- } + -- -- NOTE: this lives in Cabal + -- createHaddockIndex + -- verbosity + -- (toolchainProgramDb $ buildToolchain $ pkgConfigToolchains sharedConfig') + -- (toolchainCompiler $ buildToolchain $ pkgConfigToolchains sharedConfig') + -- (toolchainPlatform $ buildToolchain $ pkgConfigToolchains sharedConfig') + -- Nothing + -- flags' + -- build all packages with appropriate haddock flags commonFlags = haddockProjectCommonFlags flags diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index 5e13515c960..e430e983ba9 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -48,7 +48,6 @@ import Distribution.Client.TargetProblem (TargetProblem (..)) import Distribution.Simple.BuildPaths (dllExtension, exeExtension) import Distribution.Simple.Command (CommandUI (..)) import Distribution.Simple.Utils (dieWithException, withOutputMarker, wrapText) -import Distribution.System (Platform) import Distribution.Types.ComponentName (showComponentName) import Distribution.Types.UnitId (UnitId) import Distribution.Types.UnqualComponentName (UnqualComponentName) @@ -204,8 +203,8 @@ listbinAction flags args globalFlags = do | s == selectedComponent -> [flib_file' s] _ -> [] - plat :: Platform - plat = pkgConfigPlatform elaboratedSharedConfig + Toolchain{toolchainPlatform = plat} = + getStage (pkgConfigToolchains elaboratedSharedConfig) (elabStage elab) -- here and in PlanOutput, -- use binDirectoryFor? diff --git a/cabal-install/src/Distribution/Client/CmdPath.hs b/cabal-install/src/Distribution/Client/CmdPath.hs index cfb23c376da..9e07d69c39f 100644 --- a/cabal-install/src/Distribution/Client/CmdPath.hs +++ b/cabal-install/src/Distribution/Client/CmdPath.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} -- | -- Module : Distribution.Client.CmdPath @@ -41,14 +42,12 @@ import Distribution.Client.ProjectConfig.Types ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types (Toolchain (..)) import Distribution.Client.RebuildMonad (runRebuild) import Distribution.Client.ScriptUtils import Distribution.Client.Setup ( yesNoOpt ) -import Distribution.Client.Toolchain - ( Toolchain (..) - ) import Distribution.Client.Utils.Json ( (.=) ) @@ -79,9 +78,11 @@ import Distribution.Simple.Program import Distribution.Simple.Utils ( die' , dieWithException + , warn , withOutputMarker , wrapText ) +import Distribution.Solver.Types.Stage import Distribution.Verbosity ( normal , verbosityFlags @@ -248,10 +249,13 @@ pathAction flags@NixStyleFlags{extraFlags = pathFlags'} cliTargetStrings globalF if not $ fromFlagOrDefault False (pathCompiler pathFlags) then pure Nothing else do - toolchain <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ configureCompiler verbosity (distDirLayout baseCtx) (projectConfig baseCtx) - compilerProg <- requireCompilerProg verbosity (toolchainCompiler toolchain) - (configuredCompilerProg, _) <- requireProgram verbosity compilerProg (toolchainProgramDb toolchain) - pure $ Just $ mkCompilerInfo configuredCompilerProg (toolchainCompiler toolchain) + let projectRoot = distProjectRootDirectory (distDirLayout baseCtx) + toolchains <- runRebuild projectRoot $ configureToolchains verbosity (distDirLayout baseCtx) (projectConfig baseCtx) + warn verbosity "WIP: Assuming host toolchain, result might be wrong" + let Toolchain{..} = getStage toolchains Host + compilerProg <- requireCompilerProg verbosity toolchainCompiler + (configuredCompilerProg, _) <- requireProgram verbosity compilerProg toolchainProgramDb + pure $ Just $ mkCompilerInfo configuredCompilerProg toolchainCompiler paths <- for (fromFlagOrDefault [] $ pathDirectories pathFlags) $ \p -> do t <- getPathLocation verbosity baseCtx p diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index 940237200ea..39c1b973194 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -58,7 +58,8 @@ import Distribution.Client.ProjectPlanning , ElaboratedSharedConfig (..) ) import Distribution.Client.ProjectPlanning.Types - ( elabOrderExeDependencies + ( Toolchain (..) + , elabOrderExeDependencies , showElaboratedInstallPlan ) import Distribution.Client.ScriptUtils @@ -189,7 +190,7 @@ import Distribution.Simple.Flag (flagToMaybe, fromFlagOrDefault, pattern Flag) import Distribution.Simple.Program.Builtin (ghcProgram) import Distribution.Simple.Program.Db (requireProgram) import Distribution.Simple.Program.Types -import Distribution.Types.PackageName.Magic (fakePackageId) +import Distribution.Solver.Types.Stage import System.Directory ( doesFileExist , getCurrentDirectory @@ -443,7 +444,9 @@ targetedRepl -- especially in the no-project case. withInstallPlan (modifyVerbosityFlags lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do -- targets should be non-empty map, but there's no NonEmptyMap yet. - targets <- validatedTargets' (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors + -- TODO: This only makes sense for the build stage + let Toolchain{toolchainCompiler = compiler} = getStage (pkgConfigToolchains sharedConfig) Build + targets <- validatedTargets (projectConfigShared (projectConfig ctx)) compiler elaboratedPlan targetSelectors let (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets @@ -462,12 +465,14 @@ targetedRepl -- In addition, to avoid a *third* trip through the solver, we are -- replicating the second half of 'runProjectPreBuildPhase' by hand -- here. - (buildCtx, compiler, platform, replOpts', targets) <- withInstallPlan verbosity baseCtx'' $ + (buildCtx, compiler, progdb, platform, replOpts', targets) <- withInstallPlan verbosity baseCtx'' $ \elaboratedPlan elaboratedShared' -> do let ProjectBaseContext{..} = baseCtx'' + -- TODO: This mightr not make sense + Toolchain{..} = getStage (pkgConfigToolchains elaboratedShared') Host -- Recalculate with updated project. - targets <- validatedTargets' (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors + targets <- validatedTargets (projectConfigShared projectConfig) toolchainCompiler elaboratedPlan targetSelectors let elaboratedPlan' = @@ -504,13 +509,11 @@ targetedRepl , targetsMap = targets } - ElaboratedSharedConfig{pkgConfigCompiler = compiler, pkgConfigPlatform = platform} = elaboratedShared' - repl_flags = case originalComponent of Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci Nothing -> [] - return (buildCtx, compiler, platform, configureReplOptions & lReplOptionsFlags %~ (++ repl_flags), targets) + return (buildCtx, toolchainCompiler, toolchainProgramDb, toolchainPlatform, configureReplOptions & lReplOptionsFlags %~ (++ repl_flags), targets) -- Multi Repl implementation see: https://well-typed.com/blog/2023/03/cabal-multi-unit/ for -- a high-level overview about how everything fits together. @@ -545,7 +548,7 @@ targetedRepl -- HACK: Just combine together all env overrides, placing the most common things last -- ghc program with overridden PATH - (ghcProg, _) <- requireProgram verbosity ghcProgram (pkgConfigCompilerProgs (elaboratedShared buildCtx')) + (ghcProg, _) <- requireProgram verbosity ghcProgram progdb let ghcProg' = ghcProg{programOverrideEnv = [("PATH", Just sp)]} -- Find what the unit files are, and start a repl based on all the response diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index bb427f44a2c..17838aadc5f 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -41,6 +41,7 @@ module Distribution.Client.InstallPlan , configureInstallPlan , remove , installed + , installedM , lookup , directDeps , revDirectDeps @@ -432,6 +433,26 @@ installed shouldBeInstalled installPlan = { planGraph = Graph.insert (Installed pkg) (planGraph plan) } +-- | Change a number of packages in the 'Configured' state to the 'Installed' +-- state. +-- +-- To preserve invariants, the package must have all of its dependencies +-- already installed too (that is 'PreExisting' or 'Installed'). +installedM + :: (IsUnit ipkg, IsUnit srcpkg, Monad m) + => (srcpkg -> m Bool) + -> GenericInstallPlan ipkg srcpkg + -> m (GenericInstallPlan ipkg srcpkg) +installedM shouldBeInstalled installPlan = do + s <- filterM shouldBeInstalled [pkg | Configured pkg <- reverseTopologicalOrder installPlan] + return $ foldl markInstalled installPlan s + where + markInstalled plan pkg = + assert (all isInstalled (directDeps plan (nodeKey pkg))) $ + plan + { planGraph = Graph.insert (Installed pkg) (planGraph plan) + } + -- | Lookup a package in the plan. lookup :: (IsUnit ipkg, IsUnit srcpkg) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 46ec3d452e2..2632ded2d06 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -71,7 +72,6 @@ import Distribution.Client.Types hiding import Distribution.Package import Distribution.Simple.Compiler -import Distribution.Simple.Program import qualified Distribution.Simple.Register as Cabal import Distribution.Compat.Graph (IsNode (..)) @@ -342,10 +342,7 @@ rebuildTargets distDirLayout@DistDirLayout{..} storeDirLayout installPlan - sharedPackageConfig@ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigCompilerProgs = progdb - } + sharedPackageConfig pkgsBuildStatus buildSettings@BuildTimeSettings { buildSettingNumJobs @@ -365,7 +362,7 @@ rebuildTargets createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory createDirectoryIfMissingVerbose verbosity True distTempDirectory - traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse + createPackageDBsIfMissing -- Concurrency control: create the job controller and concurrency limits -- for downloading, building and installing. @@ -409,19 +406,52 @@ rebuildTargets projectConfigWithBuilderRepoContext verbosity buildSettings - packageDBsToUse = - -- all the package dbs we may need to create - (Set.toList . Set.fromList) - [ pkgdb - | InstallPlan.Configured elab <- InstallPlan.toList installPlan - , pkgdb <- - concat - [ elabBuildPackageDBStack elab - , elabRegisterPackageDBStack elab - , elabSetupPackageDBStack elab - ] - ] + createPackageDBsIfMissing :: IO () + createPackageDBsIfMissing = + for_ (InstallPlan.toList installPlan) $ \case + InstallPlan.Configured elab -> do + let pkgdbs = + (Set.toList . Set.fromList) $ + concat + [ elabBuildPackageDBStack elab + , elabRegisterPackageDBStack elab + , elabSetupPackageDBStack elab + ] + for_ pkgdbs $ \case + SpecificPackageDB dbPath -> do + exists <- Cabal.doesPackageDBExist dbPath + let Toolchain{toolchainCompiler, toolchainProgramDb} = + getStage (pkgConfigToolchains sharedPackageConfig) (elabStage elab) + unless exists $ do + createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) + Cabal.createPackageDB verbosity toolchainCompiler toolchainProgramDb False dbPath + _ -> pure () + _ -> pure () + + -- createPackageDBIfMissing _ _ _ _ = return () + + -- -- all the package dbs we may need to create + -- (Set.toList . Set.fromList) + -- [ pkgdb + -- | InstallPlan.Configured elab <- InstallPlan.toList installPlan + -- , pkgdb <- + -- concat + -- [ elabBuildPackageDBStack elab + -- , elabRegisterPackageDBStack elab + -- , elabSetupPackageDBStack elab + -- ] + -- ] + -- createPackageDBIfMissing + -- verbosity + -- compiler + -- progdb + -- (SpecificPackageDB dbPath) = do + -- exists <- Cabal.doesPackageDBExist dbPath + -- unless exists $ do + -- createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) + -- Cabal.createPackageDB verbosity compiler progdb False dbPath + -- createPackageDBIfMissing _ _ _ _ = return () offlineError :: BuildOutcomes offlineError = Map.fromList . map makeBuildOutcome $ packagesToDownload where @@ -457,25 +487,6 @@ rebuildTargets isRemote (RemoteSourceRepoPackage _ _) = True isRemote _ = False --- | Create a package DB if it does not currently exist. Note that this action --- is /not/ safe to run concurrently. -createPackageDBIfMissing - :: Verbosity - -> Compiler - -> ProgramDb - -> PackageDBCWD - -> IO () -createPackageDBIfMissing - verbosity - compiler - progdb - (SpecificPackageDB dbPath) = do - exists <- Cabal.doesPackageDBExist dbPath - unless exists $ do - createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) - Cabal.createPackageDB verbosity compiler progdb dbPath -createPackageDBIfMissing _ _ _ _ = return () - -- | Given all the context and resources, (re)build an individual package. rebuildTarget :: Verbosity diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 0cf5aea5308..22e88e63ccf 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -92,12 +92,12 @@ import qualified Distribution.Simple.LocalBuildInfo as Cabal import Distribution.Simple.Program import qualified Distribution.Simple.Register as Cabal import qualified Distribution.Simple.Setup as Cabal + import Distribution.Types.BuildType import Distribution.Types.PackageDescription.Lens (componentModules) import Distribution.Client.Errors import Distribution.Simple.Utils -import Distribution.System (Platform (..)) import Distribution.Utils.Path hiding ( (<.>) , () @@ -121,6 +121,11 @@ import System.Semaphore (SemaphoreName (..)) import GHC.Stack import Web.Browser (openBrowser) +import Distribution.Client.Errors +import Distribution.Compat.Directory (listDirectory) + +import Distribution.Client.ProjectBuilding.PackageFileMonitor +import Distribution.System (Platform (..)) -- | Each unpacked package is processed in the following phases: -- -- * Configure phase @@ -181,10 +186,7 @@ buildAndRegisterUnpackedPackage buildTimeSettings@BuildTimeSettings{buildSettingKeepTempFiles} registerLock cacheLock - pkgshared@ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigCompilerProgs = progdb - } + pkgshared plan rpkg@(ReadyPackage pkg) srcdir @@ -247,8 +249,8 @@ buildAndRegisterUnpackedPackage criticalSection registerLock $ Cabal.registerPackage verbosity - compiler - progdb + toolchainCompiler + toolchainProgramDb Nothing (coercePackageDBStack pkgDBStack) ipkg @@ -296,6 +298,9 @@ buildAndRegisterUnpackedPackage where uid = installedUnitId rpkg + Toolchain{toolchainCompiler, toolchainProgramDb} = + getStage (pkgConfigToolchains pkgshared) (elabStage pkg) + comp_par_strat = case maybe_semaphore of Just sem_name -> Cabal.toFlag (getSemaphoreName sem_name) _ -> Cabal.NoFlag @@ -497,7 +502,7 @@ buildInplaceUnpackedPackage buildSettings@BuildTimeSettings{buildSettingHaddockOpen} registerLock cacheLock - pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = Platform _ os} + pkgshared plan rpkg@(ReadyPackage pkg) buildStatus @@ -595,6 +600,9 @@ buildInplaceUnpackedPackage dparams = elabDistDirParams pkgshared pkg + Toolchain{toolchainPlatform = Platform _ os} = + getStage (pkgConfigToolchains pkgshared) (elabStage pkg) + packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams withFileMonitor :: IO [MonitorFilePath] -> IO () @@ -709,10 +717,7 @@ buildAndInstallUnpackedPackage buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} registerLock cacheLock - pkgshared@ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigPlatform = platform - } + pkgshared plan rpkg@(ReadyPackage pkg) srcdir @@ -766,7 +771,7 @@ buildAndInstallUnpackedPackage "registerPkg: elab does NOT require registration for " ++ prettyShow uid | otherwise = do - let packageDbStack = elabPackageDbs pkg ++ [storePackageDB storeDirLayout compiler] + let packageDbStack = elabPackageDbs pkg ++ [storePackageDB storeDirLayout toolchainCompiler] assert (elabRegisterPackageDBStack pkg == packageDbStack) (return ()) _ <- runRegister @@ -782,7 +787,7 @@ buildAndInstallUnpackedPackage newStoreEntry verbosity storeDirLayout - compiler + toolchainCompiler uid (copyPkgFiles verbosity pkgshared pkg runCopy) registerPkg @@ -820,6 +825,9 @@ buildAndInstallUnpackedPackage uid = installedUnitId rpkg pkgid = packageId rpkg + Toolchain{toolchainCompiler, toolchainPlatform} = + getStage (pkgConfigToolchains pkgshared) (elabStage pkg) + dispname :: String dispname = case elabPkgOrComp pkg of -- Packages built altogether, instead of per component @@ -844,7 +852,7 @@ buildAndInstallUnpackedPackage mlogFile = case buildSettingLogFile of Nothing -> Nothing - Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) + Just mkLogFile -> Just (mkLogFile toolchainCompiler toolchainPlatform pkgid uid) initLogFile :: IO () initLogFile = diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 4b7cca55948..0879be00630 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -135,12 +135,9 @@ import Distribution.Client.TargetSelector , reportTargetSelectorProblems ) import Distribution.Client.Types - ( DocsResult (..) - , GenericReadyPackage (..) - , PackageLocation (..) + ( GenericReadyPackage (..) , PackageSpecifier (..) , SourcePackageDb (..) - , TestsResult (..) , UnresolvedSourcePackage , WriteGhcEnvironmentFilesPolicy (..) ) @@ -149,17 +146,8 @@ import Distribution.Solver.Types.PackageIndex ) import Distribution.Solver.Types.SourcePackage (SourcePackage (..)) -import Distribution.Client.BuildReports.Anonymous (cabalInstallID) -import qualified Distribution.Client.BuildReports.Anonymous as BuildReports -import qualified Distribution.Client.BuildReports.Storage as BuildReports - ( storeLocal - ) - import Distribution.Client.HttpUtils import Distribution.Client.Setup hiding (packageName) -import Distribution.Compiler - ( CompilerFlavor (GHC) - ) import Distribution.Types.ComponentName ( componentNameString ) @@ -184,9 +172,6 @@ import Distribution.Package import Distribution.Simple.Command (commandShowOptions) import Distribution.Simple.Compiler ( OptimisationLevel (..) - , compilerCompatVersion - , compilerId - , compilerInfo , showCompilerId ) import Distribution.Simple.Configure (computeEffectiveProfiling) @@ -209,9 +194,6 @@ import Distribution.Simple.Utils , ordNub , warn ) -import Distribution.System - ( Platform (Platform) - ) import Distribution.Types.Flag ( FlagAssignment , diffFlagAssignment @@ -222,9 +204,6 @@ import Distribution.Utils.NubList ) import Distribution.Utils.Path (makeSymbolicPath) import Distribution.Verbosity -import Distribution.Version - ( mkVersion - ) #ifdef MIN_VERSION_unix import System.Posix.Signals (sigKILL, sigSEGV) @@ -490,7 +469,7 @@ runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _ runProjectPostBuildPhase verbosity ProjectBaseContext{..} - bc@ProjectBuildContext{..} + ProjectBuildContext{..} buildOutcomes = do -- Update other build artefacts -- TODO: currently none, but could include: @@ -519,21 +498,19 @@ runProjectPostBuildPhase writeGhcEnvFilesPolicy of AlwaysWriteGhcEnvironmentFiles -> True NeverWriteGhcEnvironmentFiles -> False - WriteGhcEnvironmentFilesOnlyForGhc844AndNewer -> - let compiler = pkgConfigCompiler elaboratedShared - ghcCompatVersion = compilerCompatVersion GHC compiler - in maybe False (>= mkVersion [8, 4, 4]) ghcCompatVersion - + -- FIXME: whatever + WriteGhcEnvironmentFilesOnlyForGhc844AndNewer -> True when shouldWriteGhcEnvironment $ void $ writePlanGhcEnvironment (distProjectRootDirectory distDirLayout) + Host elaboratedPlanOriginal elaboratedShared postBuildStatus -- Write the build reports - writeBuildReports buildSettings bc elaboratedPlanToExecute buildOutcomes + -- writeBuildReports buildSettings bc elaboratedPlanToExecute buildOutcomes -- Finally if there were any build failures then report them and throw -- an exception to terminate the program @@ -1184,7 +1161,8 @@ printPlan showConfigureFlags :: ElaboratedConfiguredPackage -> String showConfigureFlags elab = - let commonFlags = + let Toolchain{toolchainProgramDb} = getStage (pkgConfigToolchains elaboratedShared) (elabStage elab) + commonFlags = setupHsCommonFlags verbosity Nothing -- omit working directory @@ -1224,7 +1202,7 @@ printPlan in -- Not necessary to "escape" it, it's just for user output unwords . ("" :) $ commandShowOptions - (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared)) + (Setup.configureCommand toolchainProgramDb) partialConfigureFlags showBuildStatus :: BuildStatus -> String @@ -1256,7 +1234,8 @@ printPlan showBuildProfile = "Build profile: " ++ unwords - [ "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared + [ "-w " ++ (showCompilerId . toolchainCompiler $ getStage (pkgConfigToolchains elaboratedShared) Host) + , "-W " ++ (showCompilerId . toolchainCompiler $ getStage (pkgConfigToolchains elaboratedShared) Build) , "-O" ++ ( case globalOptimization <> localOptimization of -- if local is not set, read global Setup.Flag NoOptimisation -> "0" @@ -1267,53 +1246,53 @@ printPlan ] ++ "\n" -writeBuildReports :: BuildTimeSettings -> ProjectBuildContext -> ElaboratedInstallPlan -> BuildOutcomes -> IO () -writeBuildReports settings buildContext plan buildOutcomes = do - let plat@(Platform arch os) = pkgConfigPlatform . elaboratedShared $ buildContext - comp = pkgConfigCompiler . elaboratedShared $ buildContext - getRepo (RepoTarballPackage r _ _) = Just r - getRepo _ = Nothing - fromPlanPackage (InstallPlan.Configured pkg) (Just result) = - let installOutcome = case result of - Left bf -> case buildFailureReason bf of - GracefulFailure _ -> BuildReports.PlanningFailed - DependentFailed p -> BuildReports.DependencyFailed p - DownloadFailed _ -> BuildReports.DownloadFailed - UnpackFailed _ -> BuildReports.UnpackFailed - ConfigureFailed _ -> BuildReports.ConfigureFailed - BuildFailed _ -> BuildReports.BuildFailed - TestsFailed _ -> BuildReports.TestsFailed - InstallFailed _ -> BuildReports.InstallFailed - ReplFailed _ -> BuildReports.InstallOk - HaddocksFailed _ -> BuildReports.InstallOk - BenchFailed _ -> BuildReports.InstallOk - Right _br -> BuildReports.InstallOk - - docsOutcome = case result of - Left bf -> case buildFailureReason bf of - HaddocksFailed _ -> BuildReports.Failed - _ -> BuildReports.NotTried - Right br -> case buildResultDocs br of - DocsNotTried -> BuildReports.NotTried - DocsFailed -> BuildReports.Failed - DocsOk -> BuildReports.Ok - - testsOutcome = case result of - Left bf -> case buildFailureReason bf of - TestsFailed _ -> BuildReports.Failed - _ -> BuildReports.NotTried - Right br -> case buildResultTests br of - TestsNotTried -> BuildReports.NotTried - TestsOk -> BuildReports.Ok - in Just (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map (packageId . fst) $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files? - fromPlanPackage _ _ = Nothing - buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan - - BuildReports.storeLocal - (compilerInfo comp) - (buildSettingSummaryFile settings) - buildReports - plat +-- writeBuildReports :: BuildTimeSettings -> ProjectBuildContext -> ElaboratedInstallPlan -> BuildOutcomes -> IO () +-- writeBuildReports settings buildContext plan buildOutcomes = do +-- let plat@(Platform arch os) = pkgConfigPlatform . elaboratedShared $ buildContext +-- comp = pkgConfigCompiler . elaboratedShared $ buildContext +-- getRepo (RepoTarballPackage r _ _) = Just r +-- getRepo _ = Nothing +-- fromPlanPackage (InstallPlan.Configured pkg) (Just result) = +-- let installOutcome = case result of +-- Left bf -> case buildFailureReason bf of +-- GracefulFailure _ -> BuildReports.PlanningFailed +-- DependentFailed p -> BuildReports.DependencyFailed p +-- DownloadFailed _ -> BuildReports.DownloadFailed +-- UnpackFailed _ -> BuildReports.UnpackFailed +-- ConfigureFailed _ -> BuildReports.ConfigureFailed +-- BuildFailed _ -> BuildReports.BuildFailed +-- TestsFailed _ -> BuildReports.TestsFailed +-- InstallFailed _ -> BuildReports.InstallFailed +-- ReplFailed _ -> BuildReports.InstallOk +-- HaddocksFailed _ -> BuildReports.InstallOk +-- BenchFailed _ -> BuildReports.InstallOk +-- Right _br -> BuildReports.InstallOk + +-- docsOutcome = case result of +-- Left bf -> case buildFailureReason bf of +-- HaddocksFailed _ -> BuildReports.Failed +-- _ -> BuildReports.NotTried +-- Right br -> case buildResultDocs br of +-- DocsNotTried -> BuildReports.NotTried +-- DocsFailed -> BuildReports.Failed +-- DocsOk -> BuildReports.Ok + +-- testsOutcome = case result of +-- Left bf -> case buildFailureReason bf of +-- TestsFailed _ -> BuildReports.Failed +-- _ -> BuildReports.NotTried +-- Right br -> case buildResultTests br of +-- TestsNotTried -> BuildReports.NotTried +-- TestsOk -> BuildReports.Ok +-- in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map (packageId . fst) $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files? +-- fromPlanPackage _ _ = Nothing +-- buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan + +-- BuildReports.storeLocal +-- (compilerInfo comp) +-- (buildSettingSummaryFile settings) +-- buildReports +-- plat -- Note this doesn't handle the anonymous build reports set by buildSettingBuildReports but those appear to not be used or missed from v1 -- The usage pattern appears to be that rather than rely on flags to cabal to send build logs to the right place and package them with reports, etc, it is easier to simply capture its output to an appropriate handle. diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index 8f5f5211ec1..509fc583282 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -30,6 +30,7 @@ import qualified Distribution.Client.Utils.Json as J import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps +import qualified Distribution.Solver.Types.Stage as Stage import qualified Distribution.Compat.Binary as Binary import Distribution.Compat.Graph (Graph, Node) @@ -104,20 +105,26 @@ encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedCo encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- TODO: [nice to have] include all of the sharedPackageConfig and all of -- the parts of the elaboratedInstallPlan - J.object + J.object $ [ "cabal-version" J..= jdisplay cabalInstallVersion , "cabal-lib-version" J..= jdisplay cabalVersion - , "compiler-id" - J..= (J.String . showCompilerId . pkgConfigCompiler) - elaboratedSharedConfig - , "compiler-abi" J..= jdisplay (compilerAbiTag (pkgConfigCompiler elaboratedSharedConfig)) - , "os" J..= jdisplay os - , "arch" J..= jdisplay arch - , "install-plan" J..= installPlanToJ elaboratedInstallPlan ] + ++ toolchainJ Host + ++ toolchainJ Build + ++ ["install-plan" J..= installPlanToJ elaboratedInstallPlan] where - plat :: Platform - plat@(Platform arch os) = pkgConfigPlatform elaboratedSharedConfig + toolchains = pkgConfigToolchains elaboratedSharedConfig + + toolchainJ stage = + [ prefixed "compiler-id" J..= J.String (showCompilerId toolchainCompiler) + , prefixed "arch" J..= (jdisplay arch) + , prefixed "os" J..= (jdisplay os) + ] + where + Toolchain{toolchainCompiler, toolchainPlatform = Platform arch os} = Stage.getStage toolchains stage + prefixed s = case stage of + Stage.Build -> "build-" ++ s + Stage.Host -> s installPlanToJ :: ElaboratedInstallPlan -> [J.Value] installPlanToJ = map planPackageToJ . InstallPlan.toList @@ -158,6 +165,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = else "configured" ) , "id" J..= (jdisplay . installedUnitId) elab + , "stage" J..= jdisplay (elabStage elab) , "pkg-name" J..= (jdisplay . pkgName . packageId) elab , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab , -- The `x-revision` field is a feature of repos (not cabal itself), @@ -211,6 +219,9 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = ] ++ bin_file (compSolverName comp) where + Toolchain{toolchainPlatform = plat} = + Stage.getStage toolchains (elabStage elab) + -- \| Only add build-info file location if the Setup.hs CLI -- is recent enough to be able to generate build info files. -- Otherwise, write 'null'. @@ -817,11 +828,16 @@ createPackageEnvironmentAndArgs elaboratedPlan elaboratedShared buildStatus - | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC = + | buildCompiler /= hostCompiler = + do + warn verbosity "package environment configuration is not supported for cross-compilation; commands that need the current project's package database are likely to fail" + return ([], []) + | compilerFlavor hostCompiler == GHC = do envFileM <- writePlanGhcEnvironment path + Host elaboratedPlan elaboratedShared buildStatus @@ -834,43 +850,50 @@ createPackageEnvironmentAndArgs do warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail" return ([], []) + where + compilers = toolchainCompiler <$> pkgConfigToolchains elaboratedShared + buildCompiler = getStage compilers Build + hostCompiler = getStage compilers Host -- Writing .ghc.environment files -- writePlanGhcEnvironment :: FilePath + -> Stage -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> PostBuildProjectStatus -> IO (Maybe FilePath) writePlanGhcEnvironment path + stage elaboratedInstallPlan - ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigPlatform = platform - } - postBuildStatus - | compilerFlavor compiler == GHC - , supportsPkgEnvFiles (getImplInfo compiler) = - -- TODO: check ghcjs compat + elaboratedSharedConfig + postBuildStatus = + if (compilerFlavor toolchainCompiler == GHC && supportsPkgEnvFiles (getImplInfo toolchainCompiler)) + then -- TODO: check ghcjs compat + fmap Just $ writeGhcEnvironmentFile path - platform - (compilerVersion compiler) + toolchainPlatform + (compilerVersion toolchainCompiler) ( renderGhcEnvironmentFile path - elaboratedInstallPlan + stagePlan postBuildStatus ) + else return Nothing + where + Toolchain{..} = getStage (pkgConfigToolchains elaboratedSharedConfig) stage + -- TODO + stagePlan = InstallPlan.remove {- (\pkg -> undefined pkg /= Host) -} (const False) elaboratedInstallPlan + -- TODO: [required eventually] support for writing user-wide package -- environments, e.g. like a global project, but we would not put the -- env file in the home dir, rather it lives under ~/.ghc/ -writePlanGhcEnvironment _ _ _ _ = return Nothing - renderGhcEnvironmentFile :: FilePath -> ElaboratedInstallPlan diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 6d7fc84f381..c391608a532 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -42,6 +42,10 @@ module Distribution.Client.ProjectPlanning , ElaboratedReadyPackage , BuildStyle (..) , CabalFileText + , elabOrderLibDependencies + , elabOrderExeDependencies + , elabLibDependencies + , elabExeDependencies -- * Reading the project configuration -- $readingTheProjectConfiguration @@ -69,7 +73,7 @@ module Distribution.Client.ProjectPlanning -- * Utils required for building , pkgHasEphemeralBuildTargets , elabBuildTargetWholeComponents - , configureCompiler + , configureToolchains -- * Setup.hs CLI flags for building , setupHsScriptOptions @@ -126,7 +130,6 @@ import Distribution.Client.ProjectConfig.Types (defaultProjectFileParser) import Distribution.Client.ProjectPlanOutput import Distribution.Client.ProjectPlanning.SetupPolicy ( NonSetupLibDepSolverPlanPackage (..) - , mkDefaultSetupDeps , packageSetupScriptSpecVersion , packageSetupScriptStyle ) @@ -138,7 +141,7 @@ import Distribution.Client.Store import Distribution.Client.Targets (userToPackageConstraint) import Distribution.Client.Toolchain import Distribution.Client.Types -import Distribution.Client.Utils (concatMapM, incVersion) +import Distribution.Client.Utils (concatMapM) import qualified Distribution.Client.BuildReports.Storage as BuildReports import qualified Distribution.Client.IndexUtils as IndexUtils @@ -165,7 +168,6 @@ import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage -import qualified Distribution.Solver.Types.Stage as Stage import Distribution.ModuleName import Distribution.Package @@ -402,9 +404,10 @@ rebuildProjectConfig let fetchCompiler = do -- have to create the cache directory before configuring the compiler liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - Toolchain{toolchainCompiler, toolchainPlatform = Platform arch os} <- - configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) - pure (os, arch, toolchainCompiler) + toolchains <- configureToolchains verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) + -- The project configuration is always done with the host compiler + let Toolchain{toolchainCompiler = compiler, toolchainPlatform = Platform arch os} = getStage toolchains Host + return (os, arch, compiler) (projectConfig, _compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton when (projectConfigDistDir (projectConfigShared $ projectConfig) /= NoFlag) $ @@ -500,12 +503,12 @@ rebuildProjectConfig $ projectConfigProvenance projectConfig ] -configureCompiler +configureToolchains :: Verbosity -> DistDirLayout -> ProjectConfig - -> Rebuild Toolchain -configureCompiler + -> Rebuild Toolchains +configureToolchains verbosity DistDirLayout { distProjectCacheFile @@ -513,7 +516,17 @@ configureCompiler ProjectConfig { projectConfigShared = ProjectConfigShared - { projectConfigToolchain + { projectConfigToolchain = + ProjectConfigToolchain + { projectConfigHcFlavor + , projectConfigHcPath + , projectConfigHcPkg + , projectConfigPackageDBs + , projectConfigBuildHcFlavor + , projectConfigBuildHcPath + , projectConfigBuildHcPkg + , projectConfigBuildPackageDBs + } , projectConfigProgPathExtra } , projectConfigLocalPackages = @@ -522,17 +535,18 @@ configureCompiler , packageConfigProgramPathExtra } } = do - let fileMonitorCompiler = newFileMonitor $ distProjectCacheFile "compiler" + let fileMonitorBuildCompiler = newFileMonitor $ distProjectCacheFile "build-compiler" + fileMonitorHostCompiler = newFileMonitor $ distProjectCacheFile "host-compiler" progsearchpath <- liftIO getSystemSearchPath - (toolchainCompiler, toolchainPlatform, tempProgDb) <- + (buildHc, buildPlat, buildHcProgDb) <- rerunIfChanged verbosity - fileMonitorCompiler - ( hcFlavor - , hcPath - , hcPkg + fileMonitorBuildCompiler + ( buildHcFlavor + , buildHcPath + , buildHcPkg , progsearchpath , packageConfigProgramPaths , packageConfigProgramPathExtra @@ -549,8 +563,44 @@ configureCompiler result@(_, _, progdb') <- liftIO $ Cabal.configCompiler - hcFlavor - hcPath + buildHcFlavor + buildHcPath + progdb + verbosity + -- Note that we added the user-supplied program locations and args + -- for /all/ programs, not just those for the compiler prog and + -- compiler-related utils. In principle we don't know which programs + -- the compiler will configure (and it does vary between compilers). + -- We do know however that the compiler will only configure the + -- programs it cares about, and those are the ones we monitor here. + monitorFiles (programsMonitorFiles progdb') + return result + + (hostHc, hostPlat, hostHcProgDb) <- + rerunIfChanged + verbosity + fileMonitorHostCompiler + ( hostHcFlavor + , hostHcPath + , hostHcPkg + , progsearchpath + , packageConfigProgramPaths + , packageConfigProgramPathExtra + ) + $ do + liftIO $ info verbosity "Compiler settings changed, reconfiguring..." + progdb <- + liftIO $ + -- Add paths in the global config + prependProgramSearchPath verbosity (fromNubList projectConfigProgPathExtra) [] defaultProgramDb + -- Add paths in the local config + >>= prependProgramSearchPath verbosity (fromNubList packageConfigProgramPathExtra) [] + >>= pure . userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) + result@(_, _, progdb') <- + liftIO $ + Cabal.configCompiler + hostHcFlavor + hostHcPath progdb verbosity -- Note that we added the user-supplied program locations and args @@ -566,13 +616,32 @@ configureCompiler -- auxiliary unconfigured programs to the ProgramDb (e.g. hc-pkg, haddock, ar, ld...). -- -- See Note [Caching the result of configuring the compiler] - toolchainProgramDb <- liftIO $ Cabal.configCompilerProgDb verbosity toolchainCompiler tempProgDb hcPkg - let toolchainPackageDBs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs projectConfigToolchain) - return Toolchain{..} + finalBuildProgDb <- liftIO $ Cabal.configCompilerProgDb verbosity buildHc buildHcProgDb buildHcPkg + finalHostProgDb <- liftIO $ Cabal.configCompilerProgDb verbosity hostHc hostHcProgDb hostHcPkg + + return $ Staged $ \case + Build -> + Toolchain + { toolchainCompiler = buildHc + , toolchainPlatform = buildPlat + , toolchainProgramDb = finalBuildProgDb + , toolchainPackageDBs = Cabal.interpretPackageDbFlags False projectConfigBuildPackageDBs + } + Host -> + Toolchain + { toolchainCompiler = hostHc + , toolchainPlatform = hostPlat + , toolchainProgramDb = finalHostProgDb + , toolchainPackageDBs = Cabal.interpretPackageDbFlags False projectConfigPackageDBs + } where - hcFlavor = flagToMaybe (projectConfigHcFlavor projectConfigToolchain) - hcPath = flagToMaybe (projectConfigHcPath projectConfigToolchain) - hcPkg = flagToMaybe (projectConfigHcPkg projectConfigToolchain) + hostHcFlavor = flagToMaybe projectConfigHcFlavor + hostHcPath = flagToMaybe projectConfigHcPath + hostHcPkg = flagToMaybe projectConfigHcPkg + -- Use the host compiler if a separate build compiler is not specified + buildHcFlavor = flagToMaybe projectConfigBuildHcFlavor <|> flagToMaybe projectConfigHcFlavor + buildHcPath = flagToMaybe projectConfigBuildHcPath <|> flagToMaybe projectConfigHcPath + buildHcPkg = flagToMaybe projectConfigBuildHcPkg <|> flagToMaybe projectConfigHcPkg {- Note [Caching the result of configuring the compiler] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -677,27 +746,30 @@ rebuildInstallPlan , progsearchpath ) $ do - toolchain <- phaseConfigureCompiler projectConfig - _ <- phaseConfigurePrograms projectConfig toolchain - (solverPlan, pkgConfigDB, totalIndexState, activeRepos) <- + toolchains <- phaseConfigureToolchains projectConfig + phaseConfigurePrograms projectConfig toolchains + (solverPlan, _, pkgConfigDBs, totalIndexState, activeRepos) <- phaseRunSolver projectConfig - toolchain + toolchains localPackages (fromMaybe mempty mbInstalledPackages) - ( elaboratedPlan - , elaboratedShared - ) <- + + (elaboratedPlan, elaboratedShared) <- phaseElaboratePlan projectConfig - toolchain - pkgConfigDB + toolchains + pkgConfigDBs solverPlan localPackages phaseMaintainPlanOutputs elaboratedPlan elaboratedShared return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) + -- \| Given the 'InstalledPackageIndex' for a nix-style package store, and an + -- 'ElaboratedInstallPlan', replace configured source packages by installed + -- packages from the store whenever they exist. + -- -- The improved plan changes each time we install something, whereas -- the underlying elaborated plan only changes when input config -- changes, so it's worth caching them separately. @@ -718,10 +790,16 @@ rebuildInstallPlan -- This is moderately expensive and doesn't change that often so we cache -- it independently. -- - phaseConfigureCompiler + phaseConfigureToolchains :: ProjectConfig - -> Rebuild Toolchain - phaseConfigureCompiler = configureCompiler verbosity distDirLayout + -> Rebuild Toolchains + phaseConfigureToolchains projectConfig = do + toolchains <- configureToolchains verbosity distDirLayout projectConfig + liftIO $ do + putStrLn "Toolchains:" + for_ stages $ \s -> + print $ Disp.hsep [Disp.text "-" <+> pretty s <+> Disp.text "compiler" <+> pretty (compilerId (toolchainCompiler (getStage toolchains s)))] + return toolchains -- Configuring other programs. -- @@ -737,17 +815,18 @@ rebuildInstallPlan -- phaseConfigurePrograms :: ProjectConfig - -> Toolchain + -> Toolchains -> Rebuild () - phaseConfigurePrograms projectConfig toolchain = do + phaseConfigurePrograms projectConfig toolchains = do -- Users are allowed to specify program locations independently for -- each package (e.g. to use a particular version of a pre-processor -- for some packages). However they cannot do this for the compiler -- itself as that's just not going to work. So we check for this. - liftIO $ - checkBadPerPackageCompilerPaths - (configuredPrograms (toolchainProgramDb toolchain)) - (getMapMappend (projectConfigSpecificPackage projectConfig)) + for_ toolchains $ \Toolchain{toolchainProgramDb} -> + liftIO $ + checkBadPerPackageCompilerPaths + (configuredPrograms toolchainProgramDb) + (getMapMappend (projectConfigSpecificPackage projectConfig)) -- TODO: [required eventually] find/configure other programs that the -- user specifies. @@ -760,48 +839,42 @@ rebuildInstallPlan -- phaseRunSolver :: ProjectConfig - -> Toolchain + -> Toolchains -> [PackageSpecifier UnresolvedSourcePackage] -> InstalledPackageIndex - -> Rebuild (SolverInstallPlan, Maybe PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) + -> Rebuild + ( SolverInstallPlan + , Staged InstalledPackageIndex + , Staged (Maybe PkgConfigDb) + , IndexUtils.TotalIndexState + , IndexUtils.ActiveRepos + ) phaseRunSolver projectConfig@ProjectConfig { projectConfigShared , projectConfigBuildOnly } - Toolchain - { toolchainCompiler = compiler - , toolchainPlatform = platform - , toolchainProgramDb = progdb - } - -- \^ The compiler and platform to use for the solver. + toolchains localPackages - installedPackages = + _installedPackages = rerunIfChanged verbosity fileMonitorSolverPlan ( solverSettings , localPackages , localPackagesEnabledStanzas - , compiler - , platform - , programDbSignature progdb + , toolchains ) $ do - installedPkgIndex <- - getInstalledPackages - verbosity - compiler - progdb - platform - corePackageDbs (sourcePkgDb, tis, ar) <- getSourcePackages verbosity withRepoCtx (solverSettingIndexState solverSettings) (solverSettingActiveRepos solverSettings) - pkgConfigDB <- getPkgConfigDb verbosity progdb + + ipis <- for toolchains (\t -> getInstalledPackages verbosity t corePackageDbs) + pkgConfigDbs <- for toolchains (getPkgConfigDb verbosity . toolchainProgramDb) -- TODO: [code cleanup] it'd be better if the Compiler contained the -- ConfiguredPrograms that it needs, rather than relying on the progdb @@ -814,20 +887,26 @@ rebuildInstallPlan foldProgress logMsg (pure . Left) (pure . Right) $ planPackages verbosity - compiler - platform solverSettings - (installedPackages <> installedPkgIndex) + compilerAndPlatform + pkgConfigDbs + ipis sourcePkgDb - pkgConfigDB localPackages localPackagesEnabledStanzas case planOrError of Left msg -> do - reportPlanningFailure projectConfig compiler platform localPackages + -- TODO + for_ toolchains $ \(Toolchain{toolchainCompiler, toolchainPlatform}) -> + reportPlanningFailure projectConfig toolchainCompiler toolchainPlatform localPackages dieWithException verbosity $ PhaseRunSolverErr msg - Right plan -> return (plan, pkgConfigDB, tis, ar) + Right plan -> return (plan, ipis, pkgConfigDbs, tis, ar) where + compilerAndPlatform = + fmap + (\Toolchain{toolchainCompiler, toolchainPlatform} -> (compilerInfo toolchainCompiler, toolchainPlatform)) + toolchains + corePackageDbs :: PackageDBStackCWD corePackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain projectConfigShared)) @@ -879,8 +958,8 @@ rebuildInstallPlan -- phaseElaboratePlan :: ProjectConfig - -> Toolchain - -> Maybe PkgConfigDb + -> Staged Toolchain + -> Staged (Maybe PkgConfigDb) -> SolverInstallPlan -> [PackageSpecifier (SourcePackage (PackageLocation loc))] -> Rebuild @@ -895,7 +974,7 @@ rebuildInstallPlan , projectConfigSpecificPackage , projectConfigBuildOnly } - Toolchain{..} + toolchains pkgConfigDB solverPlan localPackages = do @@ -908,15 +987,17 @@ rebuildInstallPlan (packageLocationsSignature solverPlan) $ getPackageSourceHashes verbosity withRepoCtx solverPlan - defaultInstallDirs <- liftIO $ userInstallDirTemplates toolchainCompiler - let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) + installDirs <- + for toolchains $ \t -> do + defaultInstallDirs <- liftIO $ userInstallDirTemplates (toolchainCompiler t) + return $ fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) + (elaboratedPlan, elaboratedShared) <- - liftIO . runLogProgress verbosity $ - elaborateInstallPlan + liftIO + . runLogProgress verbosity + $ elaborateInstallPlan verbosity - toolchainPlatform - toolchainCompiler - toolchainProgramDb + toolchains pkgConfigDB distDirLayout cabalStoreDirLayout @@ -975,11 +1056,7 @@ rebuildInstallPlan -> Rebuild ElaboratedInstallPlan phaseImprovePlan elaboratedPlan elaboratedShared = do liftIO $ debug verbosity "Improving the install plan..." - storePkgIdSet <- getStoreEntries cabalStoreDirLayout compiler - let improvedPlan = - improveInstallPlanWithInstalledPackages - storePkgIdSet - elaboratedPlan + improvedPlan <- liftIO $ InstallPlan.installedM canBeImproved elaboratedPlan liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan improvedPlan) -- TODO: [nice to have] having checked which packages from the store -- we're using, it may be sensible to sanity check those packages @@ -987,7 +1064,9 @@ rebuildInstallPlan -- matches up as expected, e.g. no dangling deps, files deleted. return improvedPlan where - compiler = pkgConfigCompiler elaboratedShared + canBeImproved pkg = do + let Toolchain{toolchainCompiler} = getStage (pkgConfigToolchains elaboratedShared) (elabStage pkg) + doesStoreEntryExist cabalStoreDirLayout toolchainCompiler (installedUnitId pkg) -- | If a 'PackageSpecifier' refers to a single package, return Just that -- package. @@ -1042,28 +1121,27 @@ programsMonitorFiles progdb = getInstalledPackages :: Verbosity - -> Compiler - -> ProgramDb - -> Platform + -> Toolchain -> PackageDBStackCWD -> Rebuild InstalledPackageIndex -getInstalledPackages verbosity compiler progdb platform packagedbs = do - monitorFiles . map monitorFileOrDirectory +getInstalledPackages verbosity Toolchain{toolchainCompiler, toolchainPlatform, toolchainProgramDb} packagedbs = do + monitorFiles + . map monitorFileOrDirectory =<< liftIO ( IndexUtils.getInstalledPackagesMonitorFiles verbosity - compiler + toolchainCompiler Nothing -- use ambient working directory (coercePackageDBStack packagedbs) - progdb - platform + toolchainProgramDb + toolchainPlatform ) liftIO $ IndexUtils.getInstalledPackages verbosity - compiler + toolchainCompiler packagedbs - progdb + toolchainProgramDb {- --TODO: [nice to have] use this but for sanity / consistency checking @@ -1091,9 +1169,10 @@ getSourcePackages getSourcePackages verbosity withRepoCtx idxState activeRepos = do (sourcePkgDbWithTIS, repos) <- liftIO $ - withRepoCtx $ \repoctx -> do - sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos - return (sourcePkgDbWithTIS, repoContextRepos repoctx) + withRepoCtx $ + \repoctx -> do + sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos + return (sourcePkgDbWithTIS, repoContextRepos repoctx) traverse_ needIfExists . IndexUtils.getSourcePackagesMonitorFiles @@ -1216,8 +1295,8 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do -- the hashes for the packages -- hashesFromRepoMetadata <- - Sec.uncheckClientErrors $ -- TODO: [code cleanup] wrap in our own exceptions - fmap (Map.fromList . concat) $ + Sec.uncheckClientErrors $ + fmap (Map.fromList . concat) $ -- TODO: [code cleanup] wrap in our own exceptions sequence -- Reading the repo index is expensive so we group the packages by repo [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> @@ -1295,30 +1374,24 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do planPackages :: Verbosity - -> Compiler - -> Platform -> SolverSettings - -> InstalledPackageIndex + -> Staged (CompilerInfo, Platform) + -> Staged (Maybe PkgConfigDb) + -> Staged InstalledPackageIndex -> SourcePackageDb - -> Maybe PkgConfigDb -> [PackageSpecifier UnresolvedSourcePackage] -> Map PackageName (Map OptionalStanza Bool) -> Progress String String SolverInstallPlan planPackages verbosity - comp - platform SolverSettings{..} - installedPkgIndex - sourcePkgDb - pkgConfigDB + toolchains + pkgConfigDbs + installedPkgs + sourcePkgs localPackages pkgStanzasEnable = - resolveDependencies - (Stage.always (compilerInfo comp, platform)) - (Stage.always pkgConfigDB) - (Stage.always installedPkgIndex) - resolverParams + resolveDependencies toolchains pkgConfigDbs installedPkgs resolverParams where -- TODO: [nice to have] disable multiple instances restriction in -- the solver, but then make sure we can cope with that in the @@ -1358,14 +1431,18 @@ planPackages . removeLowerBounds solverSettingAllowOlder . removeUpperBounds solverSettingAllowNewer - . addDefaultSetupDependencies - setImplicitSetupInfo - ( mkDefaultSetupDeps comp platform - . PD.packageDescription - . srcpkgDescription - ) - . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint - . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint + -- + -- TODO: These need to be per compiler. We should be able to do that + -- when we can use the stage as a solver scope + -- + -- . addDefaultSetupDependencies + -- ( mkDefaultSetupDeps compiler platform + -- . PD.packageDescription + -- . srcpkgDescription + -- ) + -- . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint + -- . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint + -- . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver @@ -1389,7 +1466,9 @@ planPackages , not (null stanzas) ] . addConstraints - -- enable stanza constraints where the user asked to enable + -- Enable stanza constraints where the user asked to enable + -- Only applies to the host stage. + -- TODO: Disable test and bench for build stage packages. [ LabeledPackageConstraint ( PackageConstraint (scopeToplevel pkgname) @@ -1438,80 +1517,9 @@ planPackages -- Note: we don't use the standardInstallPolicy here, since that uses -- its own addDefaultSetupDependencies that is not appropriate for us. basicInstallPolicy - sourcePkgDb + sourcePkgs localPackages - -- While we can talk to older Cabal versions (we need to be able to - -- do so for custom Setup scripts that require older Cabal lib - -- versions), we have problems talking to some older versions that - -- don't support certain features. - -- - -- For example, Cabal-1.16 and older do not know about build targets. - -- Even worse, 1.18 and older only supported the --constraint flag - -- with source package ids, not --dependency with installed package - -- ids. That is bad because we cannot reliably select the right - -- dependencies in the presence of multiple instances (i.e. the - -- store). See issue #3932. So we require Cabal 1.20 as a minimum. - -- - -- Moreover, lib:Cabal generally only supports the interface of - -- current and past compilers; in fact recent lib:Cabal versions - -- will warn when they encounter a too new or unknown GHC compiler - -- version (c.f. #415). To avoid running into unsupported - -- configurations we encode the compatibility matrix as lower - -- bounds on lib:Cabal here (effectively corresponding to the - -- respective major Cabal version bundled with the respective GHC - -- release). - -- - -- GHC 9.2 needs Cabal >= 3.6 - -- GHC 9.0 needs Cabal >= 3.4 - -- GHC 8.10 needs Cabal >= 3.2 - -- GHC 8.8 needs Cabal >= 3.0 - -- GHC 8.6 needs Cabal >= 2.4 - -- GHC 8.4 needs Cabal >= 2.2 - -- GHC 8.2 needs Cabal >= 2.0 - -- GHC 8.0 needs Cabal >= 1.24 - -- - -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is - -- the absolute lower bound) - -- - -- TODO: long-term, this compatibility matrix should be - -- stored as a field inside 'Distribution.Compiler.Compiler' - setupMinCabalVersionConstraint - | isGHC, compVer >= mkVersion [9, 10] = mkVersion [3, 12] - | isGHC, compVer >= mkVersion [9, 6] = mkVersion [3, 10] - | isGHC, compVer >= mkVersion [9, 4] = mkVersion [3, 8] - | isGHC, compVer >= mkVersion [9, 2] = mkVersion [3, 6] - | isGHC, compVer >= mkVersion [9, 0] = mkVersion [3, 4] - | isGHC, compVer >= mkVersion [8, 10] = mkVersion [3, 2] - | isGHC, compVer >= mkVersion [8, 8] = mkVersion [3, 0] - | isGHC, compVer >= mkVersion [8, 6] = mkVersion [2, 4] - | isGHC, compVer >= mkVersion [8, 4] = mkVersion [2, 2] - | isGHC, compVer >= mkVersion [8, 2] = mkVersion [2, 0] - | otherwise = mkVersion [1, 24] - where - isGHC = compFlav `elem` [GHC, GHCJS] - compFlav = compilerFlavor comp - compVer = compilerVersion comp - - -- As we can't predict the future, we also place a global upper - -- bound on the lib:Cabal version we know how to interact with: - -- - -- The upper bound is computed by incrementing the current major - -- version twice in order to allow for the current version, as - -- well as the next adjacent major version (one of which will not - -- be released, as only "even major" versions of Cabal are - -- released to Hackage or bundled with proper GHC releases). - -- - -- For instance, if the current version of cabal-install is an odd - -- development version, e.g. Cabal-2.1.0.0, then we impose an - -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a - -- stable/release even version, e.g. Cabal-2.2.1.0, the upper - -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility - -- when dealing with development snapshots of Cabal and cabal-install. - -- - setupMaxCabalVersionConstraint = - alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion - ------------------------------------------------------------------------------ -- * Install plan post-processing @@ -1617,16 +1625,14 @@ planPackages -- matching that of the classic @cabal install --user@ or @--global@ elaborateInstallPlan :: Verbosity - -> Platform - -> Compiler - -> ProgramDb - -> Maybe PkgConfigDb + -> Staged Toolchain + -> Staged (Maybe PkgConfigDb) -> DistDirLayout -> StoreDirLayout -> SolverInstallPlan -> [PackageSpecifier (SourcePackage (PackageLocation loc))] -> Map PackageId PackageSourceHash - -> InstallDirs.InstallDirTemplates + -> Staged InstallDirs.InstallDirTemplates -> ProjectConfigShared -> PackageConfig -> PackageConfig @@ -1634,9 +1640,7 @@ elaborateInstallPlan -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) elaborateInstallPlan verbosity - platform - compiler - compilerprogdb + toolchains pkgConfigDB distDirLayout@DistDirLayout{..} storeDirLayout@StoreDirLayout{storePackageDBStack} @@ -1653,9 +1657,7 @@ elaborateInstallPlan where elaboratedSharedConfig = ElaboratedSharedConfig - { pkgConfigPlatform = platform - , pkgConfigCompiler = compiler - , pkgConfigCompilerProgs = compilerprogdb + { pkgConfigToolchains = toolchains , pkgConfigReplOptions = mempty } @@ -2019,7 +2021,7 @@ elaborateInstallPlan ++ " from " ++ prettyShow (elabPkgSourceId elab0) ) - (pkgConfigDB >>= \db -> pkgConfigDbPkgVersion db pn) + (getStage pkgConfigDB (elabStage elab0) >>= \db -> pkgConfigDbPkgVersion db pn) ) | PkgconfigDependency pn _ <- PD.pkgconfigDepends @@ -2189,7 +2191,7 @@ elaborateInstallPlan -> (ElaboratedConfiguredPackage, LogProgress ()) elaborateSolverToCommon pkg@( SolverPackage - _stage + stage _qpn (SourcePackage pkgid gdesc srcloc descOverride) flags @@ -2218,12 +2220,18 @@ elaborateInstallPlan elabIsCanonical = True elabPkgSourceId = pkgid + + elabStage = stage + elabCompiler = toolchainCompiler (getStage toolchains stage) + elabPlatform = toolchainPlatform (getStage toolchains stage) + elabProgramDb = toolchainProgramDb (getStage toolchains stage) + elabPkgDescription = case PD.finalizePD flags elabEnabledSpec (const Satisfied) - platform - (compilerInfo compiler) + elabPlatform + (compilerInfo elabCompiler) [] gdesc of Right (desc, _) -> desc @@ -2299,6 +2307,10 @@ elaborateInstallPlan deps0 elabSetupPackageDBStack = buildAndRegisterDbs + inplacePackageDbs = corePackageDbs ++ [distPackageDB (compilerId elabCompiler)] + + corePackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain sharedPackageConfig)) ++ [storePackageDB storeDirLayout elabCompiler] + elabInplaceBuildPackageDBStack = inplacePackageDbs elabInplaceRegisterPackageDBStack = inplacePackageDbs elabInplaceSetupPackageDBStack = inplacePackageDbs @@ -2345,7 +2357,7 @@ elaborateInstallPlan , withProfLibDetail = elabProfExeDetail , withProfExeDetail = elabProfLibDetail } - okProfDyn = profilingDynamicSupportedOrUnknown compiler + okProfDyn = profilingDynamicSupportedOrUnknown elabCompiler profExe = perPkgOptionFlag pkgid False packageConfigProf elabBuildOptions = Cabal.adjustBuildOptions compiler compilerprogdb elabBuildOptionsRaw @@ -2369,36 +2381,22 @@ elaborateInstallPlan elabProgramPaths = Map.fromList [ (programId prog, programPath prog) - | prog <- configuredPrograms compilerprogdb + | prog <- configuredPrograms elabProgramDb ] <> perPkgOptionMapLast pkgid packageConfigProgramPaths elabProgramArgs = - -- Workaround for - -- - -- It turns out that, even with Cabal 2.0, there's still cases such as e.g. - -- custom Setup.hs scripts calling out to GHC even when going via - -- @runProgram ghcProgram@, as e.g. happy does in its - -- - -- (see also ) - -- - -- So for now, let's pass the rather harmless and idempotent - -- `-hide-all-packages` flag to all invocations (which has - -- the benefit that every GHC invocation starts with a - -- consistently well-defined clean slate) until we find a - -- better way. - Map.insertWith (++) "ghc" ["-hide-all-packages"] $ - Map.unionWith - (++) - ( Map.fromList - [ (programId prog, args) - | prog <- configuredPrograms compilerprogdb - , let args = programOverrideArgs $ addHaddockIfDocumentationEnabled prog - , not (null args) - ] - ) - (perPkgOptionMapMappend pkgid packageConfigProgramArgs) + Map.unionWith + (++) + ( Map.fromList + [ (programId prog, args) + | prog <- configuredPrograms elabProgramDb + , let args = programOverrideArgs $ addHaddockIfDocumentationEnabled prog + , not (null args) + ] + ) + (perPkgOptionMapMappend pkgid packageConfigProgramArgs) elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra - elabConfiguredPrograms = configuredPrograms compilerprogdb + elabConfiguredPrograms = configuredPrograms elabProgramDb elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs elabExtraLibDirsStatic = perPkgOptionList pkgid packageConfigExtraLibDirsStatic @@ -2475,12 +2473,6 @@ elaborateInstallPlan mempty perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) - inplacePackageDbs = - corePackageDbs - ++ [distPackageDB (compilerId compiler)] - - corePackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain sharedPackageConfig)) ++ [storePackageDB storeDirLayout compiler] - -- For this local build policy, every package that lives in a local source -- dir (as opposed to a tarball), or depends on such a package, will be -- built inplace into a shared dist dir. Tarball packages that depend on @@ -2839,7 +2831,12 @@ extractElabBuildStyle _ = BuildAndInstall -- * We use the state monad to cache already instantiated modules, so -- we don't instantiate the same thing multiple times. -- -instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan +instantiateInstallPlan + :: StoreDirLayout + -> Staged InstallDirs.InstallDirTemplates + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedInstallPlan instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = InstallPlan.new (IndependentGoals False) @@ -3915,8 +3912,9 @@ setupHsScriptOptions -- - if we commit to a Cabal version, the logic in Nothing else Just elabSetupScriptCliVersion - , useCompiler = Just pkgConfigCompiler - , usePlatform = Just pkgConfigPlatform + , useCompiler = Just toolchainCompiler + , usePlatform = Just toolchainPlatform + , useProgramDb = toolchainProgramDb , usePackageDB = elabSetupPackageDBStack , usePackageIndex = Nothing , useDependencies = @@ -3926,7 +3924,6 @@ setupHsScriptOptions ] , useDependenciesExclusive = True , useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps - , useProgramDb = pkgConfigCompilerProgs , useDistPref = builddir , useLoggingHandle = Nothing -- this gets set later , useWorkingDir = Just srcdir @@ -3949,6 +3946,10 @@ setupHsScriptOptions -- everything else is not a main lib or exe component ElabComponent _ -> False } + where + Toolchain{toolchainCompiler, toolchainPlatform, toolchainProgramDb} = + -- TODO: It is disappointing that we have to change the stage here + getStage pkgConfigToolchains (prevStage elabStage) -- | To be used for the input for elaborateInstallPlan. -- @@ -4011,20 +4012,21 @@ storePackageInstallDirs' computeInstallDirs :: StoreDirLayout - -> InstallDirs.InstallDirTemplates + -> Staged InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> InstallDirs.InstallDirs FilePath -computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab - | isInplaceBuildStyle (elabBuildStyle elab) = - -- use the ordinary default install dirs +computeInstallDirs storeDirLayout defaultInstallDirs sharedConfig elab = + if isInplaceBuildStyle (elabBuildStyle elab) + then -- use the ordinary default install dirs + ( InstallDirs.absoluteInstallDirs (elabPkgSourceId elab) (elabUnitId elab) - (compilerInfo (pkgConfigCompiler elaboratedShared)) + (compilerInfo toolchainCompiler) InstallDirs.NoCopyDest - (pkgConfigPlatform elaboratedShared) - defaultInstallDirs + toolchainPlatform + defaultInstallDirs' ) { -- absoluteInstallDirs sets these as 'undefined' but we have -- to use them as "Setup.hs configure" args @@ -4032,12 +4034,15 @@ computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab , InstallDirs.libexecsubdir = "" , InstallDirs.datasubdir = "" } - | otherwise = - -- use special simplified install dirs + else -- use special simplified install dirs + storePackageInstallDirs' storeDirLayout - (pkgConfigCompiler elaboratedShared) + toolchainCompiler (elabUnitId elab) + where + Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains sharedConfig) (elabStage elab) + defaultInstallDirs' = getStage defaultInstallDirs (elabStage elab) -- TODO: [code cleanup] perhaps reorder this code -- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, @@ -4057,7 +4062,7 @@ setupHsConfigureFlags mkSymbolicPath plan (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - sharedConfig@ElaboratedSharedConfig{..} + sharedConfig configCommonFlags = do -- explicitly clear, then our package db stack -- TODO: [required eventually] have to do this differently for older Cabal versions @@ -4068,6 +4073,8 @@ setupHsConfigureFlags elab Cabal.ConfigFlags{..} where + Toolchain{toolchainCompiler} = getStage (pkgConfigToolchains sharedConfig) elabStage + Cabal.ConfigFlags { configVanillaLib , configSharedLib @@ -4110,7 +4117,7 @@ setupHsConfigureFlags configProgramPaths = Map.toList elabProgramPaths configProgramArgs = Map.toList elabProgramArgs configProgramPathExtra = toNubList elabProgramPathExtra - configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) + configHcFlavor = toFlag (compilerFlavor toolchainCompiler) configHcPath = mempty -- we use configProgramPaths instead configHcPkg = mempty -- we use configProgramPaths instead configDumpBuildInfo = toFlag elabDumpBuildInfo @@ -4168,7 +4175,7 @@ setupHsConfigureFlags configUserInstall = mempty -- don't rely on defaults configPrograms_ = mempty -- never use, shouldn't exist configUseResponseFiles = mempty - configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler + configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported toolchainCompiler configIgnoreBuildTools = mempty cidToGivenComponent :: ConfiguredId -> GivenComponent @@ -4344,13 +4351,13 @@ setupHsHaddockFlags -> Cabal.HaddockFlags setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) - (ElaboratedSharedConfig{..}) + sharedConfig _buildTimeSettings common = Cabal.HaddockFlags { haddockCommonFlags = common , haddockProgramPaths = - case lookupProgram haddockProgram pkgConfigCompilerProgs of + case lookupProgram haddockProgram toolchainProgramDb of Nothing -> mempty Just prg -> [ @@ -4379,6 +4386,8 @@ setupHsHaddockFlags , haddockOutputDir = maybe mempty toFlag elabHaddockOutputDir , haddockUseUnicode = toFlag elabHaddockUseUnicode } + where + Toolchain{toolchainProgramDb} = getStage (pkgConfigToolchains sharedConfig) elabStage setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String] -- TODO: Does the issue #3335 affects test as well @@ -4488,11 +4497,11 @@ packageHashConfigInputs :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> PackageHashConfigInputs -packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg = +packageHashConfigInputs sharedConfig pkg = PackageHashConfigInputs - { pkgHashCompilerId = compilerId pkgConfigCompiler - , pkgHashCompilerABI = compilerAbiTag pkgConfigCompiler - , pkgHashPlatform = pkgConfigPlatform + { pkgHashCompilerId = compilerId toolchainCompiler + , pkgHashCompilerABI = compilerAbiTag toolchainCompiler + , pkgHashPlatform = toolchainPlatform , pkgHashFlagAssignment = elabFlagAssignment , pkgHashConfigureScriptArgs = elabConfigureScriptArgs , pkgHashVanillaLib = withVanillaLib @@ -4540,22 +4549,10 @@ packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg = , pkgHashHaddockUseUnicode = elabHaddockUseUnicode } where - ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg + Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains sharedConfig) elabStage + ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage sharedConfig pkg LBC.BuildOptions{..} = elabBuildOptions --- | Given the 'InstalledPackageIndex' for a nix-style package store, and an --- 'ElaboratedInstallPlan', replace configured source packages by installed --- packages from the store whenever they exist. -improveInstallPlanWithInstalledPackages - :: Set UnitId - -> ElaboratedInstallPlan - -> ElaboratedInstallPlan -improveInstallPlanWithInstalledPackages installedPkgIdSet = - InstallPlan.installed canPackageBeImproved - where - canPackageBeImproved pkg = - installedUnitId pkg `Set.member` installedPkgIdSet - -- TODO: sanity checks: -- \* the installed package must have the expected deps etc -- \* the installed package must not be broken, valid dep closure @@ -4637,3 +4634,80 @@ determineCoverageFor configuredPkg plan = isIndefiniteOrInstantiation :: ModuleShape -> Bool isIndefiniteOrInstantiation = not . Set.null . modShapeRequires + +-- While we can talk to older Cabal versions (we need to be able to +-- do so for custom Setup scripts that require older Cabal lib +-- versions), we have problems talking to some older versions that +-- don't support certain features. +-- +-- For example, Cabal-1.16 and older do not know about build targets. +-- Even worse, 1.18 and older only supported the --constraint flag +-- with source package ids, not --dependency with installed package +-- ids. That is bad because we cannot reliably select the right +-- dependencies in the presence of multiple instances (i.e. the +-- store). See issue #3932. So we require Cabal 1.20 as a minimum. +-- +-- Moreover, lib:Cabal generally only supports the interface of +-- current and past compilers; in fact recent lib:Cabal versions +-- will warn when they encounter a too new or unknown GHC compiler +-- version (c.f. #415). To avoid running into unsupported +-- configurations we encode the compatibility matrix as lower +-- bounds on lib:Cabal here (effectively corresponding to the +-- respective major Cabal version bundled with the respective GHC +-- release). +-- +-- GHC 9.2 needs Cabal >= 3.6 +-- GHC 9.0 needs Cabal >= 3.4 +-- GHC 8.10 needs Cabal >= 3.2 +-- GHC 8.8 needs Cabal >= 3.0 +-- GHC 8.6 needs Cabal >= 2.4 +-- GHC 8.4 needs Cabal >= 2.2 +-- GHC 8.2 needs Cabal >= 2.0 +-- GHC 8.0 needs Cabal >= 1.24 +-- GHC 7.10 needs Cabal >= 1.22 +-- +-- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is +-- the absolute lower bound) +-- +-- TODO: long-term, this compatibility matrix should be +-- stored as a field inside 'Distribution.Compiler.Compiler' +-- +-- setupMinCabalVersionConstraint :: Compiler -> Version +-- setupMinCabalVersionConstraint compiler +-- | isGHC, compVer >= mkVersion [9, 10] = mkVersion [3, 12] +-- | isGHC, compVer >= mkVersion [9, 6] = mkVersion [3, 10] +-- | isGHC, compVer >= mkVersion [9, 4] = mkVersion [3, 8] +-- | isGHC, compVer >= mkVersion [9, 2] = mkVersion [3, 6] +-- | isGHC, compVer >= mkVersion [9, 0] = mkVersion [3, 4] +-- | isGHC, compVer >= mkVersion [8, 10] = mkVersion [3, 2] +-- | isGHC, compVer >= mkVersion [8, 8] = mkVersion [3, 0] +-- | isGHC, compVer >= mkVersion [8, 6] = mkVersion [2, 4] +-- | isGHC, compVer >= mkVersion [8, 4] = mkVersion [2, 2] +-- | isGHC, compVer >= mkVersion [8, 2] = mkVersion [2, 0] +-- | isGHC, compVer >= mkVersion [8, 0] = mkVersion [1, 24] +-- | isGHC, compVer >= mkVersion [7, 10] = mkVersion [1, 22] +-- | otherwise = mkVersion [1, 20] +-- where +-- isGHC = compFlav `elem` [GHC, GHCJS] +-- compFlav = compilerFlavor compiler +-- compVer = compilerVersion compiler + +-- As we can't predict the future, we also place a global upper +-- bound on the lib:Cabal version we know how to interact with: +-- +-- The upper bound is computed by incrementing the current major +-- version twice in order to allow for the current version, as +-- well as the next adjacent major version (one of which will not +-- be released, as only "even major" versions of Cabal are +-- released to Hackage or bundled with proper GHC releases). +-- +-- For instance, if the current version of cabal-install is an odd +-- development version, e.g. Cabal-2.1.0.0, then we impose an +-- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a +-- stable/release even version, e.g. Cabal-2.2.1.0, the upper +-- bound is `setup.Cabal < 2.4`. This gives us enough flexibility +-- when dealing with development snapshots of Cabal and cabal-install. +-- +-- setupMaxCabalVersionConstraint :: Version +-- setupMaxCabalVersionConstraint = +-- alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs new file mode 100644 index 00000000000..afacc83f06c --- /dev/null +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeFamilies #-} + +module Distribution.Client.ProjectPlanning.Stage + ( WithStage (..) + , Stage (..) + , HasStage (..) + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.Types.ConfiguredId (HasConfiguredId (..)) +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Package (HasUnitId (..), Package (..)) +import Distribution.Solver.Types.Stage (Stage (..)) +import Text.PrettyPrint (colon) + +-- FIXME: blaaah +data WithStage a = WithStage Stage a + deriving (Eq, Ord, Show, Generic, Functor, Foldable, Traversable) + +instance Binary a => Binary (WithStage a) +instance Structured a => Structured (WithStage a) + +instance Package pkg => Package (WithStage pkg) where + packageId (WithStage _stage pkg) = packageId pkg + +instance IsNode a => IsNode (WithStage a) where + type Key (WithStage a) = WithStage (Key a) + nodeKey = fmap nodeKey + nodeNeighbors = traverse nodeNeighbors + +instance HasUnitId a => HasUnitId (WithStage a) where + installedUnitId (WithStage _stage pkg) = installedUnitId pkg + +instance HasConfiguredId a => HasConfiguredId (WithStage a) where + configuredId (WithStage _stage pkg) = configuredId pkg + +instance Pretty a => Pretty (WithStage a) where + pretty (WithStage s pkg) = pretty s <> colon <> pretty pkg + +class HasStage a where + stageOf :: a -> Stage + +instance HasStage (WithStage a) where + stageOf (WithStage s _) = s diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 10171b76adb..2678b054c42 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -59,6 +59,13 @@ module Distribution.Client.ProjectPlanning.Types , componentOptionalStanza , componentTargetName + -- * Toolchain + , Toolchain (..) + , Toolchains + , Stage (..) + , Staged (..) + , WithStage (..) + -- * Setup script , SetupScriptStyle (..) ) where @@ -77,9 +84,11 @@ import Distribution.Client.InstallPlan , GenericPlanPackage (..) ) import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.ProjectPlanning.Stage import Distribution.Client.SolverInstallPlan ( SolverInstallPlan ) +import Distribution.Client.Toolchain import Distribution.Client.Types import Distribution.Backpack @@ -110,7 +119,6 @@ import Distribution.Simple.Utils (ordNub) import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.OptionalStanza -import Distribution.System import Distribution.Types.ComponentRequestedSpec import qualified Distribution.Types.LocalBuildConfig as LBC import Distribution.Types.PackageDescription (PackageDescription (..)) @@ -185,9 +193,7 @@ showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode -- even platform and compiler could be different if we're building things -- like a server + client with ghc + ghcjs data ElaboratedSharedConfig = ElaboratedSharedConfig - { pkgConfigPlatform :: Platform - , pkgConfigCompiler :: Compiler -- TODO: [code cleanup] replace with CompilerInfo - , pkgConfigCompilerProgs :: ProgramDb + { pkgConfigToolchains :: Toolchains -- ^ The programs that the compiler configured (e.g. for GHC, the progs -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are -- used. @@ -248,6 +254,7 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage -- to disable. This tells us which ones we build by default, and -- helps with error messages when the user asks to build something -- they explicitly disabled. + , elabStage :: Stage , -- TODO: The 'Bool' here should be refined into an ADT with three -- cases: NotRequested, ExplicitlyRequested and -- ImplicitlyRequested. A stanza is explicitly requested if @@ -344,10 +351,11 @@ normaliseConfiguredPackage :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage -normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg = +normaliseConfiguredPackage shared pkg = pkg{elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg)} where - knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs + Toolchain{toolchainProgramDb} = getStage (pkgConfigToolchains shared) (elabStage pkg) + knownProgramDb = addKnownPrograms builtinPrograms toolchainProgramDb pkgDesc :: PackageDescription pkgDesc = elabPkgDescription pkg @@ -539,10 +547,12 @@ elabDistDirParams shared elab = , distParamComponentName = case elabPkgOrComp elab of ElabComponent comp -> compComponentName comp ElabPackage _ -> Nothing - , distParamCompilerId = compilerId (pkgConfigCompiler shared) - , distParamPlatform = pkgConfigPlatform shared + , distParamCompilerId = compilerId toolchainCompiler + , distParamPlatform = toolchainPlatform , distParamOptimization = LBC.withOptimization $ elabBuildOptions elab } + where + Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains shared) (elabStage elab) -- | The full set of dependencies which dictate what order we -- need to build things in the install plan: "order dependencies" diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index b92c4c47836..fa530f64ee3 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -71,7 +71,7 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage (..) , ElaboratedSharedConfig (..) - , configureCompiler + , configureToolchains ) import Distribution.Client.RebuildMonad ( runRebuild @@ -194,6 +194,7 @@ import qualified Data.ByteString.Char8 as BS import Data.ByteString.Lazy () import qualified Data.Set as S import Distribution.Client.Errors +import Distribution.Solver.Types.Stage (Stage (..), getStage) import Distribution.Utils.Path ( unsafeMakeSymbolicPath ) @@ -362,9 +363,9 @@ withContextAndSelectors verbosity noTargets kind flags@NixStyleFlags{..} targetS exists <- doesFileExist script if exists then do - ctx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script) + baseCtx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script) - let projectRoot = distProjectRootDirectory $ distDirLayout ctx + let projectRoot = distProjectRootDirectory $ distDirLayout baseCtx writeFile (projectRoot "scriptlocation") =<< canonicalizePath script scriptContents <- BS.readFile script @@ -376,15 +377,18 @@ withContextAndSelectors verbosity noTargets kind flags@NixStyleFlags{..} targetS (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) - projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents + projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout baseCtx) (takeFileName script) scriptContents - createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx) - Toolchain{toolchainCompiler, toolchainPlatform = toolchainPlatform@(Platform arch os)} <- - runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx) + createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout baseCtx) + + toolchains <- + runRebuild projectRoot $ configureToolchains verbosity (distDirLayout baseCtx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig baseCtx) + + let Toolchain{toolchainCompiler, toolchainPlatform = toolchainPlatform@(Platform arch os)} = getStage toolchains Host (projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, toolchainCompiler)) mempty projectCfgSkeleton - let ctx' = ctx & lProjectConfig %~ (<> projectCfg) + let ctx' = baseCtx & lProjectConfig %~ (<> projectCfg) build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' toolchainCompiler toolchainPlatform exePath = build_dir "bin" scriptExeFileName script @@ -472,14 +476,13 @@ updateContextAndWriteProjectFile ctx scriptPath scriptExecutable = do let projectRoot = distProjectRootDirectory $ distDirLayout ctx absScript <- unsafeMakeSymbolicPath . makeRelative (normalise projectRoot) <$> canonicalizePath scriptPath - let - sourcePackage = - fakeProjectSourcePackage projectRoot - & lSrcpkgDescription . L.condExecutables - .~ [(scriptComponentName scriptPath, CondNode executable [])] - executable = - scriptExecutable - & L.modulePath .~ absScript + let sourcePackage = + fakeProjectSourcePackage projectRoot + & lSrcpkgDescription . L.condExecutables + .~ [(scriptComponentName scriptPath, CondNode executable (targetBuildDepends $ buildInfo executable) [])] + executable = + scriptExecutable + & L.modulePath .~ absScript updateContextAndWriteProjectFile' ctx sourcePackage @@ -590,10 +593,12 @@ fakeProjectSourcePackage projectRoot = sourcePackage movedExePath :: UnqualComponentName -> DistDirLayout -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> Maybe FilePath movedExePath selectedComponent distDirLayout elabShared elabConfigured = do exe <- find ((== selectedComponent) . exeName) . executables $ elabPkgDescription elabConfigured - let CompilerId flavor _ = (compilerId . pkgConfigCompiler) elabShared + let CompilerId flavor _ = compilerId toolchainCompiler opts <- lookup flavor (perCompilerFlavorToList . options $ buildInfo exe) let projectRoot = distProjectRootDirectory distDirLayout fmap (projectRoot ) . lookup "-o" $ reverse (zip opts (drop 1 opts)) + where + Toolchain{..} = getStage (pkgConfigToolchains elabShared) (elabStage elabConfigured) -- Lenses diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 52f0a7774db..83ac01efd55 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -1051,263 +1051,351 @@ cachedSetupDirAndProg platform bt options' cabalLibVersion = do ++ "-" ++ compilerVersionString ) - <.> exeExtension buildPlatform - return (setupCacheDir, cachedSetupProgFile) - where - buildTypeString = show bt - cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion - compilerVersionString = - prettyShow $ - maybe buildCompilerId compilerId $ - useCompiler options' - platformString = prettyShow platform - --- | Look up the executable in the cache; update the cache if the executable --- is not found. -getCachedSetupExecutable - :: Verbosity - -> Platform - -> PackageIdentifier - -> BuildType - -> SetupScriptOptions - -> Version - -> Maybe InstalledPackageId - -> IO FilePath -getCachedSetupExecutable - verbosity - platform - pkgId - bt - options' - cabalLibVersion - maybeCabalLibInstalledPkgId = do - (setupCacheDir, cachedSetupProgFile) <- - cachedSetupDirAndProg platform bt options' cabalLibVersion - cachedSetupExists <- doesFileExist cachedSetupProgFile - if cachedSetupExists - then - debug verbosity $ - "Found cached setup executable: " ++ cachedSetupProgFile - else criticalSection' $ do - -- The cache may have been populated while we were waiting. - cachedSetupExists' <- doesFileExist cachedSetupProgFile - if cachedSetupExists' + installedVersion = do + (comp, progdb, options') <- configureToolchains options + (version, mipkgid, options'') <- + installedCabalVersion + options' + comp + progdb + updateSetupScript version bt + writeSetupVersionFile version + return (version, mipkgid, options'') + + savedVersion :: IO (Maybe Version) + savedVersion = do + versionString <- readFile (i setupVersionFile) `catchIO` \_ -> return "" + case reads versionString of + [(version, s)] | all isSpace s -> return (Just version) + _ -> return Nothing + + -- \| Update a Setup.hs script, creating it if necessary. + updateSetupScript :: Version -> BuildType -> IO () + updateSetupScript _ Custom = do + useHs <- doesFileExist customSetupHs + useLhs <- doesFileExist customSetupLhs + unless (useHs || useLhs) $ + dieWithException verbosity UpdateSetupScript + let src = (if useHs then customSetupHs else customSetupLhs) + srcNewer <- src `moreRecentFile` i setupHs + when srcNewer $ + if useHs + then copyFileVerbose verbosity src (i setupHs) + else runSimplePreProcessor ppUnlit src (i setupHs) verbosity + where + customSetupHs = workingDir options "Setup.hs" + customSetupLhs = workingDir options "Setup.lhs" + updateSetupScript cabalLibVersion Hooks = do + + let customSetupHooks = workingDir options "SetupHooks.hs" + useHs <- doesFileExist customSetupHooks + unless (useHs) $ + die' + verbosity + "Using 'build-type: Hooks' but there is no SetupHooks.hs file." + copyFileVerbose verbosity customSetupHooks (i setupHooks) + rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) +-- rewriteFileLBS verbosity hooksHs hooksScript + updateSetupScript cabalLibVersion _ = + rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) + + buildTypeScript :: Version -> BS.ByteString + buildTypeScript cabalLibVersion = "{-# LANGUAGE NoImplicitPrelude #-}\n" <> case bt of + Simple -> "import Distribution.Simple; main = defaultMain\n" + Configure + | cabalLibVersion >= mkVersion [3, 13, 0] + -> "import Distribution.Simple; main = defaultMainWithSetupHooks autoconfSetupHooks\n" + | cabalLibVersion >= mkVersion [1, 3, 10] + -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n" + | otherwise + -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n" + Make -> "import Distribution.Make; main = defaultMain\n" + Hooks + | cabalLibVersion >= mkVersion [3, 13, 0] + -> "import Distribution.Simple; import SetupHooks; main = defaultMainWithSetupHooks setupHooks\n" + | otherwise + -> error "buildTypeScript Hooks with Cabal < 3.13" + Custom -> error "buildTypeScript Custom" + + installedCabalVersion + :: SetupScriptOptions + -> Compiler + -> ProgramDb + -> IO + ( Version + , Maybe InstalledPackageId + , SetupScriptOptions + ) + installedCabalVersion options' _ _ + | packageName pkg == mkPackageName "Cabal" + && bt == Custom = + return (packageVersion pkg, Nothing, options') + installedCabalVersion options' compiler progdb = do + index <- maybeGetInstalledPackages options' compiler progdb + let cabalDepName = mkPackageName "Cabal" + cabalDepVersion = useCabalVersion options' + options'' = options'{usePackageIndex = Just index} + case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of + [] -> + dieWithException verbosity $ InstalledCabalVersion (packageName pkg) (useCabalVersion options) + pkgs -> + let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs + err = error "Distribution.Client.installedCabalVersion: empty version list" + in return + ( packageVersion ipkginfo + , Just . IPI.installedComponentId $ ipkginfo + , options'' + ) + + bestVersion :: (a -> Version) -> [a] -> a + bestVersion f = firstMaximumBy (comparing (preference . f)) + where + -- Like maximumBy, but picks the first maximum element instead of the + -- last. In general, we expect the preferred version to go first in the + -- list. For the default case, this has the effect of choosing the version + -- installed in the user package DB instead of the global one. See #1463. + -- + -- Note: firstMaximumBy could be written as just + -- `maximumBy cmp . reverse`, but the problem is that the behaviour of + -- maximumBy is not fully specified in the case when there is not a single + -- greatest element. + firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a + firstMaximumBy _ [] = + error "Distribution.Client.firstMaximumBy: empty list" + firstMaximumBy cmp xs = foldl1' maxBy xs + where + maxBy x y = case cmp x y of GT -> x; EQ -> x; LT -> y + + preference version = + ( sameVersion + , sameMajorVersion + , stableVersion + , latestVersion + ) + where + sameVersion = version == cabalVersion + sameMajorVersion = majorVersion version == majorVersion cabalVersion + majorVersion = take 2 . versionNumbers + stableVersion = case versionNumbers version of + (_ : x : _) -> even x + _ -> False + latestVersion = version + + configureToolchains + :: SetupScriptOptions + -> IO (Compiler, ProgramDb, SetupScriptOptions) + configureToolchains options' = do + (comp, progdb) <- case useCompiler options' of + Just comp -> return (comp, useProgramDb options') + Nothing -> do + (comp, _, progdb) <- + configCompilerEx + (Just GHC) + Nothing + Nothing + (useProgramDb options') + verbosity + return (comp, progdb) + -- Whenever we need to call configureCompiler, we also need to access the + -- package index, so let's cache it in SetupScriptOptions. + index <- maybeGetInstalledPackages options' comp progdb + return + ( comp + , progdb + , options' + { useCompiler = Just comp + , usePackageIndex = Just index + , useProgramDb = progdb + } + ) + + -- \| Path to the setup exe cache directory and path to the cached setup + -- executable. + cachedSetupDirAndProg + :: SetupScriptOptions + -> Version + -> IO (FilePath, FilePath) + cachedSetupDirAndProg options' cabalLibVersion = do + cacheDir <- defaultCacheDir + let setupCacheDir = cacheDir "setup-exe-cache" + cachedSetupProgFile = + setupCacheDir + ( "setup-" + ++ buildTypeString + ++ "-" + ++ cabalVersionString + ++ "-" + ++ platformString + ++ "-" + ++ compilerVersionString + ) + <.> exeExtension buildPlatform + return (setupCacheDir, cachedSetupProgFile) + where + buildTypeString = show bt + cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion + compilerVersionString = + prettyShow $ + maybe buildCompilerId compilerId $ + useCompiler options' + platformString = prettyShow platform + + -- \| Look up the setup executable in the cache; update the cache if the setup + -- executable is not found. + getCachedSetupExecutable + :: SetupScriptOptions + -> Version + -> Maybe InstalledPackageId + -> IO FilePath + getCachedSetupExecutable + options' + cabalLibVersion + maybeCabalLibInstalledPkgId = do + (setupCacheDir, cachedSetupProgFile) <- + cachedSetupDirAndProg options' cabalLibVersion + cachedSetupExists <- doesFileExist cachedSetupProgFile + if cachedSetupExists then debug verbosity $ "Found cached setup executable: " ++ cachedSetupProgFile - else do - debug verbosity "Setup executable not found in the cache." - src <- - compileExe - verbosity - platform - pkgId - bt - WantSetup - options' - cabalLibVersion - maybeCabalLibInstalledPkgId - True - createDirectoryIfMissingVerbose verbosity True setupCacheDir - installExecutableFile verbosity src cachedSetupProgFile - -- Do not strip if we're using GHCJS, since the result may be a script - when (maybe True ((/= GHCJS) . compilerFlavor) $ useCompiler options') $ do - -- Add the relevant PATH overrides for the package to the - -- program database. - setupProgDb - <- prependProgramSearchPath verbosity - (useExtraPathEnv options') - (useExtraEnvOverrides options') - (useProgramDb options') - >>= configureAllKnownPrograms verbosity - Strip.stripExe - verbosity - platform - setupProgDb - cachedSetupProgFile - return cachedSetupProgFile - where - criticalSection' = maybe id criticalSection $ setupCacheLock options' - --- | If the Setup.hs is out of date wrt the executable then recompile it. --- Currently this is GHC/GHCJS only. It should really be generalised. -compileExe - :: Verbosity - -> Platform - -> PackageIdentifier - -> BuildType - -> WantedExternalExe exe - -> SetupScriptOptions - -> Version - -> Maybe ComponentId - -> Bool - -> IO FilePath -compileExe verbosity platform pkgId bt wantedExe opts ver mbCompId forceCompile = - case wantedExe of - WantHooks -> - compileHooksScript verbosity platform pkgId opts ver mbCompId forceCompile - WantSetup -> - compileSetupScript verbosity platform pkgId bt opts ver mbCompId forceCompile - -compileSetupScript - :: Verbosity - -> Platform - -> PackageIdentifier - -> BuildType - -> SetupScriptOptions - -> Version - -> Maybe ComponentId - -> Bool - -> IO FilePath -compileSetupScript verbosity platform pkgId bt opts ver mbCompId forceCompile = - compileSetupX "Setup" - [setupHs opts] (setupProgFile opts) - verbosity platform pkgId bt opts ver mbCompId forceCompile - -compileHooksScript - :: Verbosity - -> Platform - -> PackageIdentifier - -> SetupScriptOptions - -> Version - -> Maybe ComponentId - -> Bool - -> IO FilePath -compileHooksScript verbosity platform pkgId opts ver mbCompId forceCompile = - compileSetupX "SetupHooks" - [setupHooks opts, hooksHs opts] (hooksProgFile opts) - verbosity platform pkgId Hooks opts ver mbCompId forceCompile - -setupDir :: SetupScriptOptions -> SymbolicPath Pkg (Dir setup) -setupDir opts = useDistPref opts Cabal.Path. makeRelativePathEx "setup" -setupVersionFile :: SetupScriptOptions -> SymbolicPath Pkg File -setupVersionFile opts = setupDir opts Cabal.Path. makeRelativePathEx ( "setup" <.> "version" ) -setupHs, hooksHs, setupHooks, setupProgFile, hooksProgFile :: SetupScriptOptions -> SymbolicPath Pkg File -setupHs opts = setupDir opts Cabal.Path. makeRelativePathEx ( "setup" <.> "hs" ) -hooksHs opts = setupDir opts Cabal.Path. makeRelativePathEx ( "hooks" <.> "hs" ) -setupHooks opts = setupDir opts Cabal.Path. makeRelativePathEx ( "SetupHooks" <.> "hs" ) -setupProgFile opts = setupDir opts Cabal.Path. makeRelativePathEx ( "setup" <.> exeExtension buildPlatform ) -hooksProgFile opts = setupDir opts Cabal.Path. makeRelativePathEx ( "hooks" <.> exeExtension buildPlatform ) - -compileSetupX - :: String - -> [SymbolicPath Pkg File] -- input files - -> SymbolicPath Pkg File -- output file - -> Verbosity - -> Platform - -> PackageIdentifier - -> BuildType - -> SetupScriptOptions - -> Version - -> Maybe ComponentId - -> Bool - -> IO FilePath -compileSetupX - what - inPaths outPath - verbosity - platform - pkgId - bt - options' - cabalLibVersion - maybeCabalLibInstalledPkgId - forceCompile = do - setupXHsNewer <- - or <$> for inPaths (\ inPath -> i inPath `moreRecentFile` i outPath) - cabalVersionNewer <- i (setupVersionFile options') `moreRecentFile` i outPath - let outOfDate = setupXHsNewer || cabalVersionNewer - when (outOfDate || forceCompile) $ do - debug verbosity $ what ++ " executable needs to be updated, compiling..." - (compiler, progdb, options'') <- configureCompiler verbosity options' - pkgDbs <- traverse (traverse (makeRelativeToDirS mbWorkDir)) (coercePackageDBStack (usePackageDB options'')) - let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion - (program, extraOpts) = - case compilerFlavor compiler of - GHCJS -> (ghcjsProgram, ["-build-runner"]) - _ -> (ghcProgram, ["-threaded"]) - cabalDep = - maybe - [] - (\ipkgid -> [(ipkgid, cabalPkgid)]) - maybeCabalLibInstalledPkgId - - -- With 'useDependenciesExclusive' and Custom build type, - -- we enforce the deps specified, so only the given ones can be used. - -- Otherwise we add on a dep on the Cabal library - -- (unless 'useDependencies' already contains one). - selectedDeps - | (useDependenciesExclusive options' && (bt /= Hooks)) - -- NB: to compile build-type: Hooks packages, we need Cabal - -- in order to compile @main = defaultMainWithSetupHooks setupHooks@. - || any (isCabalPkgId . snd) (useDependencies options') - = useDependencies options' - | otherwise = - useDependencies options' ++ cabalDep - addRenaming (ipid, _) = - -- Assert 'DefUnitId' invariant - ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) - , defaultRenaming - ) - cppMacrosFile = setupDir options' Cabal.Path. makeRelativePathEx "setup_macros.h" - ghcOptions = - mempty - { -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use - -- --ghc-option=-v instead! - ghcOptVerbosity = Flag $ min (verbosityLevel verbosity) Normal - , ghcOptMode = Flag GhcModeMake - , ghcOptInputFiles = toNubListR inPaths - , ghcOptOutputFile = Flag outPath - , ghcOptObjDir = Flag (setupDir options') - , ghcOptHiDir = Flag (setupDir options') - , ghcOptSourcePathClear = Flag True - , ghcOptSourcePath = case bt of - Custom -> toNubListR [sameDirectory] - Hooks -> toNubListR [sameDirectory] - _ -> mempty - , ghcOptPackageDBs = pkgDbs - , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') - , ghcOptCabal = Flag (useDependenciesExclusive options') - , ghcOptPackages = toNubListR $ map addRenaming selectedDeps - -- With 'useVersionMacros', use a version CPP macros .h file. - , ghcOptCppIncludes = - toNubListR - [ cppMacrosFile - | useVersionMacros options' - ] - , ghcOptExtra = extraOpts - , ghcOptExtensions = toNubListR $ - [ Simple.DisableExtension Simple.ImplicitPrelude - | not $ bt == Custom || any (isBasePkgId . snd) selectedDeps - ] - -- Pass -WNoImplicitPrelude to avoid depending on base - -- when compiling a simple Setup.hs file. - , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler - } - let ghcCmdLine = renderGhcOptions compiler platform ghcOptions - when (useVersionMacros options') $ - rewriteFileEx verbosity (i cppMacrosFile) $ - generatePackageVersionMacros (pkgVersion pkgId) (map snd selectedDeps) - case useLoggingHandle options' of - Nothing -> runDbProgramCwd verbosity mbWorkDir program progdb ghcCmdLine - -- If build logging is enabled, redirect compiler output to - -- the log file. - Just logHandle -> do - output <- - getDbProgramOutputCwd - verbosity - mbWorkDir - program - progdb - ghcCmdLine - hPutStr logHandle output - return $ i outPath - where - mbWorkDir = useWorkingDir options' - -- See Note [Symbolic paths] in Distribution.Utils.Path - i :: SymbolicPathX allowAbs Pkg to -> FilePath - i = interpretSymbolicPath mbWorkDir + else criticalSection' $ do + -- The cache may have been populated while we were waiting. + cachedSetupExists' <- doesFileExist cachedSetupProgFile + if cachedSetupExists' + then + debug verbosity $ + "Found cached setup executable: " ++ cachedSetupProgFile + else do + debug verbosity $ "Setup executable not found in the cache." + src <- + compileSetupExecutable + options' + cabalLibVersion + maybeCabalLibInstalledPkgId + True + createDirectoryIfMissingVerbose verbosity True setupCacheDir + installExecutableFile verbosity src cachedSetupProgFile + -- Do not strip if we're using GHCJS, since the result may be a script + when (maybe True ((/= GHCJS) . compilerFlavor) $ useCompiler options') $ do + -- Add the relevant PATH overrides for the package to the + -- program database. + setupProgDb + <- prependProgramSearchPath verbosity + (useExtraPathEnv options) + (useExtraEnvOverrides options) + (useProgramDb options') + >>= configureAllKnownPrograms verbosity + Strip.stripExe + verbosity + platform + setupProgDb + cachedSetupProgFile + return cachedSetupProgFile + where + criticalSection' = maybe id criticalSection $ setupCacheLock options' + + -- \| If the Setup.hs is out of date wrt the executable then recompile it. + -- Currently this is GHC/GHCJS only. It should really be generalised. + compileSetupExecutable + :: SetupScriptOptions + -> Version + -> Maybe ComponentId + -> Bool + -> IO FilePath + compileSetupExecutable + options' + cabalLibVersion + maybeCabalLibInstalledPkgId + forceCompile = do + setupHsNewer <- i setupHs `moreRecentFile` i setupProgFile + cabalVersionNewer <- i setupVersionFile `moreRecentFile` i setupProgFile + let outOfDate = setupHsNewer || cabalVersionNewer + when (outOfDate || forceCompile) $ do + debug verbosity "Setup executable needs to be updated, compiling..." + (compiler, progdb, options'') <- configureToolchains options' + pkgDbs <- traverse (traverse (makeRelativeToDirS mbWorkDir)) (coercePackageDBStack (usePackageDB options'')) + let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion + (program, extraOpts) = + case compilerFlavor compiler of + GHCJS -> (ghcjsProgram, ["-build-runner"]) + _ -> (ghcProgram, ["-threaded"]) + cabalDep = + maybe + [] + (\ipkgid -> [(ipkgid, cabalPkgid)]) + maybeCabalLibInstalledPkgId + + -- With 'useDependenciesExclusive' and Custom build type, + -- we enforce the deps specified, so only the given ones can be used. + -- Otherwise we add on a dep on the Cabal library + -- (unless 'useDependencies' already contains one). + selectedDeps + | (useDependenciesExclusive options' && (bt /= Hooks)) + -- NB: to compile build-type: Hooks packages, we need Cabal + -- in order to compile @main = defaultMainWithSetupHooks setupHooks@. + || any (isCabalPkgId . snd) (useDependencies options') + = useDependencies options' + | otherwise = + useDependencies options' ++ cabalDep + addRenaming (ipid, _) = + -- Assert 'DefUnitId' invariant + ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) + , defaultRenaming + ) + cppMacrosFile = setupDir Cabal.Path. makeRelativePathEx "setup_macros.h" + ghcOptions = + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use + -- --ghc-option=-v instead! + ghcOptVerbosity = Flag (min verbosity normal) + , ghcOptMode = Flag GhcModeMake + , ghcOptInputFiles = toNubListR [setupHs] + , ghcOptOutputFile = Flag $ setupProgFile + , ghcOptObjDir = Flag $ setupDir + , ghcOptHiDir = Flag $ setupDir + , ghcOptSourcePathClear = Flag True + , ghcOptSourcePath = case bt of + Custom -> toNubListR [sameDirectory] + Hooks -> toNubListR [sameDirectory] + _ -> mempty + , ghcOptPackageDBs = pkgDbs + , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') + , ghcOptCabal = Flag (useDependenciesExclusive options') + , ghcOptPackages = toNubListR $ map addRenaming selectedDeps + -- With 'useVersionMacros', use a version CPP macros .h file. + , ghcOptCppIncludes = + toNubListR + [ cppMacrosFile + | useVersionMacros options' + ] + , ghcOptExtra = extraOpts + , ghcOptExtensions = toNubListR $ + if bt == Custom || any (isBasePkgId . snd) selectedDeps + then [] + else [ Simple.DisableExtension Simple.ImplicitPrelude ] + -- Pass -WNoImplicitPrelude to avoid depending on base + -- when compiling a Simple Setup.hs file. + , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler + } + let ghcCmdLine = renderGhcOptions compiler platform ghcOptions + when (useVersionMacros options') $ + rewriteFileEx verbosity (i cppMacrosFile) $ + generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps) + case useLoggingHandle options of + Nothing -> runDbProgramCwd verbosity mbWorkDir program progdb ghcCmdLine + -- If build logging is enabled, redirect compiler output to + -- the log file. + Just logHandle -> do + output <- + getDbProgramOutputCwd + verbosity + mbWorkDir + program + progdb + ghcCmdLine + hPutStr logHandle output + return $ i setupProgFile isCabalPkgId, isBasePkgId :: PackageIdentifier -> Bool isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal" diff --git a/cabal-install/src/Distribution/Client/Toolchain.hs b/cabal-install/src/Distribution/Client/Toolchain.hs index f3c44e76fc8..e6023fdd91a 100644 --- a/cabal-install/src/Distribution/Client/Toolchain.hs +++ b/cabal-install/src/Distribution/Client/Toolchain.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} module Distribution.Client.Toolchain ( Stage (..) @@ -8,11 +7,14 @@ module Distribution.Client.Toolchain , Toolchain (..) , mkProgramDb , configToolchain + , configToolchains , module Distribution.Solver.Types.Stage , module Distribution.Solver.Types.Toolchain ) where +import Distribution.Client.Setup (ConfigExFlags (..)) +import Distribution.Simple (Compiler, CompilerFlavor) import Distribution.Simple.Compiler (interpretPackageDBStack) import Distribution.Simple.Configure import Distribution.Simple.Program (ProgArg) @@ -20,6 +22,7 @@ import Distribution.Simple.Program.Db import Distribution.Simple.Setup import Distribution.Solver.Types.Stage import Distribution.Solver.Types.Toolchain +import Distribution.System (Platform) import Distribution.Utils.NubList import Distribution.Verbosity (Verbosity) @@ -63,3 +66,57 @@ configToolchain configFlags@ConfigFlags{..} = do where -- FIXME verbosity = fromFlag (configVerbosity configFlags) + +configToolchains :: Verbosity -> ConfigFlags -> ConfigExFlags -> IO (Staged Toolchain) +configToolchains verbosity ConfigFlags{..} ConfigExFlags{..} = do + programDb <- + mkProgramDb + verbosity + (fromNubList configProgramPathExtra) + configProgramPaths + configProgramArgs + + hostToolchain <- do + (toolchainCompiler, toolchainPlatform, toolchainProgramDb) <- + configCompilerExSafe + verbosity + (flagToMaybe configHcFlavor) + (flagToMaybe configHcPath) + (flagToMaybe configHcPkg) + programDb + let toolchainPackageDBs = interpretPackageDBStack Nothing $ interpretPackageDbFlags False $ configPackageDBs + return Toolchain{..} + + buildToolchain <- do + (toolchainCompiler, toolchainPlatform, toolchainProgramDb) <- + configCompilerExSafe + verbosity + (flagToMaybe configBuildHcFlavor) + (flagToMaybe configBuildHcPath) + (flagToMaybe configBuildHcPkg) + programDb + let toolchainPackageDBs = interpretPackageDBStack Nothing $ interpretPackageDbFlags False $ configPackageDBs + return Toolchain{..} + + return $ Staged (\case Build -> buildToolchain; Host -> hostToolchain) + +configCompilerExSafe + :: Verbosity + -> Maybe CompilerFlavor + -> Maybe FilePath + -> Maybe FilePath + -> ProgramDb + -> IO (Compiler, Platform, ProgramDb) +configCompilerExSafe verbosity hcFlavor hcPath hcPkg progdb = do + (compiler, platform, progdb') <- + configCompilerEx + hcFlavor + hcPath + hcPkg + progdb + verbosity + + -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the future. + -- I think this should be fixed in configCompilerExAux or even configCompilerEx + progdb'' <- configureAllKnownPrograms verbosity progdb' + return (compiler, platform, progdb'') diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index b6d656adb16..194fb75dde0 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -1914,11 +1914,16 @@ testSetupScriptStyles config reportSubCase = do plan0@(_, _, sharedConfig) <- planProject testdir1 config - let compilerVer = compilerVersion (pkgConfigCompiler sharedConfig) + let isOSX (Platform _ OSX) = True + isOSX _ = False + compilerVer = compilerVersion (toolchainCompiler $ getStage (pkgConfigToolchains sharedConfig) Build) -- Skip the Custom tests when the shipped Cabal library is buggy - -- 9.10 ships Cabal 3.12.0.0 affected by #9940 - unless (mkVersion [9, 10] <= compilerVer && compilerVer < mkVersion [9, 11]) $ - do + unless + ( (isOSX (toolchainPlatform $ getStage (pkgConfigToolchains sharedConfig) Build) && (compilerVer < mkVersion [7, 10])) + -- 9.10 ships Cabal 3.12.0.0 affected by #9940 + || (mkVersion [9, 10] <= compilerVer && compilerVer < mkVersion [9, 11]) + ) + $ do (plan1, res1) <- executePlan plan0 pkg1 <- expectPackageInstalled plan1 res1 pkgidA elabSetupScriptStyle pkg1 @?= SetupCustomExplicitDeps @@ -1928,7 +1933,7 @@ testSetupScriptStyles config reportSubCase = do removeFileForcibly (basedir testdir1 "marker") -- implicit deps implies 'Cabal < 2' which conflicts w/ GHC 8.2 or later - when (compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [8, 2]) $ do + when (compilerVersion (toolchainCompiler $ getStage (pkgConfigToolchains sharedConfig) Build) < mkVersion [8, 2]) $ do reportSubCase (show SetupCustomImplicitDeps) (plan2, res2) <- executePlan =<< planProject testdir2 config pkg2 <- expectPackageInstalled plan2 res2 pkgidA @@ -2774,10 +2779,7 @@ testHaddockProjectDependencies config = do (_, _, sharedConfig) <- planProject testdir config -- `haddock-project` is only supported by `haddock-2.26.1` and above which is -- shipped with `ghc-9.4` - -- And doesn't work with older ghc on Windows for some reason (file in the - -- wrong place, perhaps?). - let safeMinor = if buildOS == Windows then 10 else 4 - when (compilerVersion (pkgConfigCompiler sharedConfig) > mkVersion [9, safeMinor]) $ do + when (compilerVersion (toolchainCompiler $ getStage (pkgConfigToolchains sharedConfig) Build) > mkVersion [9, 4]) $ do let dir = basedir testdir cleanHaddockProject testdir withCurrentDirectory dir $ do From d1d232845500cbc0b10db52fc8c354b91db4b11b Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 2 Apr 2025 14:43:52 +0800 Subject: [PATCH 12/54] feat(cabal-install): add stage to ConstraintScope and UserConstraint --- .../Solver/Modular/IndexConversion.hs | 8 +- .../Solver/Types/PackageConstraint.hs | 47 +++++++---- .../src/Distribution/Client/CmdFreeze.hs | 2 +- .../src/Distribution/Client/CmdRepl.hs | 2 +- .../src/Distribution/Client/Dependency.hs | 8 +- .../src/Distribution/Client/Targets.hs | 82 ++++++++++++++----- .../Client/Types/PackageSpecifier.hs | 2 +- cabal-install/tests/IntegrationTests2.hs | 2 +- .../Distribution/Client/ArbitraryInstances.hs | 4 + .../UnitTests/Distribution/Client/Targets.hs | 2 +- .../Distribution/Client/TreeDiffInstances.hs | 1 + .../Distribution/Solver/Modular/QuickCheck.hs | 4 +- .../Distribution/Solver/Modular/Solver.hs | 36 ++++---- 13 files changed, 133 insertions(+), 67 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs index 83d3d51ce12..4844909123c 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs @@ -278,17 +278,19 @@ testConditionForComponent :: Stage -> (a -> Bool) -> CondTree ConfVar a -> Maybe Bool -testConditionForComponent _stage os arch cinfo constraints p tree = +testConditionForComponent stage os arch cinfo constraints p tree = case go $ extractCondition p tree of Lit True -> Just True Lit False -> Just False _ -> Nothing where + -- TODO: fix for stage flagAssignment :: [(FlagName, Bool)] flagAssignment = mconcat [ unFlagAssignment fa - | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa) - <- L.map unlabelPackageConstraint constraints] + | PackageConstraint (ConstraintScope stage' (ScopeAnyQualifier _)) (PackagePropertyFlags fa) + <- L.map unlabelPackageConstraint constraints + , maybe True (== stage) stage'] -- Simplify the condition, using the current environment. Most of this -- function was copied from convBranch and diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index dc5b685ff61..9a6c2a665b0 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -7,6 +7,7 @@ -- module Distribution.Solver.Types.PackageConstraint ( ConstraintScope(..), + ConstraintQualifier(..), scopeToplevel, scopeToPackageName, constraintScopeMatches, @@ -29,11 +30,21 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath import qualified Text.PrettyPrint as Disp +import Distribution.Solver.Types.Toolchain (Stage (..)) -- | Determines to what packages and in what contexts a -- constraint applies. -data ConstraintScope +data ConstraintScope = + ConstraintScope + -- | The stage at which the constraint applies, if any. + -- If Nothing, the constraint applies to all stages. + (Maybe Stage) + -- | The qualifier that determines the scope of the constraint. + ConstraintQualifier + deriving (Eq, Show) + +data ConstraintQualifier -- | A scope that applies when the given package is used as a build target. -- In other words, the scope applies iff a goal has a top-level qualifier -- and its namespace matches the given package name. A namespace is @@ -56,29 +67,37 @@ data ConstraintScope -- | Constructor for a common use case: the constraint applies to -- the package with the specified name when that package is a --- top-level dependency in the default namespace. +-- top-level dependency in the host stage. scopeToplevel :: PackageName -> ConstraintScope -scopeToplevel = ScopeQualified QualToplevel +scopeToplevel = ConstraintScope (Just Host) . ScopeQualified QualToplevel -- | Returns the package name associated with a constraint scope. scopeToPackageName :: ConstraintScope -> PackageName -scopeToPackageName (ScopeTarget pn) = pn -scopeToPackageName (ScopeQualified _ pn) = pn -scopeToPackageName (ScopeAnySetupQualifier pn) = pn -scopeToPackageName (ScopeAnyQualifier pn) = pn +scopeToPackageName (ConstraintScope _stage (ScopeTarget pn)) = pn +scopeToPackageName (ConstraintScope _stage (ScopeQualified _ pn)) = pn +scopeToPackageName (ConstraintScope _stage (ScopeAnySetupQualifier pn)) = pn +scopeToPackageName (ConstraintScope _stage (ScopeAnyQualifier pn)) = pn constraintScopeMatches :: ConstraintScope -> QPN -> Bool -constraintScopeMatches (ScopeTarget pn) (Q (PackagePath _ q) pn') = +constraintScopeMatches (ConstraintScope mstage qualifier) (Q (PackagePath stage' q) pn') = + maybe True (== stage') mstage && constraintQualifierMatches qualifier q pn' + +constraintQualifierMatches :: ConstraintQualifier -> Qualifier -> PackageName -> Bool +constraintQualifierMatches (ScopeTarget pn) q pn' = q == QualToplevel && pn == pn' -constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') = +constraintQualifierMatches (ScopeQualified q pn) q' pn' = q == q' && pn == pn' -constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') = - let setup (PackagePath _ (QualSetup _)) = True - setup _ = False - in setup pp && pn == pn' -constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn' +constraintQualifierMatches (ScopeAnySetupQualifier pn) (QualSetup _) pn' = + pn == pn' +constraintQualifierMatches (ScopeAnyQualifier pn) _ pn' = + pn == pn' +constraintQualifierMatches _ _ _ = False instance Pretty ConstraintScope where + pretty (ConstraintScope mstage qualifier) = + maybe mempty pretty mstage <+> pretty qualifier + +instance Pretty ConstraintQualifier where pretty (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn pretty (ScopeQualified q pn) = dispQualifier q <<>> pretty pn pretty (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn diff --git a/cabal-install/src/Distribution/Client/CmdFreeze.hs b/cabal-install/src/Distribution/Client/CmdFreeze.hs index 2f4ddaac8b4..eb799324f7c 100644 --- a/cabal-install/src/Distribution/Client/CmdFreeze.hs +++ b/cabal-install/src/Distribution/Client/CmdFreeze.hs @@ -30,7 +30,7 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning import Distribution.Client.Targets ( UserConstraint (..) - , UserConstraintScope (..) + , UserConstraintQualifier (..) , UserQualifier (..) ) import Distribution.Solver.Types.ConstraintSource diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index 39c1b973194..fe0e6f80ca3 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -82,7 +82,7 @@ import Distribution.Client.TargetProblem ) import Distribution.Client.Targets ( UserConstraint (..) - , UserConstraintScope (..) + , UserConstraintQualifier (..) ) import Distribution.Client.Types ( PackageSpecifier (..) diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 27a43e7c6d1..7c338b05d34 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -461,7 +461,7 @@ dontInstallNonReinstallablePackages params = where extraConstraints = [ LabeledPackageConstraint - (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled) + (PackageConstraint (ConstraintScope Nothing (ScopeAnyQualifier pkgname)) PackagePropertyInstalled) ConstraintSourceNonReinstallablePackage | pkgname <- nonReinstallablePackages ] @@ -710,7 +710,7 @@ addSetupCabalMinVersionConstraint minVersion = addConstraints [ LabeledPackageConstraint ( PackageConstraint - (ScopeAnySetupQualifier cabalPkgname) + (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname)) (PackagePropertyVersion $ orLaterVersion minVersion) ) ConstraintSetupCabalMinVersion @@ -728,7 +728,7 @@ addSetupCabalMaxVersionConstraint maxVersion = addConstraints [ LabeledPackageConstraint ( PackageConstraint - (ScopeAnySetupQualifier cabalPkgname) + (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname)) (PackagePropertyVersion $ earlierVersion maxVersion) ) ConstraintSetupCabalMaxVersion @@ -744,7 +744,7 @@ addSetupCabalProfiledDynamic = addConstraints [ LabeledPackageConstraint ( PackageConstraint - (ScopeAnySetupQualifier cabalPkgname) + (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname)) (PackagePropertyVersion $ orLaterVersion (mkVersion [3, 13, 0])) ) ConstraintSourceProfiledDynamic diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs index 05fa5d09516..042c3465f23 100644 --- a/cabal-install/src/Distribution/Client/Targets.hs +++ b/cabal-install/src/Distribution/Client/Targets.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} -- | @@ -34,7 +35,8 @@ module Distribution.Client.Targets -- * User constraints , UserQualifier (..) , UserConstraintScope (..) - , UserConstraint (..) + , UserConstraintQualifier (..) + , UserConstraint (UserConstraint, UserConstraintStaged) , userConstraintPackageName , readUserConstraint , userToPackageConstraint @@ -99,6 +101,7 @@ import qualified Data.Map as Map import Distribution.Client.Errors import qualified Distribution.Client.GZipUtils as GZipUtils import qualified Distribution.Compat.CharParsing as P +import Distribution.Solver.Types.Stage (Stage) import Distribution.Utils.Path (makeSymbolicPath) import Network.URI ( URI (..) @@ -611,7 +614,13 @@ instance Structured UserQualifier -- | Version of 'ConstraintScope' that a user may specify on the -- command line. -data UserConstraintScope +data UserConstraintScope = UserConstraintScope (Maybe Stage) UserConstraintQualifier + deriving (Eq, Show, Generic) + +instance Binary UserConstraintScope +instance Structured UserConstraintScope + +data UserConstraintQualifier = -- | Scope that applies to the package when it has the specified qualifier. UserQualified UserQualifier PackageName | -- | Scope that applies to the package when it has a setup qualifier. @@ -620,9 +629,8 @@ data UserConstraintScope UserAnyQualifier PackageName deriving (Eq, Show, Generic) -instance Binary UserConstraintScope -instance NFData UserConstraintScope -instance Structured UserConstraintScope +instance Binary UserConstraintQualifier +instance Structured UserConstraintQualifier fromUserQualifier :: UserQualifier -> Qualifier fromUserQualifier UserQualToplevel = QualToplevel @@ -630,30 +638,38 @@ fromUserQualifier (UserQualSetup name) = QualSetup name fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2 fromUserConstraintScope :: UserConstraintScope -> ConstraintScope -fromUserConstraintScope (UserQualified q pn) = - ScopeQualified (fromUserQualifier q) pn -fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn -fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn +fromUserConstraintScope (UserConstraintScope mstage (UserQualified q pn)) = + ConstraintScope mstage (ScopeQualified (fromUserQualifier q) pn) +fromUserConstraintScope (UserConstraintScope mstage (UserAnySetupQualifier pn)) = + ConstraintScope mstage (ScopeAnySetupQualifier pn) +fromUserConstraintScope (UserConstraintScope mstage (UserAnyQualifier pn)) = + ConstraintScope mstage (ScopeAnyQualifier pn) -- | Version of 'PackageConstraint' that the user can specify on -- the command line. data UserConstraint - = UserConstraint UserConstraintScope PackageProperty + = UserConstraintX UserConstraintScope PackageProperty deriving (Eq, Show, Generic) instance Binary UserConstraint instance NFData UserConstraint instance Structured UserConstraint +pattern UserConstraint :: UserConstraintQualifier -> PackageProperty -> UserConstraint +pattern UserConstraint qualifier prop = UserConstraintX (UserConstraintScope Nothing qualifier) prop + +pattern UserConstraintStaged :: Stage -> UserConstraintQualifier -> PackageProperty -> UserConstraint +pattern UserConstraintStaged stage qualifier prop = UserConstraintX (UserConstraintScope (Just stage) qualifier) prop + userConstraintPackageName :: UserConstraint -> PackageName -userConstraintPackageName (UserConstraint scope _) = scopePN scope +userConstraintPackageName (UserConstraintX (UserConstraintScope _stage qualifier) _) = scopePN qualifier where scopePN (UserQualified _ pn) = pn scopePN (UserAnyQualifier pn) = pn scopePN (UserAnySetupQualifier pn) = pn userToPackageConstraint :: UserConstraint -> PackageConstraint -userToPackageConstraint (UserConstraint scope prop) = +userToPackageConstraint (UserConstraintX scope prop) = PackageConstraint (fromUserConstraintScope scope) prop readUserConstraint :: String -> Either String UserConstraint @@ -668,7 +684,7 @@ readUserConstraint str = ++ "'source', 'test', 'bench', or flags. " instance Pretty UserConstraint where - pretty (UserConstraint scope prop) = + pretty (UserConstraintX scope prop) = pretty $ PackageConstraint (fromUserConstraintScope scope) prop instance Parsec UserConstraint where @@ -684,25 +700,49 @@ instance Parsec UserConstraint where , PackagePropertyStanzas [TestStanzas] <$ P.string "test" , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench" ] - return (UserConstraint scope prop) + return (UserConstraintX scope prop) where parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope parseConstraintScope = do + mstage <- P.optional (P.try (parsec <* P.char ':')) pn <- parsec - P.choice - [ P.char '.' *> withDot pn - , P.char ':' *> withColon pn - , return (UserQualified UserQualToplevel pn) - ] + c <- + P.choice + [ P.char '.' *> withDot pn + , P.char ':' *> withColon pn + , return (UserQualified UserQualToplevel pn) + ] + return $ UserConstraintScope mstage c where - withDot :: PackageName -> m UserConstraintScope + withDot :: PackageName -> m UserConstraintQualifier withDot pn | pn == mkPackageName "any" = UserAnyQualifier <$> parsec | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn - withColon :: PackageName -> m UserConstraintScope + withColon :: PackageName -> m UserConstraintQualifier withColon pn = UserQualified (UserQualSetup pn) <$ P.string "setup." <*> parsec + +-- >>> eitherParsec "foo > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified UserQualToplevel (PackageName "foo"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "foo ^>= 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified UserQualToplevel (PackageName "foo"))) (PackagePropertyVersion (MajorBoundVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "foo:setup.bar > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified (UserQualSetup (PackageName "foo")) (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "setup.any source" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "any"))) PackagePropertySource) +-- +-- >>> eitherParsec "build:rts source" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "rts"))) PackagePropertySource) +-- +-- >>> eitherParsec "setup.any installed" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "any"))) PackagePropertyInstalled) +-- +-- >>> eitherParsec "build:ghc-internal installed" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "ghc-internal"))) PackagePropertyInstalled) diff --git a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs b/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs index 6c8ac9b3966..c4f3362b4e3 100644 --- a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs +++ b/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs @@ -52,7 +52,7 @@ pkgSpecifierConstraints (SpecificSourcePackage pkg) = where pc = PackageConstraint - (ScopeTarget $ packageName pkg) + (scopeToplevel (packageName pkg)) (PackagePropertyVersion $ thisVersion (packageVersion pkg)) mkNamedPackage :: PackageIdentifier -> PackageSpecifier pkg diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 194fb75dde0..55346020a7c 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -30,7 +30,7 @@ import Distribution.Client.TargetSelector hiding (DirActions (..)) import qualified Distribution.Client.TargetSelector as TS (DirActions (..)) import Distribution.Client.Targets ( UserConstraint (..) - , UserConstraintScope (UserAnyQualifier) + , UserConstraintQualifier (UserAnyQualifier) ) import Distribution.Client.Types ( PackageLocation (..) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index 5a7daf43cc7..18242903c12 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -287,6 +287,10 @@ instance Arbitrary UserConstraintScope where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary UserConstraintQualifier where + arbitrary = genericArbitrary + shrink = genericShrink + instance Arbitrary UserQualifier where arbitrary = oneof diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs index ac6d96cc159..cbb16c49477 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs @@ -4,7 +4,7 @@ module UnitTests.Distribution.Client.Targets import Distribution.Client.Targets ( UserConstraint (..) - , UserConstraintScope (..) + , UserConstraintQualifier (..) , UserQualifier (..) , readUserConstraint ) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs index 545e33c0449..b7db877562e 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -82,6 +82,7 @@ instance ToExpr Timestamp instance ToExpr TotalIndexState instance ToExpr UserConstraint instance ToExpr UserConstraintScope +instance ToExpr UserConstraintQualifier instance ToExpr UserQualifier instance ToExpr WriteGhcEnvironmentFilesPolicy diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index 91603973b90..a994170db03 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -500,8 +500,8 @@ arbitraryConstraint pkgs = do (PN pn, v) <- elements pkgs let anyQualifier = ScopeAnyQualifier (mkPackageName pn) oneof - [ ExVersionConstraint anyQualifier <$> arbitraryVersionRange v - , ExStanzaConstraint anyQualifier <$> sublistOf [TestStanzas, BenchStanzas] + [ ExVersionConstraint (ConstraintScope Nothing anyQualifier) <$> arbitraryVersionRange v + , ExStanzaConstraint (ConstraintScope Nothing anyQualifier) <$> sublistOf [TestStanzas, BenchStanzas] ] arbitraryPreference :: [(PN, PV)] -> Gen ExPreference diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs index 9ea020bd512..e8ac96114a1 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -77,13 +77,13 @@ tests = any $ isInfixOf "rejecting: pkg:-flag (manual flag can only be changed explicitly)" in runTest $ setVerbose $ - constraints [ExVersionConstraint (ScopeAnyQualifier "true-dep") V.noVersion] $ + constraints [ExVersionConstraint (ConstraintScope Nothing (ScopeAnyQualifier "true-dep")) V.noVersion] $ mkTest dbManualFlags "Don't toggle manual flag to avoid conflict" ["pkg"] $ -- TODO: We should check the summarized log instead of the full log -- for the manual flags error message, but it currently only -- appears in the full log. SolverResult checkFullLog (Left $ const True) - , let cs = [ExFlagConstraint (ScopeAnyQualifier "pkg") "flag" False] + , let cs = [ExFlagConstraint (ConstraintScope Nothing (ScopeAnyQualifier "pkg")) "flag" False] in runTest $ constraints cs $ mkTest dbManualFlags "Toggle manual flag with flag constraint" ["pkg"] $ @@ -92,7 +92,7 @@ tests = , testGroup "Qualified manual flag constraints" [ let name = "Top-level flag constraint does not constrain setup dep's flag" - cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] + cs = [ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" False] in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ @@ -105,8 +105,8 @@ tests = ] , let name = "Solver can toggle setup dep's flag to match top-level constraint" cs = - [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False - , ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion + [ ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" False + , ExVersionConstraint (ConstraintScope Nothing (ScopeAnyQualifier "b-2-true-dep")) V.noVersion ] in runTest $ constraints cs $ @@ -120,8 +120,8 @@ tests = ] , let name = "User can constrain flags separately with qualified constraints" cs = - [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True - , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False + [ ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" True + , ExFlagConstraint (ConstraintScope Nothing (ScopeQualified (P.QualSetup "A") "B")) "flag" False ] in runTest $ constraints cs $ @@ -135,15 +135,15 @@ tests = ] , -- Regression test for #4299 let name = "Solver can link deps when only one has constrained manual flag" - cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] + cs = [ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" False] in runTest $ constraints cs $ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $ solverSuccess [("A", 1), ("B", 1), ("b-1-false-dep", 1)] , let name = "Solver cannot link deps that have conflicting manual flag constraints" cs = - [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True - , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False + [ ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" True + , ExFlagConstraint (ConstraintScope Nothing (ScopeQualified (P.QualSetup "A") "B")) "flag" False ] failureReason = "(constraint from unknown source requires opposite flag selection)" checkFullLog lns = @@ -295,20 +295,20 @@ tests = [ runTest $ mkTest dbConstraints "install latest versions without constraints" ["A", "B", "C"] $ solverSuccess [("A", 7), ("B", 8), ("C", 9), ("D", 7), ("D", 8), ("D", 9)] - , let cs = [ExVersionConstraint (ScopeAnyQualifier "D") $ mkVersionRange 1 4] + , let cs = [ExVersionConstraint (ConstraintScope Nothing (ScopeAnyQualifier "D")) $ mkVersionRange 1 4] in runTest $ constraints cs $ mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $ solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)] , let cs = - [ ExVersionConstraint (ScopeQualified P.QualToplevel "D") $ mkVersionRange 1 4 - , ExVersionConstraint (ScopeQualified (P.QualSetup "B") "D") $ mkVersionRange 4 7 + [ ExVersionConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "D")) $ mkVersionRange 1 4 + , ExVersionConstraint (ConstraintScope Nothing (ScopeQualified (P.QualSetup "B") "D")) $ mkVersionRange 4 7 ] in runTest $ constraints cs $ mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $ solverSuccess [("A", 1), ("B", 5), ("C", 9), ("D", 1), ("D", 5), ("D", 9)] - , let cs = [ExVersionConstraint (ScopeAnySetupQualifier "D") $ mkVersionRange 1 4] + , let cs = [ExVersionConstraint (ConstraintScope Nothing (ScopeAnySetupQualifier "D")) $ mkVersionRange 1 4] in runTest $ constraints cs $ mkTest dbConstraints "constrain package across setup scripts" ["A", "B", "C"] $ @@ -450,7 +450,7 @@ tests = `withSubLibrary` exSubLib "sub-lib" [ExFlagged "make-lib-private" (dependencies []) publicDependencies] ] in runTest $ - constraints [ExFlagConstraint (ScopeAnyQualifier "B") "make-lib-private" True] $ + constraints [ExFlagConstraint (ConstraintScope Nothing (ScopeAnyQualifier "B")) "make-lib-private" True] $ mkTest db "reject package with sub-library made private by flag constraint" ["A"] $ solverFailure $ isInfixOf "rejecting: B-1 (library 'sub-lib' is private, but it is required by A)" @@ -563,7 +563,7 @@ tests = ] , -- tests for partial fix for issue #5325 testGroup "Components that are unbuildable in the current environment" $ - let flagConstraint = ExFlagConstraint . ScopeAnyQualifier + let flagConstraint = ExFlagConstraint . ConstraintScope Nothing . ScopeAnyQualifier in [ let db = [Right $ exAv "A" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies]] in runTest $ constraints [flagConstraint "A" "build-lib" False] $ @@ -2502,7 +2502,7 @@ requireConsistentBuildToolVersions name = -- instead of missing. chooseUnbuildableExeAfterBuildToolsPackage :: String -> SolverTest chooseUnbuildableExeAfterBuildToolsPackage name = - constraints [ExFlagConstraint (ScopeAnyQualifier "B") "build-bt2" False] $ + constraints [ExFlagConstraint (ConstraintScope Nothing (ScopeAnyQualifier "B")) "build-bt2" False] $ goalOrder goals $ mkTest db name ["A"] $ solverFailure $ @@ -2618,7 +2618,7 @@ setupStanzaTest1 = constraints [ExStanzaConstraint (scopeToplevel "B") [TestStan -- With the "any" qualifier syntax setupStanzaTest2 :: SolverTest setupStanzaTest2 = - constraints [ExStanzaConstraint (ScopeAnyQualifier "B") [TestStanzas]] $ + constraints [ExStanzaConstraint (ConstraintScope Nothing (ScopeAnyQualifier "B")) [TestStanzas]] $ mkTest dbSetupStanza "setupStanzaTest2" From ab21c2d2825283881b55f3341d986453723d73e3 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 23 Apr 2025 17:59:51 +0800 Subject: [PATCH 13/54] refactor(cabal-install-solver): improve messages --- cabal-install-solver/src/Distribution/Solver/Modular/Message.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs index 5f17428c8bd..d378c732821 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs @@ -263,7 +263,7 @@ showOption :: QPN -> POption -> String showOption qpn@(Q _pp pn) (POption i linkedTo) = case linkedTo of Nothing -> showQPN qpn ++ " == " ++ showI i - Just pp' -> showQPN qpn ++ " ~> " ++ showQPN (Q pp' pn) + Just pp' -> "to reuse " ++ showQPN (Q pp' pn) ++ " for " ++ showQPN qpn -- | Shows a mixed list of instances and versions in a human-friendly way, -- abbreviated. From 9ee520463e757262405744468b42f938dc206b4e Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 23 Apr 2025 18:00:53 +0800 Subject: [PATCH 14/54] refactor(cabal-install): use a pretty printer in showDepResolverParams --- .../src/Distribution/Client/Dependency.hs | 88 ++++++++++--------- 1 file changed, 46 insertions(+), 42 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 7c338b05d34..eb7da76f2a7 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -115,7 +115,8 @@ import qualified Distribution.PackageDescription.Configuration as PD import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import Distribution.Simple.Setup - ( asBool + ( BooleanFlag + , asBool ) import Distribution.Solver.Modular ( PruneAfterFirstSuccess (..) @@ -136,7 +137,8 @@ import Distribution.Types.DependencySatisfaction ( DependencySatisfaction (..) ) import Distribution.Verbosity - ( VerbosityLevel (..) + ( deafening + , normal ) import Distribution.Version @@ -172,6 +174,7 @@ import Data.List ) import qualified Data.Map as Map import qualified Data.Set as Set +import Text.PrettyPrint -- ------------------------------------------------------------ @@ -216,47 +219,48 @@ data DepResolverParams = DepResolverParams showDepResolverParams :: DepResolverParams -> String showDepResolverParams p = - "targets: " - ++ intercalate ", " (map prettyShow $ Set.toList (depResolverTargets p)) - ++ "\nconstraints: " - ++ concatMap - (("\n " ++) . showLabeledConstraint) - (depResolverConstraints p) - ++ "\npreferences: " - ++ concatMap - (("\n " ++) . showPackagePreference) - (depResolverPreferences p) - ++ "\nstrategy: " - ++ show (depResolverPreferenceDefault p) - ++ "\nreorder goals: " - ++ show (asBool (depResolverReorderGoals p)) - ++ "\ncount conflicts: " - ++ show (asBool (depResolverCountConflicts p)) - ++ "\nfine grained conflicts: " - ++ show (asBool (depResolverFineGrainedConflicts p)) - ++ "\nminimize conflict set: " - ++ show (asBool (depResolverMinimizeConflictSet p)) - ++ "\nindependent goals: " - ++ show (asBool (depResolverIndependentGoals p)) - ++ "\navoid reinstalls: " - ++ show (asBool (depResolverAvoidReinstalls p)) - ++ "\nshadow packages: " - ++ show (asBool (depResolverShadowPkgs p)) - ++ "\nstrong flags: " - ++ show (asBool (depResolverStrongFlags p)) - ++ "\nallow boot library installs: " - ++ show (asBool (depResolverAllowBootLibInstalls p)) - ++ "\nonly constrained packages: " - ++ show (depResolverOnlyConstrained p) - ++ "\nmax backjumps: " - ++ maybe - "infinite" - show - (depResolverMaxBackjumps p) + render $ + vcat + [ hang (text "targets:") 2 $ + vcat [text (prettyShow pkgname) | pkgname <- Set.toList (depResolverTargets p)] + , hang (text "constraints:") 2 $ + vcat [prettyLabeledConstraint lc | lc <- depResolverConstraints p] + , hang (text "constraints:") 2 $ + vcat [prettyLabeledConstraint lc | lc <- depResolverConstraints p] + , hang (text "preferences:") 2 $ + if depResolverVerbosity p >= deafening + then vcat [text (showPackagePreference pref) | pref <- depResolverPreferences p] + else text "... increase verbosity to see" + , hang (text "strategy:") 2 $ + text (show (depResolverPreferenceDefault p)) + , hang (text "reorder goals:") 2 $ + prettyBool (depResolverReorderGoals p) + , hang (text "count conflicts:") 2 $ + prettyBool (depResolverCountConflicts p) + , hang (text "fine grained conflicts:") 2 $ + prettyBool (depResolverFineGrainedConflicts p) + , hang (text "minimize conflict set:") 2 $ + prettyBool (depResolverMinimizeConflictSet p) + , hang (text "avoid reinstalls:") 2 $ + prettyBool (depResolverAvoidReinstalls p) + , hang (text "shadow packages:") 2 $ + prettyBool (depResolverShadowPkgs p) + , hang (text "strong flags:") 2 $ + prettyBool (depResolverStrongFlags p) + , hang (text "allow boot library installs:") 2 $ + prettyBool (depResolverAllowBootLibInstalls p) + , hang (text "only constrained packages:") 2 $ + text (show (depResolverOnlyConstrained p)) + , hang (text "max backjumps:") 2 $ + text (maybe "infinite" show (depResolverMaxBackjumps p)) + ] where - showLabeledConstraint :: LabeledPackageConstraint -> String - showLabeledConstraint (LabeledPackageConstraint pc src) = - showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")" + prettyBool :: BooleanFlag a => a -> Doc + prettyBool = pretty . asBool + + prettyLabeledConstraint :: LabeledPackageConstraint -> Doc + prettyLabeledConstraint (LabeledPackageConstraint pc src) = + pretty pc <+> parens (pretty src) -- | A package selection preference for a particular package. -- From cdd42ccb1d3024aeaa45ad155a404e1687aa3291 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 23 Apr 2025 18:00:53 +0800 Subject: [PATCH 15/54] feat(cabal-install-solver): add null to ComponentDeps --- .../src/Distribution/Solver/Types/ComponentDeps.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs b/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs index e551aa2916b..4355a797cd6 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs @@ -36,11 +36,12 @@ module Distribution.Solver.Types.ComponentDeps ( , setupDeps , select , components + , null ) where import Prelude () import Distribution.Types.UnqualComponentName -import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip) +import Distribution.Solver.Compat.Prelude hiding (null, empty, toList, zip) import qualified Data.Map as Map @@ -132,6 +133,9 @@ insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps aux Nothing = Just a aux (Just a') = Just $ a `mappend` a' +null :: ComponentDeps a -> Bool +null = Map.null . unComponentDeps + -- | Zip two 'ComponentDeps' together by 'Component', using 'mempty' -- as the neutral element when a 'Component' is present only in one. zip From edd6679e7c503a36cfd1416c511a35ab84c11c87 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 23 Apr 2025 18:00:53 +0800 Subject: [PATCH 16/54] feat(cabal-install-solver): add Pretty instance for SolverId --- .../src/Distribution/Solver/Types/SolverId.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs index d32ccc17e74..1141530c7c4 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs @@ -9,6 +9,8 @@ import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Package (PackageId, Package(..), UnitId) +import Distribution.Pretty (Pretty (..)) +import Text.PrettyPrint (parens) -- | The solver can produce references to existing packages or -- packages we plan to install. Unlike 'ConfiguredId' we don't @@ -27,3 +29,7 @@ instance Show SolverId where instance Package SolverId where packageId = solverSrcId + +instance Pretty SolverId where + pretty (PreExistingId pkg unitId) = pretty pkg <+> parens (pretty unitId) + pretty (PlannedId pkg) = pretty pkg \ No newline at end of file From f644628d1d568b79b1fad090ee5ae8e33a7226a0 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 28 Apr 2025 22:49:55 +0800 Subject: [PATCH 17/54] refactor(cabal-install): merge two almost identical functions Merge fromSolverInstallPlan and fromSolverInstallPlanWithProgress. --- Cabal/src/Distribution/Utils/LogProgress.hs | 11 +++++ .../src/Distribution/Client/InstallPlan.hs | 44 +++++-------------- 2 files changed, 21 insertions(+), 34 deletions(-) diff --git a/Cabal/src/Distribution/Utils/LogProgress.hs b/Cabal/src/Distribution/Utils/LogProgress.hs index 5f3ada889bf..f010a4c9913 100644 --- a/Cabal/src/Distribution/Utils/LogProgress.hs +++ b/Cabal/src/Distribution/Utils/LogProgress.hs @@ -4,6 +4,7 @@ module Distribution.Utils.LogProgress ( LogProgress , runLogProgress + , runLogProgress' , warnProgress , infoProgress , dieProgress @@ -71,6 +72,16 @@ runLogProgress verbosity (LogProgress m) = fail_fn doc = do dieNoWrap verbosity (render doc) +-- | Run 'LogProgress' ignoring all traces. +runLogProgress' :: LogProgress a -> Either ErrMsg a +runLogProgress' (LogProgress m) = foldProgress (\_ x -> x) Left Right (m env) + where + env = + LogEnv + { le_verbosity = silent + , le_context = [] + } + -- | Output a warning trace message in 'LogProgress'. warnProgress :: Doc -> LogProgress () warnProgress s = LogProgress $ \env -> diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index 17838aadc5f..b929fc6c4e4 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -539,36 +539,11 @@ fromSolverInstallPlan -> SolverInstallPlan -> GenericInstallPlan ipkg srcpkg fromSolverInstallPlan f plan = - mkInstallPlan - "fromSolverInstallPlan" - (Graph.fromDistinctList pkgs'') - (SolverInstallPlan.planIndepGoals plan) - where - (_, _, pkgs'') = - foldl' - f' - (Map.empty, Map.empty, []) - (SolverInstallPlan.reverseTopologicalOrder plan) - - f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs) - where - pkgs' = f (mapDep pidMap ipiMap) pkg - - (pidMap', ipiMap') = - case nodeKey pkg of - PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) - PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) - - mapDep _ ipiMap (PreExistingId _pid uid) - | Just pkgs <- Map.lookup uid ipiMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) - mapDep pidMap _ (PlannedId pid) - | Just pkgs <- Map.lookup pid pidMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) - --- This shouldn't happen, since mapDep should only be called --- on neighbor SolverId, which must have all been done already --- by the reverse top-sort (we assume the graph is not broken). + either (error . show) id $ + runLogProgress' $ + fromSolverInstallPlanWithProgress + (\mapDep planpkg -> return $ f mapDep planpkg) + plan fromSolverInstallPlanWithProgress :: (IsUnit ipkg, IsUnit srcpkg) @@ -598,6 +573,11 @@ fromSolverInstallPlanWithProgress f plan = do PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) return (pidMap', ipiMap', pkgs' ++ pkgs) + -- The error below shouldn't happen, since mapDep should only + -- be called on neighbor SolverId, which must have all been done + -- already by the reverse top-sort (we assume the graph is not broken). + -- + -- FIXME: stage is ignored mapDep _ ipiMap (PreExistingId _pid uid) | Just pkgs <- Map.lookup uid ipiMap = pkgs | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) @@ -605,10 +585,6 @@ fromSolverInstallPlanWithProgress f plan = do | Just pkgs <- Map.lookup pid pidMap = pkgs | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) --- This shouldn't happen, since mapDep should only be called --- on neighbor SolverId, which must have all been done already --- by the reverse top-sort (we assume the graph is not broken). - -- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. -- Similar to 'elaboratedInstallPlan' configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan From 22eb45e559761550310333b3fcea04da48810315 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 29 Apr 2025 17:23:02 +0800 Subject: [PATCH 18/54] chore(cabal-install-solver): add comments and improve readability --- .../Distribution/Solver/Modular/Builder.hs | 76 +++++++++------- .../Distribution/Solver/Modular/Dependency.hs | 68 +++++++++++--- .../src/Distribution/Solver/Modular/Index.hs | 13 ++- .../src/Distribution/Solver/Modular/Tree.hs | 91 +++++++++++++++---- 4 files changed, 179 insertions(+), 69 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs index 2ea62ec4ed9..875c9bf78c3 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs @@ -63,41 +63,48 @@ type LinkingState = M.Map (PN, I) [PackagePath] -- We also adjust the map of overall goals, and keep track of the -- reverse dependencies of each of the goals. extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState -extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs +extendOpen qpn deps buildState@(BS { rdeps = rdeps0, open = goals0 }) = go rdeps0 goals0 deps where go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState - go g o [] = s { rdeps = g, open = o } - go g o ((Flagged fn@(FN qpn _) fInfo t f) : ngs) = - go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs - -- Note: for 'Flagged' goals, we always insert, so later additions win. - -- This is important, because in general, if a goal is inserted twice, - -- the later addition will have better dependency information. - go g o ((Stanza sn@(SN qpn _) t) : ngs) = - go g (StanzaGoal sn t (flagGR qpn) : o) ngs - go g o ((Simple (LDep dr (Dep (PkgComponent qpn _) _)) c) : ngs) - | qpn == qpn' = - -- We currently only add a self-dependency to the graph if it is - -- between a package and its setup script. The edge creates a cycle - -- and causes the solver to backtrack and choose a different - -- instance for the setup script. We may need to track other - -- self-dependencies once we implement component-based solving. + go rdeps goals [] = + buildState { rdeps = rdeps, open = goals } + + go rdeps goals ((Flagged fn@(FN qpn' _) fInfo t f) : fdeps) = + go rdeps (FlagGoal fn fInfo t f (flagGR qpn') : goals) fdeps + + -- Note: for 'Flagged' goals, we always insert, so later additions win. + -- This is important, because in general, if a goal is inserted twice, + -- the later addition will have better dependency information. + go rdeps goals ((Stanza sn@(SN qpn' _) t) : fdeps) = + go rdeps (StanzaGoal sn t (flagGR qpn') : goals) fdeps + + go rdeps goals ((Simple (LDep dr (Dep (PkgComponent qpn' _) _)) c) : fdeps) + | qpn' == qpn = + -- We currently only add a self-dependency to the graph if it is + -- between a package and its setup script. The edge creates a cycle + -- and causes the solver to backtrack and choose a different + -- instance for the setup script. We may need to track other + -- self-dependencies once we implement component-based solving. case c of - ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn g) o ngs - _ -> go g o ngs - | qpn `M.member` g = go (M.adjust (addIfAbsent (c, qpn')) qpn g) o ngs - | otherwise = go (M.insert qpn [(c, qpn')] g) (PkgGoal qpn (DependencyGoal dr) : o) ngs - -- code above is correct; insert/adjust have different arg order - go g o ((Simple (LDep _dr (Ext _ext )) _) : ngs) = go g o ngs - go g o ((Simple (LDep _dr (Lang _lang))_) : ngs) = go g o ngs - go g o ((Simple (LDep _dr (Pkg _pn _vr))_) : ngs) = go g o ngs + ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn)) qpn' rdeps) goals fdeps + _ -> go rdeps goals fdeps + | qpn' `M.member` rdeps = + go (M.adjust (addIfAbsent (c, qpn)) qpn' rdeps) goals fdeps + | otherwise = + -- Note: insert/adjust have different arg order + go (M.insert qpn' [(c, qpn)] rdeps) (PkgGoal qpn' (DependencyGoal dr) : goals) fdeps + + go rdeps o ((Simple (LDep _dr (Ext _ext )) _c) : goals) = go rdeps o goals + go rdeps o ((Simple (LDep _dr (Lang _lang)) _c) : goals) = go rdeps o goals + go rdeps o ((Simple (LDep _dr (Pkg _pn _vr)) _c) : goals) = go rdeps o goals addIfAbsent :: Eq a => a -> [a] -> [a] addIfAbsent x xs = if x `elem` xs then xs else x : xs - -- GoalReason for a flag or stanza. Each flag/stanza is introduced only by - -- its containing package. - flagGR :: qpn -> GoalReason qpn - flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty) +-- GoalReason for a flag or stanza. Each flag/stanza is introduced only by +-- its containing package. +flagGR :: qpn -> GoalReason qpn +flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty) -- | Given the current scope, qualify all the package names in the given set of -- dependencies and then extend the set of open goals accordingly. @@ -128,12 +135,14 @@ build = ana go go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState) go s = addLinking (linkingState s) $ addChildren (buildState s) +-- | Add children to the tree based on the current build state. addChildren :: BuildState -> TreeF () QGoalReason BuildState -- If we have a choice between many goals, we just record the choice in -- the tree. We select each open goal in turn, and before we descend, remove -- it from the queue of open goals. addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals }) + -- No goals left. We have done. | L.null gs = DoneF rdm () | otherwise = GoalChoiceF rdm $ P.fromList $ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' })) @@ -251,21 +260,22 @@ 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 - , rdeps = M.fromList (L.map (, []) qpns) - , open = L.map topLevelGoal qpns + , rdeps = M.fromList [(qpn, []) | qpn <- qpns] + , open = [ PkgGoal qpn UserGoal | qpn <- qpns ] , next = Goals , qualifyOptions = defaultQualifyOptions idx } , linkingState = M.empty } where - topLevelGoal qpn = PkgGoal qpn UserGoal + -- The package names are interpreted as top-level goals in the host stage. + path = PackagePath Stage.Host QualToplevel + qpns = [ Q path pn | pn <- igs ] - qpns = L.map (Q (PackagePath Stage.Host QualToplevel)) igs {------------------------------------------------------------------------------- Goals diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs index 8c141222ad1..1a3783fe6ba 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs @@ -86,14 +86,36 @@ type FlaggedDeps qpn = [FlaggedDep qpn] -- | Flagged dependencies can either be plain dependency constraints, -- or flag-dependent dependency trees. -data FlaggedDep qpn = - -- | Dependencies which are conditional on a flag choice. - Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) - -- | Dependencies which are conditional on whether or not a stanza +-- +-- Note: this is a recursive data structure representing a tree of dependencies. +-- +-- Note 2: why LDep contains its own DependencyReason? I am thinking it should +-- be external to this type. Basically you traverse the tree and the flag and +-- stanza choices are the DepedencyReason? +data FlaggedDep qpn + = -- | Dependencies which are conditional on a flag choice. + Flagged + (FN qpn) + -- ^ The qualified flag name. + FInfo + -- ^ The flag information. + (FlaggedDeps qpn) + -- ^ Extra dependencies when the flag is true. + (FlaggedDeps qpn) + -- ^ Extra dependencies when the flag is false. + | -- | Dependencies which are conditional on whether or not a stanza. -- (e.g., a test suite or benchmark) is enabled. - Stanza (SN qpn) (TrueFlaggedDeps qpn) - | -- | Dependencies which are always enabled, for the component 'comp'. - Simple (LDep qpn) Component + Stanza + (SN qpn) + -- ^ The qualified stanza name. + (FlaggedDeps qpn) + -- ^ Extra dependencies when stanza is enabled. + | -- | Dependencies which are always enabled. + Simple + (LDep qpn) + -- ^ The dependency. + Component + -- ^ The component of `qpn` introducing the dependency. deriving Show -- | Conservatively flatten out flagged dependencies @@ -107,16 +129,18 @@ flattenFlaggedDeps = concatMap aux aux (Stanza _ t) = flattenFlaggedDeps t aux (Simple d c) = [(d, c)] -type TrueFlaggedDeps qpn = FlaggedDeps qpn -type FalseFlaggedDeps qpn = FlaggedDeps qpn - -- | A 'Dep' labeled with the reason it was introduced. -- -- 'LDep' intentionally has no 'Functor' instance because the type variable -- is used both to record the dependencies as well as who's doing the -- depending; having a 'Functor' instance makes bugs where we don't distinguish -- these two far too likely. (By rights 'LDep' ought to have two type variables.) -data LDep qpn = LDep (DependencyReason qpn) (Dep qpn) +data LDep qpn + = LDep + (DependencyReason qpn) + -- ^ The reason the dependency was introduced. + (Dep qpn) + -- ^ The dependency itself. deriving Show -- | A dependency (constraint) associates a package name with a constrained @@ -135,21 +159,35 @@ data Dep qpn -- | An exposed component within a package. This type is used to represent -- build-depends and build-tool-depends dependencies. -data PkgComponent qpn = PkgComponent qpn ExposedComponent +data PkgComponent qpn + = PkgComponent + qpn + -- ^ The qualified name of the package. + ExposedComponent + -- ^ The component exposed by the package. deriving (Eq, Ord, Functor, Show) -- | A component that can be depended upon by another package, i.e., a library -- or an executable. -data ExposedComponent = +data ExposedComponent + = -- | A library component ExposedLib LibraryName - | ExposedExe UnqualComponentName + | -- | An executable component + ExposedExe UnqualComponentName deriving (Eq, Ord, Show) -- | The reason that a dependency is active. It identifies the package and any -- flag and stanza choices that introduced the dependency. It contains -- everything needed for creating ConflictSets or describing conflicts in solver -- log messages. -data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Stanza) +data DependencyReason qpn + = DependencyReason + qpn + -- ^ The qualified name of the dependent package. + (Map Flag FlagValue) + -- ^ The flag choices that introduced the dependency. + (S.Set Stanza) + -- ^ The stanza choices that introduced the dependency. deriving (Functor, Eq, Show) -- | Print the reason that a dependency was introduced. diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs index 2f28d12de85..cfd8f94a64d 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs @@ -32,10 +32,15 @@ type Index = Map PN (Map I PInfo) -- globally, for reasons external to the solver. We currently use this -- for shadowing which essentially is a GHC limitation, and for -- installed packages that are broken. -data PInfo = PInfo (FlaggedDeps PN) - (Map ExposedComponent ComponentInfo) - FlagInfo - (Maybe FailReason) +data PInfo = PInfo + (FlaggedDeps PN) + -- ^ The package dependencies, whether they are conditional on a flag, a + -- stanza or always active. + (Map ExposedComponent ComponentInfo) + -- ^ Info associated with each library and executable component. + FlagInfo + -- + (Maybe FailReason) -- | Info associated with each library and executable in a package instance. data ComponentInfo = ComponentInfo { diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs index aeda39f6b3f..169b33de499 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs @@ -49,19 +49,52 @@ type Weight = Double -- -- TODO: The weight type should be changed from [Double] to Double to avoid -- giving too much weight to preferences that are applied later. -data Tree d c = - -- | Choose a version for a package (or choose to link) - PChoice QPN RevDepMap c (WeightedPSQ [Weight] POption (Tree d c)) +-- +-- Note: this the tree *of possible choices*, which is used to explore all +-- possible solutions to a given problem. It does not describe a single solution. +data Tree d c + = -- | Choose a version for a package (or choose to link) + PChoice + QPN + -- ^ The package to choose an instance for + RevDepMap + -- ^ The reverse dependency map (FIXME ?) + c + -- ^ Additional data for the choice node + (WeightedPSQ [Weight] POption (Tree d c)) + -- ^ Weighted list of possible options (`POption`) paired with the subsequent search tree. - -- | Choose a value for a flag - -- - -- The Bool is the default value. - | FChoice QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool (Tree d c)) + | -- | Choose a value for a flag. + FChoice + QFN + -- ^ The flag to choose a value for. + RevDepMap + -- ^ The reverse dependency map (FIXME ?). + c + -- ^ Additional data for the choice node. + WeakOrTrivial + -- ^ Whether the choice should be deferred. + FlagType + -- ^ Whether the flag is manual or automatic. + Bool + -- ^ The flag default value + (WeightedPSQ [Weight] Bool (Tree d c)) + -- ^ Weighted list of possible options paired with the subsequent search tree. - -- | Choose whether or not to enable a stanza - | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c)) + | -- | Choose whether or not to enable a stanza. + SChoice + QSN + -- ^ The stanza to choose to enable or disable. + RevDepMap + -- ^ The reverse dependency map (FIXME ?). + c + -- ^ Additional data for the choice node. + WeakOrTrivial + -- ^ Whether the choice should be deferred. + (WeightedPSQ [Weight] Bool (Tree d c)) + -- ^ Weighted list of possible options paired with the subsequent search tree. - -- | Choose which choice to make next + | -- | Choose which choice to make next -- -- Invariants: -- @@ -72,13 +105,25 @@ data Tree d c = -- invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice' -- or 'SChoice' directly below a 'GoalChoice' node must equal the reason -- recorded on that 'GoalChoice' node. - | GoalChoice RevDepMap (PSQ (Goal QPN) (Tree d c)) + GoalChoice + RevDepMap + -- ^ The reverse dependency map (FIXME ?). + (PSQ (Goal QPN) (Tree d c)) + -- ^ Priority search queue associating a goal with the search tree. - -- | We're done -- we found a solution! - | Done RevDepMap d + | -- | We're done -- we found a solution! + Done + RevDepMap + -- ^ The reverse dependency map (FIXME ?). + d + -- ^ The solution. - -- | We failed to find a solution in this path through the tree - | Fail ConflictSet FailReason + | -- | We failed to find a solution in this path through the tree + Fail + ConflictSet + -- ^ The conflict set. + FailReason + -- ^ The reason for failure. -- | A package option is a package instance with an optional linking annotation -- @@ -96,7 +141,12 @@ data Tree d c = -- dependencies must also be the exact same). -- -- See for details. -data POption = POption I (Maybe PackagePath) +data POption + = POption + I + -- ^ The choosen package instance. + (Maybe PackagePath) + -- ^ The package this choice is linked to (if any). deriving (Eq, Show) data FailReason = UnsupportedExtension Extension @@ -133,7 +183,14 @@ data FailReason = UnsupportedExtension Extension deriving (Eq, Show) -- | Information about a dependency involved in a conflict, for error messages. -data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI +data ConflictingDep + = ConflictingDep + (DependencyReason QPN) + -- ^ The reason for the dependency. + (PkgComponent QPN) + -- ^ The component of the package that caused the conflict. + CI + -- ^ The constrained instance. deriving (Eq, Show) -- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' From 336f88ad52c9b78dfda0db3fbd1cc99c3118d15f Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 2 Jul 2025 13:11:36 +0800 Subject: [PATCH 19/54] feat(cabal-install, cabal-install-solver): track stage in SolverId --- .../Solver/Modular/ConfiguredConversion.hs | 8 ++++---- .../Distribution/Solver/Types/ResolverPackage.hs | 15 +++++++++++++-- .../src/Distribution/Solver/Types/SolverId.hs | 13 ++++++++----- cabal-install/src/Distribution/Client/Freeze.hs | 12 ++++++++++-- .../src/Distribution/Client/InstallPlan.hs | 9 +++++---- .../src/Distribution/Client/ProjectPlanning.hs | 11 ++++++----- 6 files changed, 46 insertions(+), 22 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs index 72eedf3ceaa..af78f678712 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs @@ -57,9 +57,9 @@ convCP iidx sidx (CP qpi fa es ds) = ds' = fmap (partitionEithers . map convConfId) ds convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -} -convConfId (PI (Q (PackagePath _stage q) pn) (I _stage' v loc)) = +convConfId (PI (Q (PackagePath _stage q) pn) (I stage v loc)) = case loc of - Inst pi -> Left (PreExistingId sourceId pi) + Inst pi -> Left (PreExistingId stage sourceId pi) _otherwise | QualExe _ pn' <- q -- NB: the dependencies of the executable are also @@ -68,7 +68,7 @@ convConfId (PI (Q (PackagePath _stage q) pn) (I _stage' v loc)) = -- at the actual thing. Fortunately for us, I was -- silly and didn't allow arbitrarily nested build-tools -- dependencies, so a shallow check works. - , pn == pn' -> Right (PlannedId sourceId) - | otherwise -> Left (PlannedId sourceId) + , pn == pn' -> Right (PlannedId stage sourceId) + | otherwise -> Left (PlannedId stage sourceId) where sourceId = PackageIdentifier pn v diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs index d7f9520866b..9458e7ee0b1 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs @@ -2,6 +2,8 @@ {-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.ResolverPackage ( ResolverPackage(..) + , solverId + , solverQPN , resolverPackageLibDeps , resolverPackageExeDeps ) where @@ -12,6 +14,7 @@ import Prelude () import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.PackagePath (QPN) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Compat.Graph (IsNode(..)) @@ -35,6 +38,14 @@ instance Package (ResolverPackage loc) where packageId (PreExisting ipkg) = packageId ipkg packageId (Configured spkg) = packageId spkg +solverId :: ResolverPackage loc -> SolverId +solverId (PreExisting ipkg) = PreExistingId (instSolverStage ipkg) (packageId ipkg) (installedUnitId ipkg) +solverId (Configured spkg) = PlannedId (solverPkgStage spkg) (packageId spkg) + +solverQPN :: ResolverPackage loc -> QPN +solverQPN (PreExisting ipkg) = instSolverQPN ipkg +solverQPN (Configured spkg) = solverPkgQPN spkg + resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg @@ -45,8 +56,8 @@ resolverPackageExeDeps (Configured spkg) = solverPkgExeDeps spkg instance IsNode (ResolverPackage loc) where type Key (ResolverPackage loc) = SolverId - nodeKey (PreExisting ipkg) = PreExistingId (packageId ipkg) (installedUnitId ipkg) - nodeKey (Configured spkg) = PlannedId (packageId spkg) + nodeKey = solverId + -- Use dependencies for ALL components nodeNeighbors pkg = ordNub $ fold (resolverPackageLibDeps pkg) ++ diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs index 1141530c7c4..9afb8bf1338 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs @@ -10,15 +10,18 @@ import Prelude () import Distribution.Package (PackageId, Package(..), UnitId) import Distribution.Pretty (Pretty (..)) -import Text.PrettyPrint (parens) +import Distribution.Solver.Types.Stage (Stage) + +import Text.PrettyPrint (colon, punctuate, text) + -- | The solver can produce references to existing packages or -- packages we plan to install. Unlike 'ConfiguredId' we don't -- yet know the 'UnitId' for planned packages, because it's -- not the solver's job to compute them. -- -data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId } - | PlannedId { solverSrcId :: PackageId } +data SolverId = PreExistingId { solverStage :: Stage, solverSrcId :: PackageId, solverInstId :: UnitId } + | PlannedId { solverStage :: Stage, solverSrcId :: PackageId } deriving (Eq, Ord, Generic) instance Binary SolverId @@ -31,5 +34,5 @@ instance Package SolverId where packageId = solverSrcId instance Pretty SolverId where - pretty (PreExistingId pkg unitId) = pretty pkg <+> parens (pretty unitId) - pretty (PlannedId pkg) = pretty pkg \ No newline at end of file + pretty (PreExistingId stage pkg unitId) = mconcat $ punctuate colon $ [pretty stage, pretty pkg, text "installed", pretty unitId] + pretty (PlannedId stage pkg) = mconcat $ punctuate colon $ [pretty stage, pretty pkg, text "planned"] \ No newline at end of file diff --git a/cabal-install/src/Distribution/Client/Freeze.hs b/cabal-install/src/Distribution/Client/Freeze.hs index 868646b6080..7052515e8ce 100644 --- a/cabal-install/src/Distribution/Client/Freeze.hs +++ b/cabal-install/src/Distribution/Client/Freeze.hs @@ -51,7 +51,9 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb +import Distribution.Solver.Types.ResolverPackage (solverId) import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage (SolverPackage (..)) import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Client.Errors @@ -288,9 +290,15 @@ pruneInstallPlan installPlan pkgSpecifiers = removeSelf pkgIds $ SolverInstallPlan.dependencyClosure installPlan pkgIds where + -- Get the source packages from the (specific) package specifiers. + srcpkgs :: [UnresolvedSourcePackage] + srcpkgs = [pkg | SpecificSourcePackage pkg <- pkgSpecifiers] + -- Get the 'SolverId's of the packages we are freezing. + pkgIds :: [SolverId] pkgIds = - [ PlannedId (packageId pkg) - | SpecificSourcePackage pkg <- pkgSpecifiers + [ solverId (SolverInstallPlan.Configured pkg) + | SolverInstallPlan.Configured pkg <- SolverInstallPlan.toList installPlan + , solverPkgSource pkg `elem` srcpkgs ] removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg) removeSelf _ = diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index b929fc6c4e4..281908355df 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -569,8 +569,9 @@ fromSolverInstallPlanWithProgress f plan = do pkgs' <- f (mapDep pidMap ipiMap) pkg let (pidMap', ipiMap') = case nodeKey pkg of - PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) - PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) + -- FIXME: stage is ignored + PreExistingId _stage _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) + PlannedId _stage pid -> (Map.insert pid pkgs' pidMap, ipiMap) return (pidMap', ipiMap', pkgs' ++ pkgs) -- The error below shouldn't happen, since mapDep should only @@ -578,10 +579,10 @@ fromSolverInstallPlanWithProgress f plan = do -- already by the reverse top-sort (we assume the graph is not broken). -- -- FIXME: stage is ignored - mapDep _ ipiMap (PreExistingId _pid uid) + mapDep _ ipiMap (PreExistingId _stage _pid uid) | Just pkgs <- Map.lookup uid ipiMap = pkgs | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) - mapDep pidMap _ (PlannedId pid) + mapDep pidMap _ (PlannedId _stage pid) | Just pkgs <- Map.lookup pid pidMap = pkgs | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index c391608a532..b5b017dc07e 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -2485,11 +2485,12 @@ elaborateInstallPlan pkgsToBuildInplaceOnly :: Set PackageId pkgsToBuildInplaceOnly = - Set.fromList $ - map packageId $ - SolverInstallPlan.reverseDependencyClosure - solverPlan - (map PlannedId (Set.toList pkgsLocalToProject)) + Set.fromList + [ packageId pkg + | stage <- stages + , let solverIds = [PlannedId stage pkgId | pkgId <- Set.toList pkgsLocalToProject] + , pkg <- SolverInstallPlan.reverseDependencyClosure solverPlan solverIds + ] isLocalToProject :: Package pkg => pkg -> Bool isLocalToProject pkg = From 4d1fc99a5c1e3505158733056411c8429e018117 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 1 May 2025 11:15:24 +0800 Subject: [PATCH 20/54] fix(cabal-install): rewrite dependencyInconsistencies --- .../Distribution/Client/SolverInstallPlan.hs | 36 +++++++++---------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs index a53108f4128..6bb250176ba 100644 --- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs +++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs @@ -56,11 +56,7 @@ import Prelude () import Distribution.Package ( HasUnitId (..) , Package (..) - , PackageId , PackageIdentifier (..) - , PackageName - , packageName - , packageVersion ) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Types.Flag (nullFlagAssignment) @@ -68,10 +64,8 @@ import Distribution.Types.Flag (nullFlagAssignment) import Distribution.Client.Types ( UnresolvedPkgLoc ) -import Distribution.Version - ( Version - ) +import Distribution.Solver.Types.PackagePath (QPN) import Distribution.Solver.Types.ResolverPackage import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId @@ -185,7 +179,7 @@ data SolverPlanProblem SolverPlanPackage [PackageIdentifier] | PackageCycle [SolverPlanPackage] - | PackageInconsistency PackageName [(PackageIdentifier, Version)] + | PackageInconsistency QPN [(SolverId, SolverId)] | PackageStateInvalid SolverPlanPackage SolverPlanPackage showPlanProblem :: SolverPlanProblem -> String @@ -206,7 +200,7 @@ showPlanProblem (PackageInconsistency name inconsistencies) = [ " package " ++ prettyShow pkg ++ " requires " - ++ prettyShow (PackageIdentifier name ver) + ++ prettyShow ver | (pkg, ver) <- inconsistencies ] showPlanProblem (PackageStateInvalid pkg pkg') = @@ -230,7 +224,7 @@ problems :: IndependentGoals -> SolverPlanIndex -> [SolverPlanProblem] -problems indepGoals index = +problems _indepGoals index = [ PackageMissingDeps pkg ( mapMaybe @@ -263,10 +257,9 @@ problems indepGoals index = -- cycle. Such cycles may or may not be an issue; either way, we don't check -- for them here. dependencyInconsistencies - :: IndependentGoals - -> SolverPlanIndex - -> [(PackageName, [(PackageIdentifier, Version)])] -dependencyInconsistencies indepGoals index = + :: SolverPlanIndex + -> [(QPN, [(SolverId, SolverId)])] +dependencyInconsistencies index = concatMap dependencyInconsistencies' subplans where subplans :: [SolverPlanIndex] @@ -323,6 +316,8 @@ rootSets (IndependentGoals indepGoals) index = -- -- The library roots are the set of packages with no reverse dependencies -- (no reverse library dependencies but also no reverse setup dependencies). +-- +-- FIXME: misleading name, this includes executables too! libraryRoots :: SolverPlanIndex -> [SolverId] libraryRoots index = map (nodeKey . toPkgId) roots @@ -350,9 +345,14 @@ setupRoots = -- distinct. dependencyInconsistencies' :: SolverPlanIndex - -> [(PackageName, [(PackageIdentifier, Version)])] + -> [(QPN, [(SolverId, SolverId)])] dependencyInconsistencies' index = - [ (name, [(pid, packageVersion dep) | (dep, pids) <- uses, pid <- pids]) + [ ( name + , [ (sid, solverId dep) + | (dep, sids) <- uses + , sid <- sids + ] + ) | (name, ipid_map) <- Map.toList inverseIndex , let uses = Map.elems ipid_map , reallyIsInconsistent (map fst uses) @@ -362,11 +362,11 @@ dependencyInconsistencies' index = -- and each installed ID of that package -- the associated package instance -- and a list of reverse dependencies (as source IDs) - inverseIndex :: Map PackageName (Map SolverId (SolverPlanPackage, [PackageId])) + inverseIndex :: Map QPN (Map SolverId (SolverPlanPackage, [SolverId])) inverseIndex = Map.fromListWith (Map.unionWith (\(a, b) (_, b') -> (a, b ++ b'))) - [ (packageName dep, Map.fromList [(sid, (dep, [packageId pkg]))]) + [ (solverQPN dep, Map.fromList [(sid, (dep, [solverId pkg]))]) | -- For each package @pkg@ pkg <- Foldable.toList index , -- Find out which @sid@ @pkg@ depends on From 567218b6c06baf96dc6e10e32b7c7bcf53418278 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 23 Jun 2025 17:59:22 +0800 Subject: [PATCH 21/54] refactor(cabal-install-solver): refactor modularResolver --- .../src/Distribution/Solver/Modular.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index 5d80036d0ec..5e9f75006f3 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs @@ -22,7 +22,7 @@ import Distribution.Compat.Graph import Distribution.Compiler ( CompilerInfo ) import Distribution.Solver.Modular.Assignment - ( Assignment, toCPs ) + ( Assignment(..), toCPs ) import Distribution.Solver.Modular.ConfiguredConversion ( convCP ) import qualified Distribution.Solver.Modular.ConflictSet as CS @@ -81,7 +81,12 @@ import Distribution.Verbosity ( normal, verbose ) -- solver. Performs the necessary translations before and after. modularResolver :: SolverConfig -> DependencyResolver loc modularResolver sc toolchains pkgConfigDbs iidx sidx pprefs pcs pns = do - uncurry postprocess <$> solve' sc cinfo pkgConfigDbs idx pprefs gcs pns + (assignment, revdepmap) <- solve' sc cinfo pkgConfigDbs idx pprefs gcs pns + + -- Results have to be converted into an install plan. 'convCP' removes + -- package qualifiers, which means that linked packages become duplicates + -- and can be removed. + return $ ordNubBy nodeKey $ map (convCP iidx sidx) (toCPs assignment revdepmap) where cinfo = fst <$> toolchains @@ -92,12 +97,6 @@ modularResolver sc toolchains pkgConfigDbs iidx sidx pprefs pcs pns = do where pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc]) - -- Results have to be converted into an install plan. 'convCP' removes - -- package qualifiers, which means that linked packages become duplicates - -- and can be removed. - postprocess a rdm = ordNubBy nodeKey $ - map (convCP iidx sidx) (toCPs a rdm) - -- Helper function to extract the PN from a constraint. pcName :: PackageConstraint -> PN pcName (PackageConstraint scope _) = scopeToPackageName scope From 0f65e873378ea3807355e9bbb3582accc305fbb3 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 7 Aug 2025 12:23:15 +0800 Subject: [PATCH 22/54] refactor(cabal-install): generalise GenericInstallPlan to arbitrary node keys --- Cabal/src/Distribution/Utils/LogProgress.hs | 1 + .../src/Distribution/Client/InstallPlan.hs | 246 +++++++++++------- .../Distribution/Client/ProjectBuilding.hs | 21 +- .../Client/ProjectOrchestration.hs | 5 +- .../Client/ProjectPlanning/Types.hs | 4 +- .../Distribution/Client/InstallPlan.hs | 14 +- 6 files changed, 180 insertions(+), 111 deletions(-) diff --git a/Cabal/src/Distribution/Utils/LogProgress.hs b/Cabal/src/Distribution/Utils/LogProgress.hs index f010a4c9913..ba55cdab294 100644 --- a/Cabal/src/Distribution/Utils/LogProgress.hs +++ b/Cabal/src/Distribution/Utils/LogProgress.hs @@ -9,6 +9,7 @@ module Distribution.Utils.LogProgress , infoProgress , dieProgress , addProgressCtx + , ErrMsg ) where import Distribution.Compat.Prelude diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index 281908355df..d2942bf6b5d 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -1,7 +1,10 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -25,7 +28,6 @@ module Distribution.Client.InstallPlan , PlanPackage , GenericPlanPackage (..) , foldPlanPackage - , IsUnit -- * Operations on 'InstallPlan's , new @@ -70,6 +72,7 @@ module Distribution.Client.InstallPlan , dependencyClosure , reverseTopologicalOrder , reverseDependencyClosure + , IsGraph (..) ) where import Distribution.Client.Compat.Prelude hiding (lookup, toList) @@ -91,7 +94,6 @@ import Distribution.Package ( HasMungedPackageId (..) , HasUnitId (..) , Package (..) - , UnitId ) import Distribution.Pretty (defaultStyle) import Distribution.Solver.Types.SolverPackage @@ -111,11 +113,15 @@ import Distribution.Utils.Structured (Structure (Nominal), Structured (..)) import Control.Exception ( assert ) +import Data.Bifoldable +import Data.Bifunctor +import Data.Bitraversable import qualified Data.Foldable as Foldable (all, toList) import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Compat.Graph (Graph, IsNode (..)) import qualified Distribution.Compat.Graph as Graph +import GHC.Stack -- When cabal tries to install a number of packages, including all their -- dependencies it has a non-trivial problem to solve. @@ -174,38 +180,33 @@ data GenericPlanPackage ipkg srcpkg = PreExisting ipkg | Configured srcpkg | Installed srcpkg - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Traversable, Foldable, Functor) -displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String -displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg) -displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg) -displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg) +instance Bifunctor GenericPlanPackage where + bimap f _ (PreExisting ipkg) = PreExisting (f ipkg) + bimap _ g (Configured srcpkg) = Configured (g srcpkg) + bimap _ g (Installed srcpkg) = Installed (g srcpkg) --- | Convenience combinator for destructing 'GenericPlanPackage'. --- This is handy because if you case manually, you have to handle --- 'Configured' and 'Installed' separately (where often you want --- them to be the same.) -foldPlanPackage - :: (ipkg -> a) - -> (srcpkg -> a) - -> GenericPlanPackage ipkg srcpkg - -> a -foldPlanPackage f _ (PreExisting ipkg) = f ipkg -foldPlanPackage _ g (Configured srcpkg) = g srcpkg -foldPlanPackage _ g (Installed srcpkg) = g srcpkg +instance Bifoldable GenericPlanPackage where + bifoldMap f _ (PreExisting ipkg) = f ipkg + bifoldMap _ g (Configured srcpkg) = g srcpkg + bifoldMap _ g (Installed srcpkg) = g srcpkg -type IsUnit a = (IsNode a, Key a ~ UnitId) +instance Bitraversable GenericPlanPackage where + bitraverse f _ (PreExisting ipkg) = PreExisting <$> f ipkg + bitraverse _ g (Configured srcpkg) = Configured <$> g srcpkg + bitraverse _ g (Installed srcpkg) = Installed <$> g srcpkg -depends :: IsUnit a => a -> [UnitId] -depends = nodeNeighbors +-- I admit this is a bit awkward but I could not find a better way. --- NB: Expanded constraint synonym here to avoid undecidable --- instance errors in GHC 7.8 and earlier. -instance - (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId) - => IsNode (GenericPlanPackage ipkg srcpkg) - where - type Key (GenericPlanPackage ipkg srcpkg) = UnitId +class (IsNode a, IsNode b, Key a ~ Key b) => IsGraph a b where + type GraphKey a b + +instance (IsNode a, Key a ~ key, IsNode b, Key b ~ key) => IsGraph a b where + type GraphKey a b = Key a + +instance IsGraph ipkg srcpkg => IsNode (GenericPlanPackage ipkg srcpkg) where + type Key (GenericPlanPackage ipkg srcpkg) = GraphKey ipkg srcpkg nodeKey (PreExisting ipkg) = nodeKey ipkg nodeKey (Configured spkg) = nodeKey spkg nodeKey (Installed spkg) = nodeKey spkg @@ -216,11 +217,6 @@ instance instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg) instance (Structured ipkg, Structured srcpkg) => Structured (GenericPlanPackage ipkg srcpkg) -type PlanPackage = - GenericPlanPackage - InstalledPackageInfo - (ConfiguredPackage UnresolvedPkgLoc) - instance (Package ipkg, Package srcpkg) => Package (GenericPlanPackage ipkg srcpkg) @@ -254,11 +250,39 @@ instance configuredId (Configured spkg) = configuredId spkg configuredId (Installed spkg) = configuredId spkg -data GenericInstallPlan ipkg srcpkg = GenericInstallPlan +displayGenericPlanPackage :: (IsNode ipkg, Key ipkg ~ key, IsNode srcpkg, Key srcpkg ~ key, Pretty key) => GenericPlanPackage ipkg srcpkg -> String +displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg) +displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg) +displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg) + +-- | Convenience combinator for destructing 'GenericPlanPackage'. +-- This is handy because if you case manually, you have to handle +-- 'Configured' and 'Installed' separately (where often you want +-- them to be the same.) +foldPlanPackage + :: (ipkg -> a) + -> (srcpkg -> a) + -> GenericPlanPackage ipkg srcpkg + -> a +foldPlanPackage f _ (PreExisting ipkg) = f ipkg +foldPlanPackage _ g (Configured srcpkg) = g srcpkg +foldPlanPackage _ g (Installed srcpkg) = g srcpkg + +depends :: IsNode a => a -> [Key a] +depends = nodeNeighbors + +type PlanPackage = + GenericPlanPackage + InstalledPackageInfo + (ConfiguredPackage UnresolvedPkgLoc) + +data GenericInstallPlan' key ipkg srcpkg = GenericInstallPlan { planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)) , planIndepGoals :: !IndependentGoals } +type GenericInstallPlan ipkg srcpkg = GenericInstallPlan' (GraphKey ipkg srcpkg) ipkg srcpkg + -- | 'GenericInstallPlan' specialised to most commonly used types. type InstallPlan = GenericInstallPlan @@ -267,7 +291,9 @@ type InstallPlan = -- | Smart constructor that deals with caching the 'Graph' representation. mkInstallPlan - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) => String -> Graph (GenericPlanPackage ipkg srcpkg) -> IndependentGoals @@ -287,7 +313,10 @@ internalError loc msg = ++ loc ++ if null msg then "" else ": " ++ msg -instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where +instance + (Typeable key, Structured ipkg, Structured srcpkg) + => Structured (GenericInstallPlan' key ipkg srcpkg) + where structure p = Nominal (typeRep p) @@ -298,14 +327,14 @@ instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ] instance - ( IsNode ipkg - , Key ipkg ~ UnitId - , IsNode srcpkg - , Key srcpkg ~ UnitId + ( IsGraph ipkg srcpkg + , key ~ GraphKey ipkg srcpkg , Binary ipkg , Binary srcpkg + , Pretty key + , Show key ) - => Binary (GenericInstallPlan ipkg srcpkg) + => Binary (GenericInstallPlan' key ipkg srcpkg) where put GenericInstallPlan @@ -341,7 +370,11 @@ showInstallPlan_gen toShow = showPlanGraph . fmap toShow . Foldable.toList . pla showInstallPlan :: forall ipkg srcpkg - . (Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) + . ( IsGraph ipkg srcpkg + , Package ipkg + , Package srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) => GenericInstallPlan ipkg srcpkg -> String showInstallPlan = showInstallPlan_gen toShow @@ -364,9 +397,10 @@ showPlanPackageTag (Installed _) = "Installed" -- | Build an installation plan from a valid set of resolved packages. new - :: (IsUnit ipkg, IsUnit srcpkg) - => IndependentGoals - -> Graph (GenericPlanPackage ipkg srcpkg) + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) + => Graph (GenericPlanPackage ipkg srcpkg) -> GenericInstallPlan ipkg srcpkg new indepGoals graph = mkInstallPlan "new" graph indepGoals @@ -382,13 +416,13 @@ toList = Foldable.toList . planGraph toMap :: GenericInstallPlan ipkg srcpkg - -> Map UnitId (GenericPlanPackage ipkg srcpkg) + -> Map (Key ipkg) (GenericPlanPackage ipkg srcpkg) toMap = Graph.toMap . planGraph -keys :: GenericInstallPlan ipkg srcpkg -> [UnitId] +keys :: GenericInstallPlan ipkg srcpkg -> [Key ipkg] keys = Graph.keys . planGraph -keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId +keysSet :: GenericInstallPlan ipkg srcpkg -> Set (Key ipkg) keysSet = Graph.keysSet . planGraph -- | Remove packages from the install plan. This will result in an @@ -397,7 +431,10 @@ keysSet = Graph.keysSet . planGraph -- the dependencies of a package or set of packages without actually -- installing the package itself, as when doing development. remove - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + , Show (GraphKey ipkg srcpkg) + ) => (GenericPlanPackage ipkg srcpkg -> Bool) -> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg @@ -414,7 +451,7 @@ remove shouldRemove plan = -- To preserve invariants, the package must have all of its dependencies -- already installed too (that is 'PreExisting' or 'Installed'). installed - :: (IsUnit ipkg, IsUnit srcpkg) + :: IsGraph ipkg srcpkg => (srcpkg -> Bool) -> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg @@ -439,7 +476,7 @@ installed shouldBeInstalled installPlan = -- To preserve invariants, the package must have all of its dependencies -- already installed too (that is 'PreExisting' or 'Installed'). installedM - :: (IsUnit ipkg, IsUnit srcpkg, Monad m) + :: (IsGraph ipkg srcpkg, Monad m) => (srcpkg -> m Bool) -> GenericInstallPlan ipkg srcpkg -> m (GenericInstallPlan ipkg srcpkg) @@ -455,9 +492,9 @@ installedM shouldBeInstalled installPlan = do -- | Lookup a package in the plan. lookup - :: (IsUnit ipkg, IsUnit srcpkg) + :: IsGraph ipkg srcpkg => GenericInstallPlan ipkg srcpkg - -> UnitId + -> GraphKey ipkg srcpkg -> Maybe (GenericPlanPackage ipkg srcpkg) lookup plan pkgid = Graph.lookup pkgid (planGraph plan) @@ -466,7 +503,7 @@ lookup plan pkgid = Graph.lookup pkgid (planGraph plan) -- Note that the package must exist in the plan or it is an error. directDeps :: GenericInstallPlan ipkg srcpkg - -> UnitId + -> GraphKey ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg] directDeps plan pkgid = case Graph.neighbors (planGraph plan) pkgid of @@ -478,7 +515,7 @@ directDeps plan pkgid = -- Note that the package must exist in the plan or it is an error. revDirectDeps :: GenericInstallPlan ipkg srcpkg - -> UnitId + -> GraphKey ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg] revDirectDeps plan pkgid = case Graph.revNeighbors (planGraph plan) pkgid of @@ -501,7 +538,7 @@ reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan) -- the given packages. dependencyClosure :: GenericInstallPlan ipkg srcpkg - -> [UnitId] + -> [GraphKey ipkg srcpkg] -> [GenericPlanPackage ipkg srcpkg] dependencyClosure plan = fromMaybe [] @@ -511,7 +548,7 @@ dependencyClosure plan = -- given packages. reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg - -> [UnitId] + -> [GraphKey ipkg srcpkg] -> [GenericPlanPackage ipkg srcpkg] reverseDependencyClosure plan = fromMaybe [] @@ -531,7 +568,11 @@ reverseDependencyClosure plan = -- because that's not enough information. fromSolverInstallPlan - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( HasCallStack + , IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + , Show (GraphKey ipkg srcpkg) + ) => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) -> SolverInstallPlan.SolverPlanPackage -> [GenericPlanPackage ipkg srcpkg] @@ -546,7 +587,10 @@ fromSolverInstallPlan f plan = plan fromSolverInstallPlanWithProgress - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + , Show (GraphKey ipkg srcpkg) + ) => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) -> SolverInstallPlan.SolverPlanPackage -> LogProgress [GenericPlanPackage ipkg srcpkg] @@ -670,7 +714,7 @@ configureInstallPlan configFlags solverPlan = -- and includes the set of packages that are in the processing state, e.g. in -- the process of being installed, plus those that have been completed and -- those where processing failed. -data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId) +data Processing key = Processing !(Set key) !(Set key) !(Set key) -- processing, completed, failed @@ -683,9 +727,13 @@ data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId) -- all the packages that are ready will now be processed and so we can consider -- them to be in the processing state. ready - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsNode ipkg + , Key ipkg ~ key + , IsNode srcpkg + , Key srcpkg ~ key + ) => GenericInstallPlan ipkg srcpkg - -> ([GenericReadyPackage srcpkg], Processing) + -> ([GenericReadyPackage srcpkg], Processing key) ready plan = assert (processingInvariant plan processing) (readyPackages, processing) where @@ -710,11 +758,11 @@ isInstalled _ = False -- process), along with the updated 'Processing' state. completed :: forall ipkg srcpkg - . (IsUnit ipkg, IsUnit srcpkg) + . (IsGraph ipkg srcpkg, Ord (GraphKey ipkg srcpkg), Pretty (GraphKey ipkg srcpkg)) => GenericInstallPlan ipkg srcpkg - -> Processing - -> UnitId - -> ([GenericReadyPackage srcpkg], Processing) + -> Processing (GraphKey ipkg srcpkg) + -> (GraphKey ipkg srcpkg) + -> ([GenericReadyPackage srcpkg], Processing (GraphKey ipkg srcpkg)) completed plan (Processing processingSet completedSet failedSet) pkgid = assert (pkgid `Set.member` processingSet) $ assert @@ -746,11 +794,11 @@ completed plan (Processing processingSet completedSet failedSet) pkgid = asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg failed - :: (IsUnit ipkg, IsUnit srcpkg) + :: (IsGraph ipkg srcpkg, Pretty (GraphKey ipkg srcpkg)) => GenericInstallPlan ipkg srcpkg - -> Processing - -> UnitId - -> ([srcpkg], Processing) + -> Processing (GraphKey ipkg srcpkg) + -> GraphKey ipkg srcpkg + -> ([srcpkg], Processing (GraphKey ipkg srcpkg)) failed plan (Processing processingSet completedSet failedSet) pkgid = assert (pkgid `Set.member` processingSet) $ assert (all (`Set.notMember` processingSet) (drop 1 newlyFailedIds)) $ @@ -776,9 +824,13 @@ failed plan (Processing processingSet completedSet failedSet) pkgid = asConfiguredPackage pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg processingInvariant - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsNode ipkg + , Key ipkg ~ key + , IsNode srcpkg + , Key srcpkg ~ key + ) => GenericInstallPlan ipkg srcpkg - -> Processing + -> Processing key -> Bool processingInvariant plan (Processing processingSet completedSet failedSet) = -- All the packages in the three sets are actually in the graph @@ -857,7 +909,7 @@ processingInvariant plan (Processing processingSet completedSet failedSet) = -- source packages in the dependency graph, albeit not necessarily exactly the -- same ordering as that produced by 'reverseTopologicalOrder'. executionOrder - :: (IsUnit ipkg, IsUnit srcpkg) + :: (IsGraph ipkg srcpkg, Pretty (GraphKey ipkg srcpkg)) => GenericInstallPlan ipkg srcpkg -> [GenericReadyPackage srcpkg] executionOrder plan = @@ -879,15 +931,15 @@ executionOrder plan = -- ------------------------------------------------------------ -- | The set of results we get from executing an install plan. -type BuildOutcomes failure result = Map UnitId (Either failure result) +type BuildOutcomes key failure result = Map key (Either failure result) -- | Lookup the build result for a single package. lookupBuildOutcome - :: HasUnitId pkg + :: (IsNode pkg, Key pkg ~ key) => pkg - -> BuildOutcomes failure result + -> BuildOutcomes key failure result -> Maybe (Either failure result) -lookupBuildOutcome = Map.lookup . installedUnitId +lookupBuildOutcome = Map.lookup . nodeKey -- | Execute an install plan. This traverses the plan in dependency order. -- @@ -905,29 +957,30 @@ lookupBuildOutcome = Map.lookup . installedUnitId -- these will have no 'BuildOutcome'. execute :: forall m ipkg srcpkg result failure - . ( IsUnit ipkg - , IsUnit srcpkg + . ( IsGraph ipkg srcpkg , Monad m + , Pretty (Key srcpkg) ) - => JobControl m (UnitId, Either failure result) + => JobControl m (GraphKey ipkg srcpkg, Either failure result) -> Bool -- ^ Keep going after failure -> (srcpkg -> failure) -- ^ Value for dependents of failed packages -> GenericInstallPlan ipkg srcpkg -> (GenericReadyPackage srcpkg -> m (Either failure result)) - -> m (BuildOutcomes failure result) + -> m (BuildOutcomes (GraphKey ipkg srcpkg) failure result) execute jobCtl keepGoing depFailure plan installPkg = let (newpkgs, processing) = ready plan - in tryNewTasks Map.empty False False processing newpkgs + in tryNewTasks mempty False False processing newpkgs where tryNewTasks - :: BuildOutcomes failure result + :: (Pretty key, Key srcpkg ~ key) + => BuildOutcomes key failure result -> Bool -> Bool - -> Processing + -> Processing key -> [GenericReadyPackage srcpkg] - -> m (BuildOutcomes failure result) + -> m (BuildOutcomes key failure result) tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs -- we were in the process of cancelling and now we're finished @@ -954,11 +1007,12 @@ execute jobCtl keepGoing depFailure plan installPkg = waitForTasks results tasksFailed processing waitForTasks - :: BuildOutcomes failure result + :: (Pretty key, Key srcpkg ~ key) + => BuildOutcomes key failure result -> Bool - -> Processing - -> m (BuildOutcomes failure result) - waitForTasks !results tasksFailed !processing = do + -> Processing key + -> m (BuildOutcomes key failure result) + waitForTasks results tasksFailed !processing = do (pkgid, result) <- collectJob jobCtl case result of @@ -1001,7 +1055,9 @@ execute jobCtl keepGoing depFailure plan installPkg = -- -- * if the result is @False@ use 'problems' to get a detailed list. valid - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) => String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool @@ -1011,14 +1067,16 @@ valid loc graph = ps -> internalError loc ('\n' : unlines (map showPlanProblem ps)) data PlanProblem ipkg srcpkg - = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId] + = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [GraphKey ipkg srcpkg] | PackageCycle [GenericPlanPackage ipkg srcpkg] | PackageStateInvalid (GenericPlanPackage ipkg srcpkg) (GenericPlanPackage ipkg srcpkg) showPlanProblem - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) => PlanProblem ipkg srcpkg -> String showPlanProblem (PackageMissingDeps pkg missingDeps) = @@ -1044,7 +1102,7 @@ showPlanProblem (PackageStateInvalid pkg pkg') = -- error messages. This is mainly intended for debugging purposes. -- Use 'showPlanProblem' for a human readable explanation. problems - :: (IsUnit ipkg, IsUnit srcpkg) + :: IsGraph ipkg srcpkg => Graph (GenericPlanPackage ipkg srcpkg) -> [PlanProblem ipkg srcpkg] problems graph = diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 2632ded2d06..720bf74589a 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -58,7 +58,6 @@ import Distribution.Client.GlobalFlags (RepoContext) import Distribution.Client.InstallPlan ( GenericInstallPlan , GenericPlanPackage - , IsUnit ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.JobControl @@ -259,21 +258,26 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = -- visiting function is passed the results for all the immediate package -- dependencies. This can be used to propagate information from dependencies. foldMInstallPlanDepOrder - :: forall m ipkg srcpkg b - . (Monad m, IsUnit ipkg, IsUnit srcpkg) + :: forall m ipkg srcpkg b key + . ( Monad m + , IsNode ipkg + , Key ipkg ~ key + , IsNode srcpkg + , Key srcpkg ~ key + ) => ( GenericPlanPackage ipkg srcpkg -> [b] -> m b ) -> GenericInstallPlan ipkg srcpkg - -> m (Map UnitId b) + -> m (Map key b) foldMInstallPlanDepOrder visit = go Map.empty . InstallPlan.reverseTopologicalOrder where go - :: Map UnitId b + :: Map key b -> [GenericPlanPackage ipkg srcpkg] - -> m (Map UnitId b) + -> m (Map key b) go !results [] = return results go !results (pkg : pkgs) = do -- we go in the right order so the results map has entries for all deps @@ -298,7 +302,7 @@ improveInstallPlanWithUpToDatePackages pkgsBuildStatus = where canPackageBeImproved :: ElaboratedConfiguredPackage -> Bool canPackageBeImproved pkg = - case Map.lookup (installedUnitId pkg) pkgsBuildStatus of + case Map.lookup (nodeKey pkg) pkgsBuildStatus of Just BuildStatusUpToDate{} -> True Just _ -> False Nothing -> @@ -384,8 +388,7 @@ rebuildTargets $ \pkg -> -- TODO: review exception handling handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ do - let uid = installedUnitId pkg - pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus + let pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") (nodeKey pkg) pkgsBuildStatus rebuildTarget verbosity diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 0879be00630..19a7055afde 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -108,6 +108,7 @@ import Distribution.Client.Compat.Prelude import System.Directory ( makeAbsolute ) +import qualified Distribution.Compat.Graph as Graph import Prelude () import Distribution.Client.ProjectBuilding @@ -1446,7 +1447,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes case reason of DownloadFailed _ -> "Failed to download " ++ pkgstr UnpackFailed _ -> "Failed to unpack " ++ pkgstr - ConfigureFailed _ -> "Failed to build " ++ pkgstr + ConfigureFailed _ -> "Failed to configure " ++ pkgstr BuildFailed _ -> "Failed to build " ++ pkgstr ReplFailed _ -> "repl failed for " ++ pkgstr HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr @@ -1456,7 +1457,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes GracefulFailure msg -> msg DependentFailed depid -> "Failed to build " - ++ prettyShow (packageId pkg) + ++ prettyShow (Graph.nodeKey pkg) ++ " because it depends on " ++ prettyShow depid ++ " which itself failed to build" diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 2678b054c42..606db4b0a64 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -131,7 +131,7 @@ import Data.Foldable (fold) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Monoid as Mon -import Distribution.Verbosity +import qualified Distribution.Compat.Graph as Graph import System.FilePath (()) import Text.PrettyPrint (hsep, parens, text) @@ -534,7 +534,7 @@ elabConfiguredName verbosity elab Just (CLibName LMainLibName) -> "" Just cname -> prettyShow cname ++ " from " ) - ++ prettyShow (packageId elab) + ++ prettyShow (Graph.nodeKey elab) | otherwise = prettyShow (elabUnitId elab) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs index e9fce74c5fe..4088eafb9ad 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-} @@ -7,7 +8,7 @@ module UnitTests.Distribution.Client.InstallPlan (tests) where import Distribution.Client.Compat.Prelude -import Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit) +import Distribution.Client.InstallPlan (GenericInstallPlan) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.JobControl import Distribution.Client.Types @@ -225,8 +226,13 @@ arbitraryTestInstallPlan = do -- It takes generators for installed and source packages and the chance that -- each package is installed (for those packages with no prerequisites). arbitraryInstallPlan - :: ( IsUnit ipkg - , IsUnit srcpkg + :: forall ipkg srcpkg key + . ( IsNode ipkg + , Key ipkg ~ key + , IsNode srcpkg + , Key srcpkg ~ key + , Show key + , Pretty key ) => (Vertex -> [Vertex] -> Gen ipkg) -> (Vertex -> [Vertex] -> Gen srcpkg) From b809870c11dd083d9d3c1efd792e722e8c246e3b Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 6 May 2025 15:01:33 +0800 Subject: [PATCH 23/54] chore(Cabal): update reference to backpack-include field, now called mixin --- Cabal/src/Distribution/Backpack/ConfiguredComponent.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs index 9fd78352b7c..93da4de37c3 100644 --- a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs +++ b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs @@ -94,7 +94,7 @@ dispConfiguredComponent cc = -- | Construct a 'ConfiguredComponent', given that the 'ComponentId' -- and library/executable dependencies are known. The primary --- work this does is handling implicit @backpack-include@ fields. +-- work this does is handling implicit @mixin@ fields. mkConfiguredComponent :: PackageDescription -> ComponentId @@ -121,7 +121,7 @@ mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do } -- Any @build-depends@ which is not explicitly mentioned in - -- @backpack-include@ is converted into an "implicit" include. + -- @mixin@ is converted into an "implicit" include. let used_explicitly = Set.fromList (map ci_id explicit_includes) implicit_includes = map From 2fd55fa2c635eb6c5bedf87ddab3a9824d7c0383 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 25 Jun 2025 16:41:51 +0800 Subject: [PATCH 24/54] feat: add a bunch of HasCallStack --- Cabal-syntax/src/Distribution/Compat/Graph.hs | 3 ++- .../Distribution/Backpack/ComponentsGraph.hs | 4 +++- Cabal/src/Distribution/Backpack/Configure.hs | 11 +++++++---- Cabal/src/Distribution/Simple/Configure.hs | 4 +++- .../src/Distribution/Types/LocalBuildInfo.hs | 3 ++- .../src/Distribution/Solver/Modular/Cycles.hs | 5 +++-- .../src/Distribution/Client/Dependency.hs | 4 +++- .../Distribution/Client/ProjectPlanOutput.hs | 6 ++++-- .../Distribution/Client/ProjectPlanning.hs | 19 +++++++++++++------ .../Distribution/Client/SolverInstallPlan.hs | 4 +++- 10 files changed, 43 insertions(+), 20 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Compat/Graph.hs b/Cabal-syntax/src/Distribution/Compat/Graph.hs index ea37af99a77..0873fbbb1f4 100644 --- a/Cabal-syntax/src/Distribution/Compat/Graph.hs +++ b/Cabal-syntax/src/Distribution/Compat/Graph.hs @@ -104,6 +104,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Tree as Tree import qualified Distribution.Compat.Prelude as Prelude +import GHC.Stack (HasCallStack) -- | A graph of nodes @a@. The nodes are expected to have instance -- of class 'IsNode'. @@ -377,7 +378,7 @@ fromMap m = bounds = (0, Map.size m - 1) -- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph. -fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a +fromDistinctList :: HasCallStack => (IsNode a, Show (Key a)) => [a] -> Graph a fromDistinctList = fromMap . Map.fromListWith (\_ -> duplicateError) diff --git a/Cabal/src/Distribution/Backpack/ComponentsGraph.hs b/Cabal/src/Distribution/Backpack/ComponentsGraph.hs index aef3db817c6..6ce25d2a323 100644 --- a/Cabal/src/Distribution/Backpack/ComponentsGraph.hs +++ b/Cabal/src/Distribution/Backpack/ComponentsGraph.hs @@ -22,6 +22,7 @@ import Distribution.Types.ComponentRequestedSpec import Distribution.Utils.Generic import Distribution.Pretty (pretty) +import GHC.Stack (HasCallStack) import Text.PrettyPrint ------------------------------------------------------------------------------ @@ -50,7 +51,8 @@ dispComponentsWithDeps graph = -- | Create a 'Graph' of 'Component', or report a cycle if there is a -- problem. mkComponentsGraph - :: ComponentRequestedSpec + :: HasCallStack + => ComponentRequestedSpec -> PackageDescription -> Either [ComponentName] ComponentsGraph mkComponentsGraph enabled pkg_descr = diff --git a/Cabal/src/Distribution/Backpack/Configure.hs b/Cabal/src/Distribution/Backpack/Configure.hs index 55d1ae03254..aec217ebd22 100644 --- a/Cabal/src/Distribution/Backpack/Configure.hs +++ b/Cabal/src/Distribution/Backpack/Configure.hs @@ -54,6 +54,7 @@ import Data.Either import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Pretty +import GHC.Stack (HasCallStack) import Text.PrettyPrint ------------------------------------------------------------------------------ @@ -61,7 +62,8 @@ import Text.PrettyPrint ------------------------------------------------------------------------------ configureComponentLocalBuildInfos - :: Verbosity + :: HasCallStack + => Verbosity -> Bool -- use_external_internal_deps -> ComponentRequestedSpec -> Bool -- deterministic @@ -206,7 +208,8 @@ configureComponentLocalBuildInfos ------------------------------------------------------------------------------ toComponentLocalBuildInfos - :: Compiler + :: HasCallStack + => Compiler -> InstalledPackageIndex -- FULL set -> [ConfiguredPromisedComponent] -> PackageDescription @@ -232,12 +235,12 @@ toComponentLocalBuildInfos -- since we will pay for the ALL installed packages even if -- they are not related to what we are building. This was true -- in the old configure code. - external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + external_graph :: HasCallStack => Graph (Either InstalledPackageInfo ReadyComponent) external_graph = Graph.fromDistinctList . map Left $ PackageIndex.allPackages installedPackageSet - internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + internal_graph :: HasCallStack => Graph (Either InstalledPackageInfo ReadyComponent) internal_graph = Graph.fromDistinctList . map Right diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 79ab53f364a..a8a001f0727 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -196,6 +196,7 @@ import Text.PrettyPrint import qualified Data.Maybe as M import qualified Data.Set as Set import qualified Distribution.Compat.NonEmptySet as NES +import GHC.Stack (HasCallStack) type UseExternalInternalDeps = Bool @@ -1393,7 +1394,8 @@ finalCheckPackage CantFindForeignLibraries unsupportedFLibs configureComponents - :: VerbosityHandles + :: HasCallStack + => VerbosityHandles -> LBC.LocalBuildConfig -> LBC.PackageBuildDescr -> InstalledPackageIndex diff --git a/Cabal/src/Distribution/Types/LocalBuildInfo.hs b/Cabal/src/Distribution/Types/LocalBuildInfo.hs index f525d397aba..24ebebbbd6f 100644 --- a/Cabal/src/Distribution/Types/LocalBuildInfo.hs +++ b/Cabal/src/Distribution/Types/LocalBuildInfo.hs @@ -132,6 +132,7 @@ import qualified Data.Map as Map import Distribution.Compat.Graph (Graph) import qualified Distribution.Compat.Graph as Graph +import GHC.Stack (HasCallStack) import qualified System.FilePath as FilePath (takeDirectory) -- | Data cached after configuration step. See also @@ -417,7 +418,7 @@ withAllTargetsInBuildOrder' pkg_descr lbi f = -- the order they need to be built. -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. -neededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> [TargetInfo] +neededTargetsInBuildOrder' :: HasCallStack => PackageDescription -> LocalBuildInfo -> [UnitId] -> [TargetInfo] neededTargetsInBuildOrder' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) uids = case Graph.closure compsGraph uids of Nothing -> error $ "localBuildPlan: missing uids " ++ intercalate ", " (map prettyShow uids) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs index e156912133b..4ddf93a9a38 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs @@ -15,6 +15,7 @@ import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Types.ComponentDeps (Component) import Distribution.Solver.Types.PackagePath +import GHC.Stack (HasCallStack) -- | Find and reject any nodes with cyclic dependencies detectCyclesPhase :: Tree d c -> Tree d c @@ -51,7 +52,7 @@ detectCyclesPhase = go -- all decisions that could potentially break the cycle. -- -- TODO: The conflict set should also contain flag and stanza variables. -findCycles :: QPN -> RevDepMap -> Maybe ConflictSet +findCycles :: HasCallStack => QPN -> RevDepMap -> Maybe ConflictSet findCycles pkg rdm = -- This function has two parts: a faster cycle check that is called at every -- step and a slower calculation of the conflict set. @@ -115,6 +116,6 @@ instance G.IsNode RevDepMapNode where nodeKey (RevDepMapNode qpn _) = qpn nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns -revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode +revDepMapToGraph :: HasCallStack => RevDepMap -> G.Graph RevDepMapNode revDepMapToGraph rdm = G.fromDistinctList [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm] diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index eb7da76f2a7..ef3e53d45d7 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -174,6 +174,7 @@ import Data.List ) import qualified Data.Map as Map import qualified Data.Set as Set +import GHC.Stack (HasCallStack) import Text.PrettyPrint -- ------------------------------------------------------------ @@ -971,7 +972,8 @@ interpretPackagesPreference selected defaultPref prefs = -- | Make an install plan from the output of the dep resolver. -- It checks that the plan is valid, or it's an error in the dep resolver. validateSolverResult - :: Staged (CompilerInfo, Platform) + :: HasCallStack + => Staged (CompilerInfo, Platform) -> [ResolverPackage UnresolvedPkgLoc] -> SolverInstallPlan validateSolverResult toolchains pkgs = diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index 509fc583282..eabe1fbe2f6 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -77,6 +77,7 @@ import System.FilePath import System.IO import Distribution.Simple.Program.GHC (packageDbArgsDb) +import GHC.Stack (HasCallStack) ----------------------------------------------------------------------------- -- Writing plan.json files @@ -542,7 +543,8 @@ data PostBuildProjectStatus = PostBuildProjectStatus -- | Work out which packages are out of date or invalid after a build. postBuildProjectStatus - :: ElaboratedInstallPlan + :: HasCallStack + => ElaboratedInstallPlan -> PackagesUpToDate -> BuildStatusMap -> BuildOutcomes @@ -639,7 +641,7 @@ postBuildProjectStatus ) -- The plan graph but only counting dependency-on-library edges - packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) + packagesLibDepGraph :: HasCallStack => Graph (Node UnitId ElaboratedPlanPackage) packagesLibDepGraph = Graph.fromDistinctList [ Graph.N pkg (installedUnitId pkg) libdeps diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index b5b017dc07e..90ca67f435c 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -236,6 +236,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Client.Errors import Distribution.Solver.Types.ProjectConfigPath +import GHC.Stack (HasCallStack) import System.Directory (getCurrentDirectory) import System.FilePath import qualified Text.PrettyPrint as Disp @@ -1699,7 +1700,8 @@ elaborateInstallPlan -- NB: We don't INSTANTIATE packages at this point. That's -- a post-pass. This makes it simpler to compute dependencies. elaborateSolverToComponents - :: (SolverId -> [ElaboratedPlanPackage]) + :: HasCallStack + => (SolverId -> [ElaboratedPlanPackage]) -> SolverPackage UnresolvedPkgLoc -> LogProgress [ElaboratedConfiguredPackage] elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ _ _ deps0 exe_deps0) = @@ -1841,7 +1843,8 @@ elaborateInstallPlan ++ " not implemented yet" buildComponent - :: ( ConfiguredComponentMap + :: HasCallStack + => ( ConfiguredComponentMap , LinkedComponentMap , Map ComponentId FilePath ) @@ -2833,7 +2836,8 @@ extractElabBuildStyle _ = BuildAndInstall -- we don't instantiate the same thing multiple times. -- instantiateInstallPlan - :: StoreDirLayout + :: HasCallStack + => StoreDirLayout -> Staged InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan @@ -3364,7 +3368,8 @@ data TargetAction -- will prune differently depending on what is already installed (to -- implement "sticky" test suite enabling behavior). pruneInstallPlanToTargets - :: TargetAction + :: HasCallStack + => TargetAction -> Map UnitId [ComponentTarget] -> ElaboratedInstallPlan -> ElaboratedInstallPlan @@ -3460,7 +3465,8 @@ setRootTargets targetAction perPkgTargetsMap = -- are used only by unneeded optional stanzas. These pruned deps are only -- used for the dependency closure and are not persisted in this pass. pruneInstallPlanPass1 - :: [ElaboratedPlanPackage] + :: HasCallStack + => [ElaboratedPlanPackage] -> [ElaboratedPlanPackage] pruneInstallPlanPass1 pkgs -- if there are repl targets, we need to do a bit more work @@ -3820,7 +3826,8 @@ mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = -- -- This is not always possible. pruneInstallPlanToDependencies - :: Set UnitId + :: HasCallStack + => Set UnitId -> ElaboratedInstallPlan -> Either CannotPruneDependencies diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs index 6bb250176ba..83490ceb927 100644 --- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs +++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs @@ -77,6 +77,7 @@ import qualified Data.Graph as OldGraph import qualified Data.Map as Map import Distribution.Compat.Graph (Graph, IsNode (..)) import qualified Distribution.Compat.Graph as Graph +import GHC.Stack (HasCallStack) type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc @@ -144,7 +145,8 @@ toMap = Graph.toMap . planIndex -- the dependencies of a package or set of packages without actually -- installing the package itself, as when doing development. remove - :: (SolverPlanPackage -> Bool) + :: HasCallStack + => (SolverPlanPackage -> Bool) -> SolverInstallPlan -> Either [SolverPlanProblem] From 26368736ae66c1791481fe7c4933c88ad93c38e1 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 19 May 2025 16:54:37 +0800 Subject: [PATCH 25/54] fix: use nodeKey in fromSolverInstallPlanWithProgress --- .../src/Distribution/Client/InstallPlan.hs | 25 ++++++------------- 1 file changed, 7 insertions(+), 18 deletions(-) diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index d2942bf6b5d..f9edbde6fe0 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -598,10 +598,10 @@ fromSolverInstallPlanWithProgress -> SolverInstallPlan -> LogProgress (GenericInstallPlan ipkg srcpkg) fromSolverInstallPlanWithProgress f plan = do - (_, _, pkgs'') <- + (_, pkgs'') <- foldM f' - (Map.empty, Map.empty, []) + (Map.empty, []) (SolverInstallPlan.reverseTopologicalOrder plan) return $ mkInstallPlan @@ -609,26 +609,15 @@ fromSolverInstallPlanWithProgress f plan = do (Graph.fromDistinctList pkgs'') (SolverInstallPlan.planIndepGoals plan) where - f' (pidMap, ipiMap, pkgs) pkg = do - pkgs' <- f (mapDep pidMap ipiMap) pkg - let (pidMap', ipiMap') = - case nodeKey pkg of - -- FIXME: stage is ignored - PreExistingId _stage _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) - PlannedId _stage pid -> (Map.insert pid pkgs' pidMap, ipiMap) - return (pidMap', ipiMap', pkgs' ++ pkgs) + f' (pMap, pkgs) pkg = do + pkgs' <- f (mapDep pMap) pkg + let pMap' = Map.insert (nodeKey pkg) pkgs' pMap + return (pMap', pkgs' ++ pkgs) -- The error below shouldn't happen, since mapDep should only -- be called on neighbor SolverId, which must have all been done -- already by the reverse top-sort (we assume the graph is not broken). - -- - -- FIXME: stage is ignored - mapDep _ ipiMap (PreExistingId _stage _pid uid) - | Just pkgs <- Map.lookup uid ipiMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) - mapDep pidMap _ (PlannedId _stage pid) - | Just pkgs <- Map.lookup pid pidMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) + mapDep pMap key = fromMaybe (error ("fromSolverInstallPlanWithProgress: " ++ prettyShow key)) (Map.lookup key pMap) -- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. -- Similar to 'elaboratedInstallPlan' From f6a04f1467060c0707c441cf06afb7f0d2a05042 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 5 May 2025 16:31:02 +0800 Subject: [PATCH 26/54] propagate stage trough elaborateProjectPlanning available targets are only host --- .../src/Distribution/Client/CmdGenBounds.hs | 10 +- .../Distribution/Client/CmdHaddockProject.hs | 12 +- .../src/Distribution/Client/CmdInstall.hs | 15 +- .../src/Distribution/Client/CmdListBin.hs | 6 +- .../src/Distribution/Client/CmdPath.hs | 2 - .../src/Distribution/Client/CmdRepl.hs | 99 ++-- .../src/Distribution/Client/CmdRun.hs | 30 +- .../src/Distribution/Client/CmdTarget.hs | 6 +- .../src/Distribution/Client/Errors.hs | 3 +- .../src/Distribution/Client/PackageHash.hs | 17 +- .../Distribution/Client/ProjectBuilding.hs | 9 +- .../Client/ProjectBuilding/Types.hs | 8 +- .../Client/ProjectOrchestration.hs | 69 +-- .../Distribution/Client/ProjectPlanOutput.hs | 105 ++-- .../Distribution/Client/ProjectPlanning.hs | 482 +++++++++++------- .../Client/ProjectPlanning/Stage.hs | 3 +- .../Client/ProjectPlanning/Types.hs | 121 +++-- cabal-install/tests/IntegrationTests2.hs | 68 +-- 18 files changed, 620 insertions(+), 445 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdGenBounds.hs b/cabal-install/src/Distribution/Client/CmdGenBounds.hs index b19161e3ac9..5989fb55e23 100644 --- a/cabal-install/src/Distribution/Client/CmdGenBounds.hs +++ b/cabal-install/src/Distribution/Client/CmdGenBounds.hs @@ -38,6 +38,7 @@ import Distribution.Client.ProjectFlags import Distribution.Client.ProjectOrchestration import Distribution.Client.ScriptUtils import Distribution.Client.TargetProblem +import qualified Distribution.Compat.Graph as Graph import Distribution.Simple.Command import Distribution.Types.Component import Distribution.Verbosity @@ -129,8 +130,8 @@ genBoundsAction flags targetStrings globalFlags = pkgVersionMap :: Map.Map ComponentId PackageIdentifier pkgVersionMap = Map.fromList (map (InstallPlan.foldPlanPackage externalVersion localVersion) (InstallPlan.toList elaboratedPlan')) - externalVersion :: InstalledPackageInfo -> (ComponentId, PackageIdentifier) - externalVersion pkg = (installedComponentId pkg, packageId pkg) + externalVersion :: WithStage InstalledPackageInfo -> (ComponentId, PackageIdentifier) + externalVersion (WithStage _stage pkg) = (installedComponentId pkg, packageId pkg) localVersion :: ElaboratedConfiguredPackage -> (ComponentId, PackageIdentifier) localVersion pkg = (elabComponentId pkg, packageId pkg) @@ -138,7 +139,7 @@ genBoundsAction flags targetStrings globalFlags = let genBoundsActionForPkg :: ElaboratedConfiguredPackage -> [GenBoundsResult] genBoundsActionForPkg pkg = -- Step 5: Match up the user specified targets with the local packages. - case Map.lookup (installedUnitId pkg) targets of + case Map.lookup (Graph.nodeKey pkg) targets of Nothing -> [] Just tgts -> map (\(tgt, _) -> getBoundsForComponent tgt pkg pkgVersionMap) tgts @@ -187,7 +188,8 @@ getBoundsForComponent tgt pkg pkgVersionMap = let componentDeps = elabLibDependencies pkg -- Match these up to package names, this is a list of Package name to versions. -- Now just match that up with what the user wrote in the build-depends section. - depsWithVersions = mapMaybe (\cid -> Map.lookup (confInstId $ fst cid) pkgVersionMap) componentDeps + -- FIXME: I am not quite sure how this is supposed to work + depsWithVersions = mapMaybe (\(WithStage _stage cid, _) -> Map.lookup (confInstId cid) pkgVersionMap) componentDeps isNeeded = hasElem needBounds . packageName in boundsResult (Just (filter isNeeded depsWithVersions)) where diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index dda55d4b8f7..a530491c09d 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -35,11 +35,11 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage (..) , ElaboratedInstallPlan + , ElaboratedInstalledPackageInfo , ElaboratedSharedConfig (..) , TargetAction (..) - ) -import Distribution.Client.ProjectPlanning.Types - ( Toolchain (..) + , Toolchain (..) + , WithStage (..) , elabDistDirParams , getStage ) @@ -162,7 +162,7 @@ haddockProjectAction flags _extraArgs globalFlags = do sharedConfig :: ElaboratedSharedConfig sharedConfig = elaboratedShared buildCtx - pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage] + pkgs :: [Either ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage] pkgs = matchingPackages elaboratedPlan -- TODO @@ -212,7 +212,7 @@ haddockProjectAction flags _extraArgs globalFlags = do packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg -> case pkg of - Left package | localStyle -> do + Left (WithStage _ package) | localStyle -> do let packageName = unPackageName (pkgName $ sourcePackageId package) destDir = outputDir packageName fmap catMaybes $ for (haddockInterfaces package) $ \interfacePath -> do @@ -446,7 +446,7 @@ haddockProjectAction flags _extraArgs globalFlags = do matchingPackages :: ElaboratedInstallPlan - -> [Either InstalledPackageInfo ElaboratedConfiguredPackage] + -> [Either ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage] matchingPackages = fmap (foldPlanPackage Left Right) . InstallPlan.toList diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index c7b73e42e94..6fb13d63a9a 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -88,10 +88,10 @@ import Distribution.Client.ProjectConfig.Types ) import Distribution.Client.ProjectFlags (ProjectFlags (..)) import Distribution.Client.ProjectPlanning - ( storePackageInstallDirs' - ) -import Distribution.Client.ProjectPlanning.Types ( ElaboratedInstallPlan + , ElaboratedPlanPackage + , Stage (..) + , storePackageInstallDirs' ) import Distribution.Client.RebuildMonad ( runRebuild @@ -112,6 +112,7 @@ import Distribution.Client.Types import Distribution.Client.Types.OverwritePolicy ( OverwritePolicy (..) ) +import qualified Distribution.Compat.Graph as Graph import Distribution.Package ( Package (..) , PackageName @@ -562,7 +563,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project traverseInstall action cfg@InstallCfg{verbosity = v, buildCtx, installClientFlags} = do let overwritePolicy = fromFlagOrDefault NeverOverwrite $ cinstOverwritePolicy installClientFlags actionOnExe <- action v overwritePolicy <$> prepareExeInstall cfg - traverse_ actionOnExe . Map.toList $ targetsMap buildCtx + traverse_ actionOnExe . Map.toList $ filterTargetsWithStage Host $ targetsMap buildCtx withProject :: Verbosity @@ -781,7 +782,7 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelector localPkgs = sdistize <$> localPackages baseCtx - gatherTargets :: UnitId -> TargetSelector + gatherTargets :: Graph.Key ElaboratedPlanPackage -> TargetSelector gatherTargets targetId = TargetPackageNamed pkgName targetFilter where targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap @@ -826,7 +827,7 @@ partitionToKnownTargetsAndHackagePackages -> SourcePackageDb -> ElaboratedInstallPlan -> [TargetSelector] - -> IO (TargetsMap, [PackageName]) + -> IO (TargetsMapS, [PackageName]) partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do let mTargets = resolveTargetsFromSolver @@ -1002,7 +1003,7 @@ installLibraries ordNub $ globalEntries ++ envEntries - ++ entriesForLibraryComponents (targetsMap buildCtx) + ++ entriesForLibraryComponents (filterTargetsWithStage Host $ targetsMap buildCtx) contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries) createDirectoryIfMissing True (takeDirectory envFile) writeFileAtomic envFile (BS.pack contents') diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index e430e983ba9..4dc55162dc6 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -224,7 +224,7 @@ listbinAction flags args globalFlags = do -- Target Problem: the very similar to CmdRun ------------------------------------------------------------------------------- -singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) +singleComponentOrElse :: IO (WithStage UnitId, UnqualComponentName) -> TargetsMapS -> IO (WithStage UnitId, UnqualComponentName) singleComponentOrElse action targetsMap = case Set.toList . distinctTargetComponents $ targetsMap of [(unitId, CExeName component)] -> return (unitId, component) @@ -316,7 +316,7 @@ data ListBinProblem | -- | A single 'TargetSelector' matches multiple targets TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] | -- | Multiple 'TargetSelector's match multiple targets - TargetProblemMultipleTargets TargetsMap + TargetProblemMultipleTargets TargetsMapS | -- | The 'TargetSelector' refers to a component that is not an executable TargetProblemComponentNotRightKind PackageId ComponentName | -- | Asking to run an individual file or module is not supported @@ -333,7 +333,7 @@ matchesMultipleProblem selector targets = CustomTargetProblem $ TargetProblemMatchesMultiple selector targets -multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem +multipleTargetsProblem :: TargetsMapS -> TargetProblem ListBinProblem multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem diff --git a/cabal-install/src/Distribution/Client/CmdPath.hs b/cabal-install/src/Distribution/Client/CmdPath.hs index 9e07d69c39f..895f68d6e49 100644 --- a/cabal-install/src/Distribution/Client/CmdPath.hs +++ b/cabal-install/src/Distribution/Client/CmdPath.hs @@ -42,7 +42,6 @@ import Distribution.Client.ProjectConfig.Types ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning -import Distribution.Client.ProjectPlanning.Types (Toolchain (..)) import Distribution.Client.RebuildMonad (runRebuild) import Distribution.Client.ScriptUtils import Distribution.Client.Setup @@ -82,7 +81,6 @@ import Distribution.Simple.Utils , withOutputMarker , wrapText ) -import Distribution.Solver.Types.Stage import Distribution.Verbosity ( normal , verbosityFlags diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index fe0e6f80ca3..1bab56d3e70 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -56,6 +56,9 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedInstallPlan , ElaboratedSharedConfig (..) + , Stage (..) + , WithStage + , getStage ) import Distribution.Client.ProjectPlanning.Types ( Toolchain (..) @@ -94,7 +97,6 @@ import Distribution.Compiler import Distribution.Package ( Package (..) , UnitId - , installedUnitId , mkPackageName , packageName ) @@ -186,11 +188,11 @@ import Distribution.Client.ReplFlags , topReplOptions ) import Distribution.Compat.Binary (decode) +import qualified Distribution.Compat.Graph as Graph import Distribution.Simple.Flag (flagToMaybe, fromFlagOrDefault, pattern Flag) import Distribution.Simple.Program.Builtin (ghcProgram) import Distribution.Simple.Program.Db (requireProgram) import Distribution.Simple.Program.Types -import Distribution.Solver.Types.Stage import System.Directory ( doesFileExist , getCurrentDirectory @@ -444,15 +446,14 @@ targetedRepl -- especially in the no-project case. withInstallPlan (modifyVerbosityFlags lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do -- targets should be non-empty map, but there's no NonEmptyMap yet. - -- TODO: This only makes sense for the build stage let Toolchain{toolchainCompiler = compiler} = getStage (pkgConfigToolchains sharedConfig) Build + -- FIXME there is total confusion here about who is filtering for the stage targets <- validatedTargets (projectConfigShared (projectConfig ctx)) compiler elaboratedPlan targetSelectors - let - (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets - originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId - oci = OriginalComponentInfo unitId originalDeps - pkgId = maybe (error $ "cannot find " ++ prettyShow unitId) packageId (InstallPlan.lookup elaboratedPlan unitId) + (key, _uid) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets + originalDeps = Graph.nodeKey <$> InstallPlan.directDeps elaboratedPlan key + oci = OriginalComponentInfo key originalDeps + pkgId = fromMaybe (error $ "cannot find " ++ prettyShow key) $ packageId <$> InstallPlan.lookup elaboratedPlan key baseCtx'' = addDepsToProjectTarget (envPackages replEnvFlags) pkgId baseCtx' return (Just oci, baseCtx'') @@ -601,30 +602,39 @@ targetedRepl buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx' runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes - where - projectRoot = distProjectRootDirectory $ distDirLayout ctx - distDir = distDirectory $ distDirLayout ctx - - combine_search_paths paths = - foldl' go Map.empty paths - where - go m ("PATH", Just s) = foldl' (\m' f -> Map.insertWith (+) f 1 m') m (splitSearchPath s) - go m _ = m - - verbosity = cfgVerbosity normal flags - tempFileOptions = commonSetupTempFileOptions $ configCommonFlags configFlags - validatedTargets' = validatedTargets verbosity replFlags - -withCtx :: NixStyleFlags a -> [String] -> GlobalFlags -> TargetsAction [TargetSelector] b -> IO b -withCtx flags targetStrings globalFlags = - withContextAndSelectors - (cfgVerbosity normal flags) - (if null targetStrings then AcceptNoTargets else RejectNoTargets) - (Just LibKind) - flags - targetStrings - globalFlags - ReplCommand + where + combine_search_paths paths = + foldl' go Map.empty paths + where + go m ("PATH", Just s) = foldl' (\m' f -> Map.insertWith (+) f 1 m') m (splitSearchPath s) + go m _ = m + + verbosity = cfgVerbosity normal flags + tempFileOptions = commonSetupTempFileOptions $ configCommonFlags configFlags + + -- FIXME: the compiler depends on the stage!! + validatedTargets ctx compiler elaboratedPlan targetSelectors = do + let multi_repl_enabled = multiReplDecision ctx compiler r + -- Interpret the targets on the command line as repl targets + -- (as opposed to say build or haddock targets). + targets <- + either (reportTargetProblems verbosity) return $ + resolveTargetsFromSolver + (selectPackageTargets multi_repl_enabled) + selectComponentTarget + elaboratedPlan' + Nothing + selectors + + -- Reject multiple targets, or at least targets in different + -- components. It is ok to have two module/file targets in the + -- same component, but not two that live in different components. + when (Set.size (distinctTargetComponents targets) > 1 && not (useMultiRepl multi_repl_enabled)) $ + reportTargetProblems + verbosity + [multipleTargetsProblem multi_repl_enabled targets] + + return targets -- | Create a constraint which requires a later version of Cabal. -- This is used for commands which require a specific feature from the Cabal library @@ -705,8 +715,8 @@ minMultipleHomeUnitsVersion :: Version minMultipleHomeUnitsVersion = mkVersion [9, 4] data OriginalComponentInfo = OriginalComponentInfo - { ociUnitId :: UnitId - , ociOriginalDeps :: [UnitId] + { ociUnitId :: WithStage UnitId + , ociOriginalDeps :: [WithStage UnitId] } deriving (Show) @@ -741,18 +751,25 @@ addDepsToProjectTarget deps pkgId ctx = generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> [String] generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags where - exeDeps :: [UnitId] + exeDeps :: [WithStage UnitId] exeDeps = foldMap (InstallPlan.foldPlanPackage (const []) elabOrderExeDependencies) (InstallPlan.dependencyClosure elaboratedPlan [ociUnitId]) - deps, deps', trans, trans' :: [UnitId] - flags :: [String] - deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId + deps :: [WithStage UnitId] + deps = Graph.nodeKey <$> InstallPlan.directDeps elaboratedPlan ociUnitId + + deps' :: [WithStage UnitId] deps' = deps \\ ociOriginalDeps - trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps' + + trans :: [WithStage UnitId] + trans = Graph.nodeKey <$> InstallPlan.dependencyClosure elaboratedPlan deps' + + trans' :: [WithStage UnitId] trans' = trans \\ ociOriginalDeps + + flags :: [String] flags = fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps) $ if includeTransitive then trans' else deps' @@ -897,7 +914,7 @@ selectComponentTarget = selectComponentTargetBasic data ReplProblem = TargetProblemMatchesMultiple MultiReplDecision TargetSelector [AvailableTarget ()] | -- | Multiple 'TargetSelector's match multiple targets - TargetProblemMultipleTargets MultiReplDecision TargetsMap + TargetProblemMultipleTargets MultiReplDecision TargetsMapS deriving (Eq, Show) -- | The various error conditions that can occur when matching a @@ -914,7 +931,7 @@ matchesMultipleProblem decision targetSelector targetsExesBuildable = multipleTargetsProblem :: MultiReplDecision - -> TargetsMap + -> TargetsMapS -> ReplTargetProblem multipleTargetsProblem decision = CustomTargetProblem . TargetProblemMultipleTargets decision diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index 6de25f0d2e9..c6ce5f8b845 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -54,6 +54,7 @@ import qualified Distribution.Client.ProjectOrchestration as Orchestration (targ import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage (..) , ElaboratedInstallPlan + , WithStage (..) , binDirectoryFor ) import Distribution.Client.ProjectPlanning.Types @@ -437,7 +438,7 @@ handleShebang :: FilePath -> [String] -> IO () handleShebang script args = runAction (commandDefaultFlags runCommand) (script : args) defaultGlobalFlags -singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) +singleExeOrElse :: IO (WithStage UnitId, UnqualComponentName) -> TargetsMapS -> IO (WithStage UnitId, UnqualComponentName) singleExeOrElse action targetsMap = case Set.toList . distinctTargetComponents $ targetsMap of [(unitId, CExeName component)] -> return (unitId, component) @@ -449,19 +450,20 @@ singleExeOrElse action targetsMap = -- 'ElaboratedConfiguredPackage's that match the specified -- 'UnitId'. matchingPackagesByUnitId - :: UnitId + :: WithStage UnitId -> ElaboratedInstallPlan -> [ElaboratedConfiguredPackage] -matchingPackagesByUnitId uid = - mapMaybe - ( foldPlanPackage - (const Nothing) - ( \x -> - if elabUnitId x == uid - then Just x - else Nothing - ) - ) +matchingPackagesByUnitId (WithStage s uid) = + catMaybes + . fmap + ( foldPlanPackage + (const Nothing) + ( \x -> + if elabUnitId x == uid && elabStage x == s + then Just x + else Nothing + ) + ) . toList -- | This defines what a 'TargetSelector' means for the @run@ command. @@ -546,7 +548,7 @@ data RunProblem | -- | A single 'TargetSelector' matches multiple targets TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] | -- | Multiple 'TargetSelector's match multiple targets - TargetProblemMultipleTargets TargetsMap + TargetProblemMultipleTargets TargetsMapS | -- | The 'TargetSelector' refers to a component that is not an executable TargetProblemComponentNotExe PackageId ComponentName | -- | Asking to run an individual file or module is not supported @@ -563,7 +565,7 @@ matchesMultipleProblem selector targets = CustomTargetProblem $ TargetProblemMatchesMultiple selector targets -multipleTargetsProblem :: TargetsMap -> TargetProblem RunProblem +multipleTargetsProblem :: TargetsMapS -> TargetProblem RunProblem multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets componentNotExeProblem :: PackageId -> ComponentName -> TargetProblem RunProblem diff --git a/cabal-install/src/Distribution/Client/CmdTarget.hs b/cabal-install/src/Distribution/Client/CmdTarget.hs index b5e332ceaeb..9d05bba076b 100644 --- a/cabal-install/src/Distribution/Client/CmdTarget.hs +++ b/cabal-install/src/Distribution/Client/CmdTarget.hs @@ -172,7 +172,7 @@ targetAction flags@NixStyleFlags{..} ts globalFlags = do either (reportTargetSelectorProblems verbosity) return =<< readTargetSelectors localPackages Nothing targetStrings - targets :: TargetsMap <- + targets <- either (reportBuildTargetProblems verbosity) return $ resolveTargetsFromSolver selectPackageTargets @@ -196,7 +196,7 @@ targetAction flags@NixStyleFlags{..} ts globalFlags = do reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a reportBuildTargetProblems verbosity = reportTargetProblems verbosity "target" -printTargetForms :: Verbosity -> [String] -> TargetsMap -> ElaboratedInstallPlan -> IO () +printTargetForms :: Verbosity -> [String] -> TargetsMapS -> ElaboratedInstallPlan -> IO () printTargetForms verbosity targetStrings targets elaboratedPlan = noticeDoc verbosity $ vcat @@ -222,7 +222,7 @@ printTargetForms verbosity targetStrings targets elaboratedPlan = sort $ catMaybes [ targetForm ct <$> pkg - | (u :: UnitId, xs) <- Map.toAscList targets + | (WithStage _ u, xs) <- Map.toAscList targets , let pkg = safeHead $ filter ((== u) . elabUnitId) localPkgs , (ct :: ComponentTarget, _) <- xs ] diff --git a/cabal-install/src/Distribution/Client/Errors.hs b/cabal-install/src/Distribution/Client/Errors.hs index 8f02620c6d8..a5497c0bab4 100644 --- a/cabal-install/src/Distribution/Client/Errors.hs +++ b/cabal-install/src/Distribution/Client/Errors.hs @@ -23,6 +23,7 @@ import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BS8 import Data.List (groupBy) import Distribution.Client.IndexUtils.Timestamp +import Distribution.Client.ProjectPlanning.Stage (WithStage) import qualified Distribution.Client.Types.Repo as Repo import qualified Distribution.Client.Types.RepoName as RepoName import Distribution.Compat.Prelude @@ -95,7 +96,7 @@ data CabalInstallException | PlanPackages String | NoSupportForRunCommand | RunPhaseReached - | UnknownExecutable String UnitId + | UnknownExecutable String (WithStage UnitId) | MultipleMatchingExecutables String [String] | CmdRunReportTargetProblems String | CleanAction [String] diff --git a/cabal-install/src/Distribution/Client/PackageHash.hs b/cabal-install/src/Distribution/Client/PackageHash.hs index 6ba0bfb98bb..227a1792691 100644 --- a/cabal-install/src/Distribution/Client/PackageHash.hs +++ b/cabal-install/src/Distribution/Client/PackageHash.hs @@ -182,7 +182,8 @@ data PackageHashInputs = PackageHashInputs , pkgHashComponent :: Maybe CD.Component , pkgHashSourceHash :: PackageSourceHash , pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion) - , pkgHashDirectDeps :: Set InstalledPackageId + , pkgHashLibDeps :: Set InstalledPackageId + , pkgHashExeDeps :: Set InstalledPackageId , pkgHashOtherConfig :: PackageHashConfigInputs } @@ -258,7 +259,8 @@ renderPackageHashInputs { pkgHashPkgId , pkgHashComponent , pkgHashSourceHash - , pkgHashDirectDeps + , pkgHashLibDeps + , pkgHashExeDeps , pkgHashPkgConfigDeps , pkgHashOtherConfig = PackageHashConfigInputs{..} @@ -297,12 +299,19 @@ renderPackageHashInputs ) pkgHashPkgConfigDeps , entry - "deps" + "lib-deps" ( intercalate ", " . map prettyShow . Set.toList ) - pkgHashDirectDeps + pkgHashLibDeps + , entry + "exe-deps" + ( intercalate ", " + . map prettyShow + . Set.toList + ) + pkgHashExeDeps , -- and then all the config entry "compilerid" prettyShow pkgHashCompilerId , entry "compilerabi" prettyShow pkgHashCompilerABI diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 720bf74589a..e14bb5bd597 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -96,6 +96,7 @@ import Distribution.Simple.Flag (fromFlagOrDefault) import Distribution.Client.ProjectBuilding.PackageFileMonitor import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage) +import qualified Distribution.Compat.Graph as Graph ------------------------------------------------------------------------------ @@ -458,13 +459,14 @@ rebuildTargets offlineError :: BuildOutcomes offlineError = Map.fromList . map makeBuildOutcome $ packagesToDownload where - makeBuildOutcome :: ElaboratedConfiguredPackage -> (UnitId, BuildOutcome) + makeBuildOutcome :: ElaboratedConfiguredPackage -> (Graph.Key ElaboratedPlanPackage, BuildOutcome) makeBuildOutcome ElaboratedConfiguredPackage { elabUnitId + , elabStage , elabPkgSourceId = PackageIdentifier{pkgName, pkgVersion} } = - ( elabUnitId + ( WithStage elabStage elabUnitId , Left ( BuildFailure { buildFailureLogFile = Nothing @@ -656,8 +658,7 @@ asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body [ elabPkgSourceLocation elab | InstallPlan.Configured elab <- InstallPlan.reverseTopologicalOrder installPlan - , let uid = installedUnitId elab - pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus + , let pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") (Graph.nodeKey elab) pkgsBuildStatus , BuildStatusDownload <- [pkgBuildStatus] ] diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs index 864455cb540..3d8b9ff9082 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs @@ -25,8 +25,10 @@ import Prelude () import Distribution.Client.FileMonitor (MonitorChangedReason (..)) import Distribution.Client.Types (DocsResult, TestsResult) +import Distribution.Client.ProjectPlanning.Types (ElaboratedPlanPackage) +import qualified Distribution.Compat.Graph as Graph import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Package (PackageId, UnitId) +import Distribution.Package (PackageId) import Distribution.Simple.LocalBuildInfo (ComponentName) ------------------------------------------------------------------------------ @@ -36,7 +38,7 @@ import Distribution.Simple.LocalBuildInfo (ComponentName) -- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'. -- -- This is used as the result of the dry-run of building an install plan. -type BuildStatusMap = Map UnitId BuildStatus +type BuildStatusMap = Map (Graph.Key ElaboratedPlanPackage) BuildStatus -- | The build status for an individual package is the state that the -- package is in /prior/ to initiating a (re)build. @@ -135,7 +137,7 @@ data BuildReason -- -- | A summary of the outcome for building a whole set of packages. -type BuildOutcomes = Map UnitId BuildOutcome +type BuildOutcomes = Map (Graph.Key ElaboratedPlanPackage) BuildOutcome -- | A summary of the outcome for building a single package: either success -- or failure. diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 19a7055afde..5bdccc935a1 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -61,6 +62,7 @@ module Distribution.Client.ProjectOrchestration , resolveTargetsFromSolver , resolveTargetsFromLocalPackages , TargetsMap + , TargetsMapS , allTargetSelectors , uniqueTargetSelectors , TargetSelector (..) @@ -102,6 +104,7 @@ module Distribution.Client.ProjectOrchestration -- * Dummy projects , establishDummyProjectBaseContext , establishDummyDistDirLayout + , filterTargetsWithStage ) where import Distribution.Client.Compat.Prelude @@ -152,9 +155,6 @@ import Distribution.Client.Setup hiding (packageName) import Distribution.Types.ComponentName ( componentNameString ) -import Distribution.Types.InstalledPackageInfo - ( InstalledPackageInfo - ) import Distribution.Types.UnqualComponentName ( UnqualComponentName , packageNameToUnqualComponentName @@ -325,7 +325,7 @@ data ProjectBuildContext = ProjectBuildContext , pkgsBuildStatus :: BuildStatusMap -- ^ The result of the dry-run phase. This tells us about each member of -- the 'elaboratedPlanToExecute'. - , targetsMap :: TargetsMap + , targetsMap :: TargetsMapS -- ^ The targets selected by @selectPlanSubset@. This is useful eg. in -- CmdRun, where we need a valid target to execute. } @@ -363,7 +363,7 @@ withInstallPlan runProjectPreBuildPhase :: Verbosity -> ProjectBaseContext - -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap)) + -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMapS)) -> IO ProjectBuildContext runProjectPreBuildPhase verbosity @@ -549,12 +549,22 @@ type TargetsMap = TargetsMapX UnitId type TargetsMapX u = Map u [(ComponentTarget, NonEmpty TargetSelector)] +type TargetsMapS = TargetsMapX (WithStage UnitId) + +filterTargetsWithStage :: Stage -> TargetsMapS -> TargetsMap +filterTargetsWithStage stage = + Map.fromList + . mapMaybe (\(WithStage s uid, v) -> if s == stage then Just (uid, v) else Nothing) + . Map.toList + +-- Map.mapMaybeWithKey (\(WithStage s uid) v -> if s == stage then Just v else Nothing) + -- | Get all target selectors. -allTargetSelectors :: TargetsMap -> [TargetSelector] +allTargetSelectors :: TargetsMapS -> [TargetSelector] allTargetSelectors = concatMap (NE.toList . snd) . concat . Map.elems -- | Get all unique target selectors. -uniqueTargetSelectors :: TargetsMap -> [TargetSelector] +uniqueTargetSelectors :: TargetsMapS -> [TargetSelector] uniqueTargetSelectors = ordNub . allTargetSelectors -- | Resolve targets from a solver result. @@ -577,7 +587,7 @@ resolveTargetsFromSolver -> ElaboratedInstallPlan -> Maybe (SourcePackageDb) -> [TargetSelector] - -> Either [TargetProblem err] TargetsMap + -> Either [TargetProblem err] TargetsMapS resolveTargetsFromSolver selectPackageTargets selectComponentTarget installPlan sourceDb targetSelectors = resolveTargets selectPackageTargets @@ -799,18 +809,18 @@ type AvailableTargetsMap k u = Map k [AvailableTarget (u, ComponentName)] -- -- They are all constructed lazily because they are not necessarily all used. -- -availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes UnitId +availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes (WithStage UnitId) availableTargetIndexes installPlan = AvailableTargetIndexes{..} where availableTargetsByPackageIdAndComponentName :: Map (PackageId, ComponentName) - [AvailableTarget (UnitId, ComponentName)] + [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageIdAndComponentName = availableTargets installPlan availableTargetsByPackageId - :: Map PackageId [AvailableTarget (UnitId, ComponentName)] + :: Map PackageId [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageId = Map.mapKeysWith (++) @@ -819,7 +829,7 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..} `Map.union` availableTargetsEmptyPackages availableTargetsByPackageName - :: Map PackageName [AvailableTarget (UnitId, ComponentName)] + :: Map PackageName [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageName = Map.mapKeysWith (++) @@ -829,7 +839,7 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..} availableTargetsByPackageNameAndComponentName :: Map (PackageName, ComponentName) - [AvailableTarget (UnitId, ComponentName)] + [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageNameAndComponentName = Map.mapKeysWith (++) @@ -839,7 +849,7 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..} availableTargetsByPackageNameAndUnqualComponentName :: Map (PackageName, UnqualComponentName) - [AvailableTarget (UnitId, ComponentName)] + [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageNameAndUnqualComponentName = Map.mapKeysWith (++) @@ -1031,7 +1041,7 @@ selectComponentTargetBasic -- for the extra unneeded info in the 'TargetsMap'. pruneInstallPlanToTargets :: TargetAction - -> TargetsMap + -> TargetsMapS -> ElaboratedInstallPlan -> ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = @@ -1043,7 +1053,7 @@ pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = -- | Utility used by repl and run to check if the targets spans multiple -- components, since those commands do not support multiple components. -distinctTargetComponents :: TargetsMap -> Set.Set (UnitId, ComponentName) +distinctTargetComponents :: TargetsMapS -> Set.Set (WithStage UnitId, ComponentName) distinctTargetComponents targetsMap = Set.fromList [ (uid, cname) @@ -1114,7 +1124,8 @@ printPlan filter (not . null) [ " -" - , if verbosityLevel verbosity >= Deafening + , prettyShow (elabStage elab) + , if verbosity >= deafening then prettyShow (installedUnitId elab) else prettyShow (packageId elab) , case elabBuildStyle elab of @@ -1126,7 +1137,7 @@ printPlan "(" ++ showComp comp ++ ")" , showFlagAssignment (nonDefaultFlags elab) , showConfigureFlags elab - , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab + , let buildStatus = pkgsBuildStatus Map.! Graph.nodeKey elab in "(" ++ showBuildStatus buildStatus ++ ")" ] @@ -1340,7 +1351,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes , (pkg, failureClassification) <- failuresClassification ] where - failures :: [(UnitId, BuildFailure)] + failures :: [(Graph.Key ElaboratedPlanPackage, BuildFailure)] failures = [ (pkgid, failure) | (pkgid, Left failure) <- Map.toList buildOutcomes @@ -1398,9 +1409,10 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes -- isSimpleCase :: Bool isSimpleCase - | [(pkgid, failure)] <- failures + | [(WithStage s pkgid, failure)] <- failures , [pkg] <- rootpkgs , installedUnitId pkg == pkgid + , stageOf pkg == s , isFailureSelfExplanatory (buildFailureReason failure) , currentCommand `notElem` [InstallCommand, BuildCommand, ReplCommand] = True @@ -1424,16 +1436,15 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes , hasNoDependents pkg ] - ultimateDeps - :: UnitId - -> [InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage] - ultimateDeps pkgid = + ultimateDeps :: (WithStage UnitId) -> [ElaboratedPlanPackage] + ultimateDeps pkgid@(WithStage s uid) = filter - (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid) + (\pkg -> hasNoDependents pkg && installedUnitId pkg /= uid && stageOf pkg == s) (InstallPlan.reverseDependencyClosure plan [pkgid]) - hasNoDependents :: HasUnitId pkg => pkg -> Bool - hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId + -- TODO: ugly + hasNoDependents :: (Graph.IsNode pkg, Graph.Key pkg ~ WithStage UnitId) => pkg -> Bool + hasNoDependents = null . InstallPlan.revDirectDeps plan . Graph.nodeKey renderFailureDetail :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String renderFailureDetail mentionDepOf pkg reason = @@ -1465,7 +1476,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes pkgstr = elabConfiguredName verbosity pkg ++ if mentionDepOf - then renderDependencyOf (installedUnitId pkg) + then renderDependencyOf (Graph.nodeKey pkg) else "" renderFailureExtraDetail :: BuildFailureReason -> String @@ -1476,7 +1487,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes renderFailureExtraDetail _ = "" - renderDependencyOf :: UnitId -> String + renderDependencyOf :: Graph.Key ElaboratedConfiguredPackage -> String renderDependencyOf pkgid = case ultimateDeps pkgid of [] -> "" diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index eabe1fbe2f6..fbec1e50554 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -141,7 +141,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- that case, but the code supports it in case we want to use this -- later in some use case where we want the status of the build. - installedPackageInfoToJ :: InstalledPackageInfo -> J.Value + installedPackageInfoToJ :: WithStage InstalledPackageInfo -> J.Value installedPackageInfoToJ ipi = -- Pre-existing packages lack configuration information such as their flag -- settings or non-lib components. We only get pre-existing packages for @@ -150,10 +150,11 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- J.object [ "type" J..= J.String "pre-existing" - , "id" J..= (jdisplay . installedUnitId) ipi + , "stage" J..= jdisplay (stageOf ipi) + , "id" J..= (jdisplay . Graph.nodeKey) ipi , "pkg-name" J..= (jdisplay . pkgName . packageId) ipi , "pkg-version" J..= (jdisplay . pkgVersion . packageId) ipi - , "depends" J..= map jdisplay (installedDepends ipi) + , "depends" J..= map jdisplay (traverse installedDepends ipi) ] elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value @@ -165,7 +166,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = then "installed" else "configured" ) - , "id" J..= (jdisplay . installedUnitId) elab + , "id" J..= (jdisplay . Graph.nodeKey) elab , "stage" J..= jdisplay (elabStage elab) , "pkg-name" J..= (jdisplay . pkgName . packageId) elab , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab @@ -201,8 +202,8 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = J.object $ [ comp2str c J..= J.object - ( [ "depends" J..= map ((jdisplay . confInstId) . fst) ldeps - , "exe-depends" J..= map (jdisplay . confInstId) edeps + ( [ "depends" J..= map (jdisplay . confInstId) (map fst ldeps) + , "exe-depends" J..= map (jdisplay . fmap confInstId) edeps ] ++ bin_file c ) @@ -214,7 +215,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = ] in ["components" J..= components] ElabComponent comp -> - [ "depends" J..= map ((jdisplay . confInstId) . fst) (elabLibDependencies elab) + [ "depends" J..= map (jdisplay . fmap confInstId . fst) (elabLibDependencies elab) , "exe-depends" J..= map jdisplay (elabExeDependencies elab) , "component-name" J..= J.String (comp2str (compSolverName comp)) ] @@ -467,7 +468,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- successfully then they're still out of date -- meeting our definition of -- invalid. -type PackageIdSet = Set UnitId +type PackageIdSet = Set (Graph.Key ElaboratedPlanPackage) type PackagesUpToDate = PackageIdSet data PostBuildProjectStatus = PostBuildProjectStatus @@ -520,7 +521,7 @@ data PostBuildProjectStatus = PostBuildProjectStatus -- or data file generation failing. -- -- This is a subset of 'packagesInvalidByChangedLibDeps'. - , packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) + , packagesLibDepGraph :: Graph (Node (Graph.Key ElaboratedPlanPackage) ElaboratedPlanPackage) -- ^ A subset of the plan graph, including only dependency-on-library -- edges. That is, dependencies /on/ libraries, not dependencies /of/ -- libraries. This tells us all the libraries that packages link to. @@ -590,11 +591,13 @@ postBuildProjectStatus -- The previous set of up-to-date packages will contain bogus package ids -- when the solver plan or config contributing to the hash changes. -- So keep only the ones where the package id (i.e. hash) is the same. + previousPackagesUpToDate' :: Set (WithStage UnitId) previousPackagesUpToDate' = Set.intersection previousPackagesUpToDate (InstallPlan.keysSet plan) + packagesUpToDatePreBuild :: Set (WithStage UnitId) packagesUpToDatePreBuild = Set.filter (\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid)) @@ -602,23 +605,26 @@ postBuildProjectStatus -- know anything about their status, so not known to be /up to date/. (InstallPlan.keysSet plan) + packagesOutOfDatePreBuild :: Set (WithStage UnitId) packagesOutOfDatePreBuild = - Set.fromList . map installedUnitId $ + Set.fromList . map Graph.nodeKey $ InstallPlan.reverseDependencyClosure plan [ ipkgid | pkg <- InstallPlan.toList plan - , let ipkgid = installedUnitId pkg + , let ipkgid = Graph.nodeKey pkg , lookupBuildStatusRequiresBuild False ipkgid -- For packages not in the plan subset we did the dry-run on we don't -- know anything about their status, so not known to be /out of date/. ] + packagesSuccessfulPostBuild :: Set (WithStage UnitId) packagesSuccessfulPostBuild = Set.fromList [ikgid | (ikgid, Right _) <- Map.toList buildOutcomes] -- direct failures, not failures due to deps + packagesFailurePostBuild :: Set (WithStage UnitId) packagesFailurePostBuild = Set.fromList [ ikgid @@ -630,6 +636,7 @@ postBuildProjectStatus -- Packages that have a library dependency on a package for which a build -- was attempted + packagesDepOnChangedLib :: Set (WithStage UnitId) packagesDepOnChangedLib = Set.fromList . map Graph.nodeKey $ fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $ @@ -641,19 +648,25 @@ postBuildProjectStatus ) -- The plan graph but only counting dependency-on-library edges - packagesLibDepGraph :: HasCallStack => Graph (Node UnitId ElaboratedPlanPackage) + packagesLibDepGraph :: HasCallStack => Graph (Node (Graph.Key ElaboratedPlanPackage) ElaboratedPlanPackage) packagesLibDepGraph = Graph.fromDistinctList - [ Graph.N pkg (installedUnitId pkg) libdeps + [ Graph.N pkg (Graph.nodeKey pkg) libdeps | pkg <- InstallPlan.toList plan , let libdeps = case pkg of - InstallPlan.PreExisting ipkg -> installedDepends ipkg - InstallPlan.Configured srcpkg -> elabLibDeps srcpkg - InstallPlan.Installed srcpkg -> elabLibDeps srcpkg + InstallPlan.PreExisting (WithStage s ipkg) -> map (WithStage s) (installedDepends ipkg) + InstallPlan.Configured srcpkg -> map (WithStage (elabStage srcpkg)) (elabLibDeps srcpkg) + InstallPlan.Installed srcpkg -> map (WithStage (elabStage srcpkg)) (elabLibDeps srcpkg) ] elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId] - elabLibDeps = map ((newSimpleUnitId . confInstId) . fst) . elabLibDependencies + elabLibDeps = + map (newSimpleUnitId . confInstId) + -- Note, we remove the stage here. In the end we only care about the hash which already incorporates the stage. + -- Moreover, library dependencies are always in the same stage as the package itself. + . map (\(WithStage _ d) -> d) + . map fst + . elabLibDependencies -- Was a build was attempted for this package? -- If it doesn't have both a build status and outcome then the answer is no. @@ -670,13 +683,13 @@ postBuildProjectStatus buildAttempted _ (Left BuildFailure{}) = True buildAttempted _ (Right _) = True - lookupBuildStatusRequiresBuild :: Bool -> UnitId -> Bool - lookupBuildStatusRequiresBuild def ipkgid = - case Map.lookup ipkgid pkgBuildStatus of + lookupBuildStatusRequiresBuild :: Bool -> Graph.Key ElaboratedPlanPackage -> Bool + lookupBuildStatusRequiresBuild def key = + case Map.lookup key pkgBuildStatus of Nothing -> def -- Not in the plan subset we did the dry-run on Just buildStatus -> buildStatusRequiresBuild buildStatus - packagesBuildLocal :: Set UnitId + packagesBuildLocal :: Set (WithStage UnitId) packagesBuildLocal = selectPlanPackageIdSet $ \pkg -> case pkg of @@ -684,7 +697,7 @@ postBuildProjectStatus InstallPlan.Installed _ -> False InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg - packagesBuildInplace :: Set UnitId + packagesBuildInplace :: Set (WithStage UnitId) packagesBuildInplace = selectPlanPackageIdSet $ \pkg -> case pkg of @@ -692,7 +705,7 @@ postBuildProjectStatus InstallPlan.Installed _ -> False InstallPlan.Configured srcpkg -> isInplaceBuildStyle (elabBuildStyle srcpkg) - packagesAlreadyInStore :: Set UnitId + packagesAlreadyInStore :: Set (WithStage UnitId) packagesAlreadyInStore = selectPlanPackageIdSet $ \pkg -> case pkg of @@ -701,10 +714,8 @@ postBuildProjectStatus InstallPlan.Configured _ -> False selectPlanPackageIdSet - :: ( InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage - -> Bool - ) - -> Set UnitId + :: (ElaboratedPlanPackage -> Bool) + -> Set (Graph.Key ElaboratedPlanPackage) selectPlanPackageIdSet p = Map.keysSet . Map.filter p @@ -881,33 +892,13 @@ writePlanGhcEnvironment path toolchainPlatform (compilerVersion toolchainCompiler) - ( renderGhcEnvironmentFile - path - stagePlan - postBuildStatus - ) + env else return Nothing where - Toolchain{..} = getStage (pkgConfigToolchains elaboratedSharedConfig) stage - -- TODO - stagePlan = InstallPlan.remove {- (\pkg -> undefined pkg /= Host) -} (const False) elaboratedInstallPlan + Toolchain{toolchainPlatform, toolchainCompiler} = getStage (pkgConfigToolchains elaboratedSharedConfig) stage --- TODO: [required eventually] support for writing user-wide package --- environments, e.g. like a global project, but we would not put the --- env file in the home dir, rather it lives under ~/.ghc/ + env = headerComment : simpleGhcEnvironmentFile packageDBs unitIds -renderGhcEnvironmentFile - :: FilePath - -> ElaboratedInstallPlan - -> PostBuildProjectStatus - -> [GhcEnvironmentFileEntry FilePath] -renderGhcEnvironmentFile - projectRootDir - elaboratedInstallPlan - postBuildStatus = - headerComment - : simpleGhcEnvironmentFile packageDBs unitIds - where headerComment = GhcEnvFileComment $ "This is a GHC environment file written by cabal. This means you can\n" @@ -915,11 +906,17 @@ renderGhcEnvironmentFile ++ "But you still need to use cabal repl $target to get the environment\n" ++ "of specific components (libs, exes, tests etc) because each one can\n" ++ "have its own source dirs, cpp flags etc.\n\n" - unitIds = selectGhcEnvironmentFileLibraries postBuildStatus + + unitIds = [unitId | WithStage Host unitId <- selectGhcEnvironmentFileLibraries postBuildStatus] + packageDBs = - relativePackageDBPaths projectRootDir $ + relativePackageDBPaths path $ selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan +-- TODO: [required eventually] support for writing user-wide package +-- environments, e.g. like a global project, but we would not put the +-- env file in the home dir, rather it lives under ~/.ghc/ + argsEquivalentOfGhcEnvironmentFile :: Compiler -> DistDirLayout @@ -987,7 +984,7 @@ argsEquivalentOfGhcEnvironmentFileGhc -- to find the libs) then those exes still end up in our list so we have -- to filter them out at the end. -- -selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId] +selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [WithStage UnitId] selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} = case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of Nothing -> error "renderGhcEnvironmentFile: broken dep closure" @@ -1004,7 +1001,7 @@ selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} = -- or just locally. Check it's a lib and that it is probably up to date. InstallPlan.Configured pkg -> elabRequiresRegistration pkg - && installedUnitId pkg `Set.member` packagesProbablyUpToDate + && Graph.nodeKey pkg `Set.member` packagesProbablyUpToDate selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStackCWD selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan = diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 90ca67f435c..70b81937f7d 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -36,12 +36,17 @@ module Distribution.Client.ProjectPlanning ( -- * Types for the elaborated install plan ElaboratedInstallPlan + , ElaboratedInstalledPackageInfo , ElaboratedConfiguredPackage (..) , ElaboratedPlanPackage , ElaboratedSharedConfig (..) , ElaboratedReadyPackage , BuildStyle (..) , CabalFileText + , Toolchain (..) + , Stage (..) + , Staged (..) + , WithStage (..) , elabOrderLibDependencies , elabOrderExeDependencies , elabLibDependencies @@ -99,12 +104,12 @@ module Distribution.Client.ProjectPlanning , binDirectories , storePackageInstallDirs , storePackageInstallDirs' + , elabDistDirParams ) where import Distribution.Client.Compat.Prelude import Text.PrettyPrint - ( colon - , comma + ( comma , fsep , hang , punctuate @@ -235,7 +240,10 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Client.Errors +import Distribution.Client.InstallPlan (foldPlanPackage) import Distribution.Solver.Types.ProjectConfigPath +import Distribution.Solver.Types.ResolverPackage (solverId) +import qualified Distribution.Solver.Types.ResolverPackage as ResolverPackage import GHC.Stack (HasCallStack) import System.Directory (getCurrentDirectory) import System.FilePath @@ -874,7 +882,7 @@ rebuildInstallPlan (solverSettingIndexState solverSettings) (solverSettingActiveRepos solverSettings) - ipis <- for toolchains (\t -> getInstalledPackages verbosity t corePackageDbs) + ipis <- for toolchains (getInstalledPackages verbosity) pkgConfigDbs <- for toolchains (getPkgConfigDb verbosity . toolchainProgramDb) -- TODO: [code cleanup] it'd be better if the Compiler contained the @@ -908,10 +916,6 @@ rebuildInstallPlan (\Toolchain{toolchainCompiler, toolchainPlatform} -> (compilerInfo toolchainCompiler, toolchainPlatform)) toolchains - corePackageDbs :: PackageDBStackCWD - corePackageDbs = - Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain projectConfigShared)) - withRepoCtx :: (RepoContext -> IO a) -> IO a withRepoCtx = projectConfigWithSolverRepoContext @@ -1123,9 +1127,8 @@ programsMonitorFiles progdb = getInstalledPackages :: Verbosity -> Toolchain - -> PackageDBStackCWD -> Rebuild InstalledPackageIndex -getInstalledPackages verbosity Toolchain{toolchainCompiler, toolchainPlatform, toolchainProgramDb} packagedbs = do +getInstalledPackages verbosity Toolchain{..} = do monitorFiles . map monitorFileOrDirectory =<< liftIO @@ -1133,7 +1136,7 @@ getInstalledPackages verbosity Toolchain{toolchainCompiler, toolchainPlatform, t verbosity toolchainCompiler Nothing -- use ambient working directory - (coercePackageDBStack packagedbs) + (coercePackageDBStack toolchainPackageDBs) toolchainProgramDb toolchainPlatform ) @@ -1141,7 +1144,7 @@ getInstalledPackages verbosity Toolchain{toolchainCompiler, toolchainPlatform, t IndexUtils.getInstalledPackages verbosity toolchainCompiler - packagedbs + toolchainPackageDBs toolchainProgramDb {- @@ -1678,13 +1681,12 @@ elaborateInstallPlan ) f _ = Nothing - elaboratedInstallPlan - :: LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage) + elaboratedInstallPlan :: LogProgress ElaboratedInstallPlan elaboratedInstallPlan = flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> case planpkg of SolverInstallPlan.PreExisting pkg -> - return [InstallPlan.PreExisting (instSolverPkgIPI pkg)] + return [InstallPlan.PreExisting (WithStage (instSolverStage pkg) (instSolverPkgIPI pkg))] SolverInstallPlan.Configured pkg -> let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace" @@ -1704,13 +1706,13 @@ elaborateInstallPlan => (SolverId -> [ElaboratedPlanPackage]) -> SolverPackage UnresolvedPkgLoc -> LogProgress [ElaboratedConfiguredPackage] - elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ _ _ deps0 exe_deps0) = + elaborateSolverToComponents mapDep spkg@SolverPackage{solverPkgStage, solverPkgLibDeps, solverPkgExeDeps} = case mkComponentsGraph (elabEnabledSpec elab0) pd of Right g -> do let src_comps = componentsGraphToList g infoProgress $ hang - (text "Component graph for" <+> pretty pkgid <<>> colon) + (text "Component graph for" <+> pretty (solverId (ResolverPackage.Configured spkg))) 4 (dispComponentsWithDeps src_comps) (_, comps) <- @@ -1813,7 +1815,21 @@ elaborateInstallPlan , elabUnitId = notImpl "elabUnitId" , elabComponentId = notImpl "elabComponentId" , elabInstallDirs = notImpl "elabInstallDirs" - , elabPkgOrComp = ElabComponent (ElaboratedComponent{..}) + , elabPkgOrComp = + ElabComponent + ( ElaboratedComponent + { compSolverName + , compComponentName + , compLibDependencies + , compLinkedLibDependencies + , compExeDependencies + , compPkgConfigDependencies + , compExeDependencyPaths + , compOrderLibDependencies + , compInstantiatedWith + , compLinkedInstantiatedWith + } + ) } | otherwise = Nothing @@ -1821,7 +1837,7 @@ elaborateInstallPlan compSolverName = CD.ComponentSetup compComponentName = Nothing - dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0 + dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps solverPkgLibDeps compLibDependencies = -- MP: No idea what this function does @@ -1842,16 +1858,17 @@ elaborateInstallPlan ++ f ++ " not implemented yet" + -- Note: this function is used to configure the components in a single package (`elab`, defined in the outer scope) buildComponent :: HasCallStack - => ( ConfiguredComponentMap - , LinkedComponentMap + => ( Map PackageName (Map ComponentName (AnnotatedId ComponentId)) + , Map ComponentId (OpenUnitId, ModuleShape) , Map ComponentId FilePath ) -> Cabal.Component -> LogProgress - ( ( ConfiguredComponentMap - , LinkedComponentMap + ( ( Map PackageName (Map ComponentName (AnnotatedId ComponentId)) + , Map ComponentId (OpenUnitId, ModuleShape) , Map ComponentId FilePath ) , ElaboratedConfiguredPackage @@ -1862,19 +1879,30 @@ elaborateInstallPlan <+> quotes (text (componentNameStanza cname)) ) $ do + let lib_dep_map = Map.unionWith Map.union external_lib_cc_map cc_map + -- TODO: is cc_map correct here? + exe_dep_map = Map.unionWith Map.union external_exe_cc_map cc_map + -- 1. Configure the component, but with a place holder ComponentId. + infoProgress $ + hang (text "configuring component" <+> pretty cname) 4 $ + vcat + [ text "lib_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys lib_dep_map)) + , text "exe_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys exe_dep_map)) + ] cc0 <- toConfiguredComponent pd (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later") - (Map.unionWith Map.union external_lib_cc_map cc_map) - (Map.unionWith Map.union external_exe_cc_map cc_map) + lib_dep_map + exe_dep_map comp let do_ cid = let cid' = annotatedIdToConfiguredId . ci_ann_id $ cid in (cid', False) -- filled in later in pruneInstallPlanPhase2) - -- 2. Read out the dependencies from the ConfiguredComponent cc0 + + -- 2. Read out the dependencies from the ConfiguredComponent cc0 let compLibDependencies = -- Nub because includes can show up multiple times ordNub @@ -1882,19 +1910,59 @@ elaborateInstallPlan (\cid -> do_ cid) (cc_includes cc0) ) + + compExeDependencies :: [WithStage ConfiguredId] compExeDependencies = - map - annotatedIdToConfiguredId - (cc_exe_deps cc0) + -- External + [ WithStage (stageOf pkg) confId + | pkg <- external_exe_dep_pkgs + , let confId = configuredId pkg + , -- only executables + Just (CExeName _) <- [confCompName confId] + , confSrcId confId /= pkgid + ] + <> + -- Internal, assume the same stage + [ WithStage solverPkgStage confId + | aid <- cc_exe_deps cc0 + , let confId = annotatedIdToConfiguredId aid + , confSrcId confId == pkgid + ] + + compExeDependencyPaths :: [(WithStage ConfiguredId, FilePath)] compExeDependencyPaths = - [ (annotatedIdToConfiguredId aid', path) - | aid' <- cc_exe_deps cc0 - , Just paths <- [Map.lookup (ann_id aid') exe_map1] - , path <- paths + -- External + [ (WithStage solverPkgStage confId, path) + | pkg <- external_exe_dep_pkgs + , let confId = configuredId pkg + , confSrcId confId /= pkgid + , -- only executables + Just (CExeName _) <- [confCompName confId] + , path <- planPackageExePaths pkg ] - compInstantiatedWith = Map.empty - compLinkedInstantiatedWith = Map.empty - elab_comp = ElaboratedComponent{..} + <> + -- Internal, assume the same stage + [ (WithStage solverPkgStage confId, path) + | aid <- cc_exe_deps cc0 + , let confId = annotatedIdToConfiguredId aid + , confSrcId confId == pkgid + , Just paths <- [Map.lookup (ann_id aid) exe_map1] + , path <- paths + ] + + elab_comp = + ElaboratedComponent + { compSolverName + , compComponentName + , compLibDependencies + , compLinkedLibDependencies + , compExeDependencies + , compPkgConfigDependencies + , compExeDependencyPaths + , compOrderLibDependencies + , compInstantiatedWith = Map.empty + , compLinkedInstantiatedWith = Map.empty + } -- 3. Construct a preliminary ElaboratedConfiguredPackage, -- and use this to compute the component ID. Fix up cc_id @@ -1919,22 +1987,30 @@ elaborateInstallPlan elab1 -- knot tied ) cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} - infoProgress $ dispConfiguredComponent cc + + infoProgress $ hang (text "configured component:") 4 (dispConfiguredComponent cc) -- 4. Perform mix-in linking let lookup_uid def_uid = case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of Just full -> full Nothing -> error ("lookup_uid: " ++ prettyShow def_uid) + lc_dep_map = Map.union external_lc_map lc_map lc <- toLinkedComponent verbosity False + -- \^ whether there are any "promised" package dependencies which we won't find already installed lookup_uid + -- \^ full db (elabPkgSourceId elab0) - (Map.union external_lc_map lc_map) + -- \^ the source package id + lc_dep_map + -- \^ linked component map cc - infoProgress $ dispLinkedComponent lc + -- \^ configured component + + infoProgress $ hang (text "linked component:") 4 (dispLinkedComponent lc) -- NB: elab is setup to be the correct form for an -- indefinite library, or a definite library with no holes. -- We will modify it in 'instantiateInstallPlan' to handle @@ -1984,23 +2060,15 @@ elaborateInstallPlan compComponentName = Just cname compSolverName = CD.componentNameToComponent cname - -- NB: compLinkedLibDependencies and - -- compOrderLibDependencies are defined when we define - -- 'elab'. - external_lib_dep_sids = CD.select (== compSolverName) deps0 - external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 + -- External dependencies. I.e. dependencies of the component on components of other packages. + external_lib_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgLibDeps - external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids - external_exe_dep_pkgs = - concatMap mapDep $ - ordNubBy (pkgName . packageId) $ - external_exe_dep_sids + external_exe_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgExeDeps external_exe_map = Map.fromList $ - [ (getComponentId pkg, paths) + [ (getComponentId pkg, planPackageExePaths pkg) | pkg <- external_exe_dep_pkgs - , let paths = planPackageExePaths pkg ] exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map @@ -2013,7 +2081,7 @@ elaborateInstallPlan external_lc_map = Map.fromList $ map mkShapeMapping $ - external_lib_dep_pkgs ++ concatMap mapDep external_exe_dep_sids + external_lib_dep_pkgs ++ external_exe_dep_pkgs compPkgConfigDependencies = [ ( pn @@ -2104,14 +2172,29 @@ elaborateInstallPlan elaborationWarnings return elab where - (elab0@ElaboratedConfiguredPackage{..}, elaborationWarnings) = - elaborateSolverToCommon pkg + elab0@ElaboratedConfiguredPackage + { elabPkgSourceHash + , elabStanzasRequested + , elabStage + } = elaborateSolverToCommon pkg elab1 = elab0 { elabUnitId = newSimpleUnitId pkgInstalledId , elabComponentId = pkgInstalledId - , elabPkgOrComp = ElabPackage $ ElaboratedPackage{..} + , elabPkgOrComp = + ElabPackage $ + ElaboratedPackage + { pkgStage = elabStage + , pkgInstalledId + , pkgLibDependencies + , pkgDependsOnSelfLib + , pkgExeDependencies + , pkgExeDependencyPaths + , pkgPkgConfigDependencies + , pkgStanzasEnabled + , pkgWhyNotPerComponent + } , elabModuleShape = modShape } @@ -2144,18 +2227,17 @@ elaborateInstallPlan -- Need to filter out internal dependencies, because they don't -- correspond to anything real anymore. - isExt confid = confSrcId confid /= pkgid - filterExt = filter isExt - - filterExt' :: [(ConfiguredId, a)] -> [(ConfiguredId, a)] - filterExt' = filter (isExt . fst) + isExternal confid = confSrcId confid /= pkgid + isExternal' (WithStage stage confId) = stage /= elabStage || isExternal confId pkgLibDependencies = - buildComponentDeps (filterExt' . compLibDependencies) + buildComponentDeps (filter (isExternal . fst) . compLibDependencies) + pkgExeDependencies = - buildComponentDeps (filterExt . compExeDependencies) + buildComponentDeps (filter isExternal' . compExeDependencies) + pkgExeDependencyPaths = - buildComponentDeps (filterExt' . compExeDependencyPaths) + buildComponentDeps (filter (isExternal' . fst) . compExeDependencyPaths) -- TODO: Why is this flat? pkgPkgConfigDependencies = @@ -2654,7 +2736,7 @@ shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of -- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool -matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p) +matchPlanPkg p = InstallPlan.foldPlanPackage (\(WithStage _stage ipkg) -> p (ipiComponentName ipkg)) (matchElabPkg p) -- | Get the appropriate 'ComponentName' which identifies an installed -- component. @@ -2680,15 +2762,14 @@ matchElabPkg p elab = (p . componentName) (Cabal.pkgBuildableComponents (elabPkgDescription elab)) --- | Given an 'ElaboratedPlanPackage', generate the mapping from 'PackageName' --- and 'ComponentName' to the 'ComponentId' that should be used --- in this case. +-- | Extract from an 'ElaboratedPlanPackage' a mapping from package and component name +-- to a component id. mkCCMapping :: ElaboratedPlanPackage -> (PackageName, Map ComponentName (AnnotatedId ComponentId)) mkCCMapping = InstallPlan.foldPlanPackage - ( \ipkg -> + ( \(WithStage _ ipkg) -> ( packageName ipkg , Map.singleton (ipiComponentName ipkg) @@ -2712,12 +2793,14 @@ mkCCMapping = , case elabPkgOrComp elab of ElabComponent comp -> case compComponentName comp of + -- This should be an error because we cannot explicitly depend on a setup Nothing -> Map.empty Just n -> Map.singleton n (mk_aid n) ElabPackage _ -> Map.fromList $ map (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn)) + -- Shouldn't this be available in ElaboratedPackage? (Cabal.pkgBuildableComponents (elabPkgDescription elab)) ) @@ -2731,9 +2814,8 @@ mkShapeMapping dpkg = where (dcid, shape) = InstallPlan.foldPlanPackage - -- Uses Monad (->) - (liftM2 (,) IPI.installedComponentId shapeInstalledPackage) - (liftM2 (,) elabComponentId elabModuleShape) + (\(WithStage _stage ipkg) -> (IPI.installedComponentId ipkg, shapeInstalledPackage ipkg)) + (\elab -> (elabComponentId elab, elabModuleShape elab)) dpkg indef_uid = IndefFullUnitId @@ -2781,7 +2863,7 @@ type InstM a = State InstS a getComponentId :: ElaboratedPlanPackage -> ComponentId -getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg +getComponentId (InstallPlan.PreExisting (WithStage _stage dipkg)) = IPI.installedComponentId dipkg getComponentId (InstallPlan.Configured elab) = elabComponentId elab getComponentId (InstallPlan.Installed elab) = elabComponentId elab @@ -2791,6 +2873,17 @@ extractElabBuildStyle extractElabBuildStyle (InstallPlan.Configured elab) = elabBuildStyle elab extractElabBuildStyle _ = BuildAndInstall +-- When using Backpack, packages can have "holes" that need to be filled with concrete implementations. + +-- This function takes an initial install plan and creates additional plan entries for all the instantiated versions of packages + +-- The function deals with: + +-- Indefinite packages - Packages with holes/signatures that need to be filled +-- Instantiated packages - Concrete packages created by filling holes with specific implementations +-- Component IDs - Unique identifiers for components (libraries, executables etc.) +-- Unit IDs - Identifiers that track how holes are filled in instantiated packages + -- instantiateInstallPlan is responsible for filling out an InstallPlan -- with all of the extra Configured packages that would be generated by -- recursively instantiating the dependencies of packages. @@ -3115,15 +3208,17 @@ availableTargets :: ElaboratedInstallPlan -> Map (PackageId, ComponentName) - [AvailableTarget (UnitId, ComponentName)] + [AvailableTarget (WithStage UnitId, ComponentName)] availableTargets installPlan = let rs = [ (pkgid, cname, fake, target) | pkg <- InstallPlan.toList installPlan - , (pkgid, cname, fake, target) <- case pkg of + , (stage, pkgid, cname, fake, target) <- case pkg of InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg InstallPlan.Installed elab -> availableSourceTargets elab InstallPlan.Configured elab -> availableSourceTargets elab + , -- Only host stage can be explicitly requested by the user + stage == Host ] in Map.union ( Map.fromListWith @@ -3146,27 +3241,29 @@ availableTargets installPlan = -- more details on this fake stuff is about. availableInstalledTargets - :: IPI.InstalledPackageInfo - -> [ ( PackageId + :: WithStage IPI.InstalledPackageInfo + -> [ ( Stage + , PackageId , ComponentName , Bool - , AvailableTarget (UnitId, ComponentName) + , AvailableTarget (WithStage UnitId, ComponentName) ) ] -availableInstalledTargets ipkg = +availableInstalledTargets (WithStage stage ipkg) = let unitid = installedUnitId ipkg cname = CLibName LMainLibName - status = TargetBuildable (unitid, cname) TargetRequestedByDefault + status = TargetBuildable (WithStage stage unitid, cname) TargetRequestedByDefault target = AvailableTarget (packageId ipkg) cname status False fake = False - in [(packageId ipkg, cname, fake, target)] + in [(stage, IPI.sourcePackageId ipkg, cname, fake, target)] availableSourceTargets :: ElaboratedConfiguredPackage - -> [ ( PackageId + -> [ ( Stage + , PackageId , ComponentName , Bool - , AvailableTarget (UnitId, ComponentName) + , AvailableTarget (WithStage UnitId, ComponentName) ) ] availableSourceTargets elab = @@ -3200,7 +3297,7 @@ availableSourceTargets elab = -- map (thus eliminating the duplicates) and then we overlay that map with -- the normal buildable targets. (This is done above in 'availableTargets'.) -- - [ (packageId elab, cname, fake, target) + [ (elabStage elab, elabPkgSourceId elab, cname, fake, target) | component <- pkgComponents (elabPkgDescription elab) , let cname = componentName component status = componentAvailableTargetStatus component @@ -3234,7 +3331,7 @@ availableSourceTargets elab = /= Just cname componentAvailableTargetStatus - :: Component -> AvailableTargetStatus (UnitId, ComponentName) + :: Component -> AvailableTargetStatus (WithStage UnitId, ComponentName) componentAvailableTargetStatus component = case componentOptionalStanza $ CD.componentNameToComponent cname of -- it is not an optional stanza, so a library, exe or foreign lib @@ -3242,7 +3339,7 @@ availableSourceTargets elab = | not buildable -> TargetNotBuildable | otherwise -> TargetBuildable - (elabUnitId elab, cname) + (WithStage (elabStage elab) (elabUnitId elab), cname) TargetRequestedByDefault -- it is not an optional stanza, so a testsuite or benchmark Just stanza -> @@ -3255,11 +3352,11 @@ availableSourceTargets elab = _ | not buildable -> TargetNotBuildable (Just True, True) -> TargetBuildable - (elabUnitId elab, cname) + (WithStage (elabStage elab) (elabUnitId elab), cname) TargetRequestedByDefault (Nothing, True) -> TargetBuildable - (elabUnitId elab, cname) + (WithStage (elabStage elab) (elabUnitId elab), cname) TargetNotRequestedByDefault (Just True, False) -> error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname @@ -3370,7 +3467,7 @@ data TargetAction pruneInstallPlanToTargets :: HasCallStack => TargetAction - -> Map UnitId [ComponentTarget] + -> Map (Graph.Key ElaboratedPlanPackage) [ComponentTarget] -> ElaboratedInstallPlan -> ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = @@ -3391,16 +3488,16 @@ pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = -- -- For 'ElaboratedComponent', this the cached unit IDs always -- coincide with the real thing. -data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId] +data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [WithStage UnitId] instance Package PrunedPackage where packageId (PrunedPackage elab _) = packageId elab instance HasUnitId PrunedPackage where - installedUnitId = Graph.nodeKey + installedUnitId (PrunedPackage elab _) = installedUnitId elab instance Graph.IsNode PrunedPackage where - type Key PrunedPackage = UnitId + type Key PrunedPackage = WithStage UnitId nodeKey (PrunedPackage elab _) = Graph.nodeKey elab nodeNeighbors (PrunedPackage _ deps) = deps @@ -3411,7 +3508,7 @@ fromPrunedPackage (PrunedPackage elab _) = elab -- This is required before we can prune anything. setRootTargets :: TargetAction - -> Map UnitId [ComponentTarget] + -> Map (Graph.Key ElaboratedPlanPackage) [ComponentTarget] -> [ElaboratedPlanPackage] -> [ElaboratedPlanPackage] setRootTargets targetAction perPkgTargetsMap = @@ -3424,7 +3521,7 @@ setRootTargets targetAction perPkgTargetsMap = -- dependencies. Those comes in the second pass once we know the rev deps. -- setElabBuildTargets elab = - case ( Map.lookup (installedUnitId elab) perPkgTargetsMap + case ( Map.lookup (Graph.nodeKey elab) perPkgTargetsMap , targetAction ) of (Nothing, _) -> elab @@ -3475,7 +3572,7 @@ pruneInstallPlanPass1 pkgs -- otherwise we'll do less | otherwise = pruned_packages where - pkgs' :: [InstallPlan.GenericPlanPackage IPI.InstalledPackageInfo PrunedPackage] + pkgs' :: [InstallPlan.GenericPlanPackage (WithStage IPI.InstalledPackageInfo) PrunedPackage] pkgs' = map (mapConfiguredPackage prune) pkgs prune :: ElaboratedConfiguredPackage -> PrunedPackage @@ -3485,8 +3582,8 @@ pruneInstallPlanPass1 pkgs graph = Graph.fromDistinctList pkgs' - roots :: [UnitId] - roots = mapMaybe find_root pkgs' + roots :: [Graph.Key ElaboratedPlanPackage] + roots = map Graph.nodeKey (filter is_root pkgs') -- Make a closed graph by calculating the closure from the roots pruned_packages :: [ElaboratedPlanPackage] @@ -3525,25 +3622,21 @@ pruneInstallPlanPass1 pkgs | anyMultiReplTarget = map (mapConfiguredPackage add_repl_target) (Graph.toList closed_graph) | otherwise = Graph.toList closed_graph - is_root :: PrunedPackage -> Maybe UnitId - is_root (PrunedPackage elab _) = - if not $ - and - [ null (elabConfigureTargets elab) - , null (elabBuildTargets elab) - , null (elabTestTargets elab) - , null (elabBenchTargets elab) - , null (elabReplTarget elab) - , null (elabHaddockTargets elab) - ] - then Just (installedUnitId elab) - else Nothing - - find_root (InstallPlan.Configured pkg) = is_root pkg - -- When using the extra-packages stanza we need to - -- look at installed packages as well. - find_root (InstallPlan.Installed pkg) = is_root pkg - find_root _ = Nothing + is_root :: InstallPlan.GenericPlanPackage (WithStage IPI.InstalledPackageInfo) PrunedPackage -> Bool + is_root = + foldPlanPackage + (const False) + ( \(PrunedPackage elab _) -> + not $ + and + [ null (elabConfigureTargets elab) + , null (elabBuildTargets elab) + , null (elabTestTargets elab) + , null (elabBenchTargets elab) + , null (elabReplTarget elab) + , null (elabHaddockTargets elab) + ] + ) -- Note [Sticky enabled testsuites] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3593,7 +3686,7 @@ pruneInstallPlanPass1 pkgs -- the optional stanzas and we'll make further tweaks to the optional -- stanzas in the next pass. -- - pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId] + pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [Graph.Key ElaboratedConfiguredPackage] pruneOptionalDependencies elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent _} = InstallPlan.depends elab -- no pruning pruneOptionalDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} = @@ -3624,7 +3717,7 @@ pruneInstallPlanPass1 pkgs availablePkgs = Set.fromList - [ installedUnitId pkg + [ Graph.nodeKey pkg | InstallPlan.PreExisting pkg <- pkgs ] @@ -3660,7 +3753,7 @@ into the repl to uphold the closure property. -- all of the deps needed for the test suite, we go ahead and -- enable it always. optionalStanzasWithDepsAvailable - :: Set UnitId + :: Set (Graph.Key ElaboratedPlanPackage) -> ElaboratedConfiguredPackage -> ElaboratedPackage -> OptionalStanzaSet @@ -3668,8 +3761,7 @@ optionalStanzasWithDepsAvailable availablePkgs elab pkg = optStanzaSetFromList [ stanza | stanza <- optStanzaSetToList (elabStanzasAvailable elab) - , let deps :: [UnitId] - deps = + , let deps = CD.select (optionalStanzaDeps stanza) -- TODO: probably need to select other @@ -3762,7 +3854,7 @@ pruneInstallPlanPass2 pkgs = libTargetsRequiredForRevDeps = [ c - | installedUnitId elab `Set.member` hasReverseLibDeps + | Graph.nodeKey elab `Set.member` hasReverseLibDeps , let c = ComponentTarget (CLibName Cabal.defaultLibName) WholeComponent , -- Don't enable building for anything which is being build in memory elabBuildStyle elab /= BuildInplaceOnly InMemory @@ -3777,11 +3869,10 @@ pruneInstallPlanPass2 pkgs = elabPkgSourceId elab ) WholeComponent - | installedUnitId elab `Set.member` hasReverseExeDeps + | Graph.nodeKey elab `Set.member` hasReverseExeDeps ] - availablePkgs :: Set UnitId - availablePkgs = Set.fromList (map installedUnitId pkgs) + availablePkgs = Set.fromList (map Graph.nodeKey pkgs) inMemoryTargets :: Set ConfiguredId inMemoryTargets = do @@ -3791,7 +3882,6 @@ pruneInstallPlanPass2 pkgs = , BuildInplaceOnly InMemory <- [elabBuildStyle pkg] ] - hasReverseLibDeps :: Set UnitId hasReverseLibDeps = Set.fromList [ depid @@ -3799,7 +3889,6 @@ pruneInstallPlanPass2 pkgs = , depid <- elabOrderLibDependencies pkg ] - hasReverseExeDeps :: Set UnitId hasReverseExeDeps = Set.fromList [ depid @@ -3827,7 +3916,7 @@ mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = -- This is not always possible. pruneInstallPlanToDependencies :: HasCallStack - => Set UnitId + => Set (Graph.Key ElaboratedPlanPackage) -> ElaboratedInstallPlan -> Either CannotPruneDependencies @@ -3841,7 +3930,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan = $ fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) . checkBrokenDeps . Graph.fromDistinctList - . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) + . filter (\pkg -> Graph.nodeKey pkg `Set.notMember` pkgTargets) . InstallPlan.toList $ installPlan where @@ -3927,7 +4016,7 @@ setupHsScriptOptions , usePackageIndex = Nothing , useDependencies = [ (uid, srcid) - | (ConfiguredId srcid (Just (CLibName LMainLibName)) uid, _) <- + | (WithStage _ (ConfiguredId srcid (Just (CLibName LMainLibName)) uid), _) <- elabSetupDependencies elab ] , useDependenciesExclusive = True @@ -4068,7 +4157,7 @@ setupHsConfigureFlags -> m Cabal.ConfigFlags setupHsConfigureFlags mkSymbolicPath - plan + _plan (ReadyPackage elab@ElaboratedConfiguredPackage{..}) sharedConfig configCommonFlags = do @@ -4150,29 +4239,33 @@ setupHsConfigureFlags -- dependencies which should NOT be fed in here (also you don't have -- enough info anyway) -- + -- FIXME: stage? configDependencies = [ cidToGivenComponent cid - | (cid, is_internal) <- elabLibDependencies elab + | (WithStage _stage cid, is_internal) <- elabLibDependencies elab , not is_internal ] + -- FIXME: stage? configPromisedDependencies = [ cidToPromisedComponent cid - | (cid, is_internal) <- elabLibDependencies elab + | (WithStage _stage cid, is_internal) <- elabLibDependencies elab , is_internal ] + -- FIXME: stage? configConstraints = case elabPkgOrComp of ElabPackage _ -> [ thisPackageVersionConstraint srcid - | (ConfiguredId srcid _ _uid, _) <- elabLibDependencies elab + | (WithStage _stage (ConfiguredId srcid _ _uid), _) <- elabLibDependencies elab ] ElabComponent _ -> [] configTests = case elabPkgOrComp of ElabPackage pkg -> toFlag (TestStanzas `optStanzaSetMember` pkgStanzasEnabled pkg) ElabComponent _ -> mempty + configBenchmarks = case elabPkgOrComp of ElabPackage pkg -> toFlag (BenchStanzas `optStanzaSetMember` pkgStanzasEnabled pkg) ElabComponent _ -> mempty @@ -4194,7 +4287,9 @@ setupHsConfigureFlags Just _ -> error "non-library dependency" Nothing -> LMainLibName - configCoverageFor = determineCoverageFor elab plan + -- FIXME: whathever + -- configCoverageFor = determineCoverageFor elab plan + configCoverageFor = NoFlag cidToPromisedComponent :: ConfiguredId -> PromisedComponent cidToPromisedComponent (ConfiguredId srcid mb_cn cid) = @@ -4458,33 +4553,39 @@ packageHashInputs ) = PackageHashInputs { pkgHashPkgId = packageId elab - , pkgHashComponent = - case elabPkgOrComp elab of - ElabPackage _ -> Nothing - ElabComponent comp -> Just (compSolverName comp) + , pkgHashComponent , pkgHashSourceHash = srchash , pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab) - , pkgHashDirectDeps = - case elabPkgOrComp elab of - ElabPackage (ElaboratedPackage{..}) -> - Set.fromList $ - [ confInstId dep - | (dep, _) <- CD.select relevantDeps pkgLibDependencies - ] - ++ [ confInstId dep - | dep <- CD.select relevantDeps pkgExeDependencies - ] - ElabComponent comp -> - Set.fromList - ( map - confInstId - ( map fst (compLibDependencies comp) - ++ compExeDependencies comp - ) - ) + , pkgHashLibDeps + , pkgHashExeDeps , pkgHashOtherConfig = packageHashConfigInputs pkgshared elab } where + pkgHashComponent = + case elabPkgOrComp elab of + ElabPackage _ -> Nothing + ElabComponent comp -> Just (compSolverName comp) + pkgHashLibDeps = + case elabPkgOrComp elab of + ElabPackage (ElaboratedPackage{..}) -> + Set.fromList + [confInstId c | (c, _promised) <- CD.select relevantDeps pkgLibDependencies] + ElabComponent comp -> + Set.fromList + [confInstId c | (c, _promised) <- compLibDependencies comp] + pkgHashExeDeps = + case elabPkgOrComp elab of + ElabPackage (ElaboratedPackage{..}) -> + Set.fromList + [ confInstId c + | WithStage _stage c <- CD.select relevantDeps pkgExeDependencies + ] + ElabComponent comp -> + Set.fromList + [ confInstId c + | WithStage _stage c <- compExeDependencies comp + ] + -- Obviously the main deps are relevant relevantDeps CD.ComponentLib = True relevantDeps (CD.ComponentSubLib _) = True @@ -4602,46 +4703,47 @@ inplaceBinRoot layout config package = distBuildDirectory layout (elabDistDirParams config package) "build" --------------------------------------------------------------------------------- --- Configure --coverage-for flags +-- FIXME: whathever +-- -------------------------------------------------------------------------------- +-- -- Configure --coverage-for flags -- The list of non-pre-existing libraries without module holes, i.e. the -- main library and sub-libraries components of all the local packages in -- the project that are dependencies of the components being built and that do -- not require instantiations or are instantiations. -determineCoverageFor - :: ElaboratedConfiguredPackage - -- ^ The package or component being configured - -> ElaboratedInstallPlan - -> Flag [UnitId] -determineCoverageFor configuredPkg plan = - Flag - $ mapMaybe - ( \case - InstallPlan.Installed elab - | shouldCoverPkg elab -> Just $ elabUnitId elab - InstallPlan.Configured elab - | shouldCoverPkg elab -> Just $ elabUnitId elab - _ -> Nothing - ) - $ Graph.toList - $ InstallPlan.toGraph plan - where - libDeps = elabLibDependencies configuredPkg - shouldCoverPkg elab@ElaboratedConfiguredPackage{elabModuleShape, elabPkgSourceId = pkgSID, elabLocalToProject} = - elabLocalToProject - && not (isIndefiniteOrInstantiation elabModuleShape) - -- TODO(#9493): We can only cover libraries in the same package - -- as the testsuite - && elabPkgSourceId configuredPkg == pkgSID - -- Libraries only! We don't cover testsuite modules, so we never need - -- the paths to their mix dirs. Furthermore, we do not install testsuites... - && maybe False (\case CLibName{} -> True; CNotLibName{} -> False) (elabComponentName elab) - -- We only want coverage for libraries which are dependencies of the given one - && pkgSID `elem` map (confSrcId . fst) libDeps - - isIndefiniteOrInstantiation :: ModuleShape -> Bool - isIndefiniteOrInstantiation = not . Set.null . modShapeRequires +-- determineCoverageFor +-- :: ElaboratedConfiguredPackage +-- -- ^ The package or component being configured +-- -> ElaboratedInstallPlan +-- -> Flag [UnitId] +-- determineCoverageFor configuredPkg plan = +-- Flag +-- $ mapMaybe +-- ( \case +-- InstallPlan.Installed elab +-- | shouldCoverPkg elab -> Just $ elabUnitId elab +-- InstallPlan.Configured elab +-- | shouldCoverPkg elab -> Just $ elabUnitId elab +-- _ -> Nothing +-- ) +-- $ Graph.toList +-- $ InstallPlan.toGraph plan +-- where +-- libDeps = elabLibDependencies configuredPkg +-- shouldCoverPkg elab@ElaboratedConfiguredPackage{elabModuleShape, elabPkgSourceId = pkgSID, elabLocalToProject} = +-- elabLocalToProject +-- && not (isIndefiniteOrInstantiation elabModuleShape) +-- -- TODO(#9493): We can only cover libraries in the same package +-- -- as the testsuite +-- && elabPkgSourceId configuredPkg == pkgSID +-- -- Libraries only! We don't cover testsuite modules, so we never need +-- -- the paths to their mix dirs. Furthermore, we do not install testsuites... +-- && maybe False (\case CLibName{} -> True; CNotLibName{} -> False) (elabComponentName elab) +-- -- We only want coverage for libraries which are dependencies of the given one +-- && pkgSID `elem` map (confSrcId . fst) libDeps + +-- isIndefiniteOrInstantiation :: ModuleShape -> Bool +-- isIndefiniteOrInstantiation = not . Set.null . modShapeRequires -- While we can talk to older Cabal versions (we need to be able to -- do so for custom Setup scripts that require older Cabal lib diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs index afacc83f06c..d2a5f186e18 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs @@ -6,6 +6,7 @@ module Distribution.Client.ProjectPlanning.Stage ( WithStage (..) , Stage (..) , HasStage (..) + , Staged (..) ) where import Distribution.Client.Compat.Prelude @@ -14,7 +15,7 @@ import Prelude () import Distribution.Client.Types.ConfiguredId (HasConfiguredId (..)) import Distribution.Compat.Graph (IsNode (..)) import Distribution.Package (HasUnitId (..), Package (..)) -import Distribution.Solver.Types.Stage (Stage (..)) +import Distribution.Solver.Types.Stage (Stage (..), Staged (..)) import Text.PrettyPrint (colon) -- FIXME: blaaah diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 606db4b0a64..fc670b0a3bd 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} @@ -14,6 +15,7 @@ module Distribution.Client.ProjectPlanning.Types -- * Elaborated install plan types , ElaboratedInstallPlan , normaliseConfiguredPackage + , ElaboratedInstalledPackageInfo , ElaboratedConfiguredPackage (..) , showElaboratedInstallPlan , elabDistDirParams @@ -65,6 +67,8 @@ module Distribution.Client.ProjectPlanning.Types , Stage (..) , Staged (..) , WithStage (..) + , withStage + , HasStage (..) -- * Setup script , SetupScriptStyle (..) @@ -130,10 +134,9 @@ 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 Data.Monoid as Mon import qualified Distribution.Compat.Graph as Graph import System.FilePath (()) -import Text.PrettyPrint (hsep, parens, text) +import Text.PrettyPrint (colon, hsep, parens, text) -- | The combination of an elaborated install plan plus a -- 'ElaboratedSharedConfig' contains all the details necessary to be able @@ -143,14 +146,27 @@ import Text.PrettyPrint (hsep, parens, text) -- connections). type ElaboratedInstallPlan = GenericInstallPlan - InstalledPackageInfo + ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage type ElaboratedPlanPackage = GenericPlanPackage - InstalledPackageInfo + ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage +instance HasStage ElaboratedPlanPackage where + stageOf (PreExisting ipkg) = stageOf ipkg + stageOf (Configured srcpkg) = stageOf srcpkg + stageOf (Installed srcpkg) = stageOf srcpkg + +instance HasStage ElaboratedPackage where + stageOf = pkgStage + +withStage :: HasStage a => a -> WithStage a +withStage a = WithStage (stageOf a) a + +type ElaboratedInstalledPackageInfo = WithStage InstalledPackageInfo + -- | User-friendly display string for an 'ElaboratedPlanPackage'. elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String elabPlanPackageName verbosity (PreExisting ipkg) @@ -164,6 +180,7 @@ elabPlanPackageName verbosity (Installed elab) = showElaboratedInstallPlan :: ElaboratedInstallPlan -> String showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode where + showNode :: ElaboratedPlanPackage -> InstallPlan.ShowPlanNode showNode pkg = InstallPlan.ShowPlanNode { InstallPlan.showPlanHerald = herald @@ -187,7 +204,10 @@ showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode installed_deps = map pretty . nodeNeighbors - local_deps cfg = [(if internal then text "+" else mempty) <> pretty (confInstId uid) | (uid, internal) <- elabLibDependencies cfg] + local_deps cfg = + [ (if internal then text "+" else mempty) <> pretty s <> colon <> pretty (confInstId uid) + | (WithStage s uid, internal) <- elabLibDependencies cfg + ] -- TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle -- even platform and compiler could be different if we're building things @@ -501,10 +521,14 @@ instance HasUnitId ElaboratedConfiguredPackage where installedUnitId = elabUnitId instance IsNode ElaboratedConfiguredPackage where - type Key ElaboratedConfiguredPackage = UnitId - nodeKey = elabUnitId + type Key ElaboratedConfiguredPackage = WithStage UnitId + nodeKey elab = WithStage (elabStage elab) (elabUnitId elab) nodeNeighbors = elabOrderDependencies +instance HasStage ElaboratedConfiguredPackage where + stageOf :: ElaboratedConfiguredPackage -> Stage + stageOf = elabStage + instance Binary ElaboratedConfiguredPackage instance Structured ElaboratedConfiguredPackage @@ -563,45 +587,52 @@ elabDistDirParams shared elab = -- 'nodeNeighbors'. -- -- NB: this method DOES include setup deps. -elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderDependencies elab = - case elabPkgOrComp elab of - -- Important not to have duplicates: otherwise InstallPlan gets - -- confused. - ElabPackage pkg -> ordNub (fold (pkgOrderDependencies pkg)) - ElabComponent comp -> compOrderDependencies comp + elabOrderLibDependencies elab ++ elabOrderExeDependencies elab -- | Like 'elabOrderDependencies', but only returns dependencies on -- libraries. -elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderLibDependencies elab = case elabPkgOrComp elab of ElabPackage pkg -> - map (newSimpleUnitId . confInstId) $ - ordNub $ - fold (map fst <$> pkgLibDependencies pkg) - ElabComponent comp -> compOrderLibDependencies comp + ordNub + [ WithStage (pkgStage pkg) (newSimpleUnitId (confInstId cid)) + | cid <- CD.flatDeps (map fst <$> pkgLibDependencies pkg) + ] + ElabComponent comp -> + [ WithStage (elabStage elab) c + | c <- compOrderLibDependencies comp + ] -- | The library dependencies (i.e., the libraries we depend on, NOT -- the dependencies of the library), NOT including setup dependencies. -- These are passed to the @Setup@ script via @--dependency@ or @--promised-dependency@. -elabLibDependencies :: ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)] +elabLibDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)] elabLibDependencies elab = case elabPkgOrComp elab of - ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) - ElabComponent comp -> compLibDependencies comp + ElabPackage pkg -> + ordNub + [ (WithStage (pkgStage pkg) cid, promised) + | (cid, promised) <- CD.nonSetupDeps (pkgLibDependencies pkg) + ] + ElabComponent comp -> + [ (WithStage (elabStage elab) c, promised) + | (c, promised) <- compLibDependencies comp + ] -- | Like 'elabOrderDependencies', but only returns dependencies on -- executables. (This coincides with 'elabExeDependencies'.) -elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderExeDependencies = - map newSimpleUnitId . elabExeDependencies + fmap (fmap newSimpleUnitId) . elabExeDependencies -- | The executable dependencies (i.e., the executables we depend on); -- these are the executables we must add to the PATH before we invoke -- the setup script. -elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId] -elabExeDependencies elab = map confInstId $ +elabExeDependencies :: ElaboratedConfiguredPackage -> [WithStage ComponentId] +elabExeDependencies elab = fmap (fmap confInstId) $ case elabPkgOrComp elab of ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) ElabComponent comp -> compExeDependencies comp @@ -619,10 +650,15 @@ elabExeDependencyPaths elab = -- | The setup dependencies (the library dependencies of the setup executable; -- note that it is not legal for setup scripts to have executable -- dependencies at the moment.) -elabSetupDependencies :: ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)] +elabSetupDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)] elabSetupDependencies elab = case elabPkgOrComp elab of - ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg) + -- FIXME: this should be wrong. Setup and its dependencies can be on a different stage. Where did that information go? + ElabPackage pkg -> + ordNub + [ (WithStage (pkgStage pkg) cid, promised) + | (cid, promised) <- CD.setupDeps (pkgLibDependencies pkg) + ] -- TODO: Custom setups not supported for components yet. When -- they are, need to do this differently ElabComponent _ -> [] @@ -695,12 +731,12 @@ data ElaboratedComponent = ElaboratedComponent -- dependencies. , compInstantiatedWith :: Map ModuleName Module , compLinkedInstantiatedWith :: Map ModuleName OpenModule - , compExeDependencies :: [ConfiguredId] + , compExeDependencies :: [WithStage ConfiguredId] -- ^ The executable dependencies of this component (including -- internal executables). , compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)] -- ^ The @pkg-config@ dependencies of the component - , compExeDependencyPaths :: [(ConfiguredId, FilePath)] + , compExeDependencyPaths :: [(WithStage ConfiguredId, FilePath)] -- ^ The paths all our executable dependencies will be installed -- to once they are installed. , compOrderLibDependencies :: [UnitId] @@ -716,18 +752,9 @@ data ElaboratedComponent = ElaboratedComponent instance Binary ElaboratedComponent instance Structured ElaboratedComponent --- | See 'elabOrderDependencies'. -compOrderDependencies :: ElaboratedComponent -> [UnitId] -compOrderDependencies comp = - compOrderLibDependencies comp - ++ compOrderExeDependencies comp - --- | See 'elabOrderExeDependencies'. -compOrderExeDependencies :: ElaboratedComponent -> [UnitId] -compOrderExeDependencies = map (newSimpleUnitId . confInstId) . compExeDependencies - data ElaboratedPackage = ElaboratedPackage - { pkgInstalledId :: InstalledPackageId + { pkgStage :: Stage + , pkgInstalledId :: InstalledPackageId , pkgLibDependencies :: ComponentDeps [(ConfiguredId, Bool)] -- ^ The exact dependencies (on other plan packages) -- The boolean value indicates whether the dependency is a promised dependency @@ -737,9 +764,9 @@ data ElaboratedPackage = ElaboratedPackage -- defined library. These are used by 'elabRequiresRegistration', -- to determine if a user-requested build is going to need -- a library registration - , pkgExeDependencies :: ComponentDeps [ConfiguredId] + , pkgExeDependencies :: ComponentDeps [WithStage ConfiguredId] -- ^ Dependencies on executable packages. - , pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)] + , pkgExeDependencyPaths :: ComponentDeps [(WithStage ConfiguredId, FilePath)] -- ^ Paths where executable dependencies live. , pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)] -- ^ Dependencies on @pkg-config@ packages. @@ -800,10 +827,14 @@ whyNotPerComponent = \case -- | See 'elabOrderDependencies'. This gives the unflattened version, -- which can be useful in some circumstances. -pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId] +pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId] pkgOrderDependencies pkg = - fmap (map (newSimpleUnitId . confInstId)) (map fst <$> pkgLibDependencies pkg) - `Mon.mappend` fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg) + fmap + (map (\(cid, _) -> WithStage (pkgStage pkg) (newSimpleUnitId $ confInstId cid))) + (pkgLibDependencies pkg) + <> fmap + (map (fmap (newSimpleUnitId . confInstId))) + (pkgExeDependencies pkg) -- | This is used in the install plan to indicate how the package will be -- built. diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 55346020a7c..2f1262961f2 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -957,11 +957,11 @@ testTargetProblemsBuild config reportSubCase = do CmdBuild.selectPackageTargets CmdBuild.selectComponentTarget [mkTargetPackage "p-0.1"] - [ ("p-0.1-inplace", (CLibName LMainLibName)) - , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") + [ (WithStage Host "p-0.1-inplace", (CLibName LMainLibName)) + , (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe") + , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp") ] reportSubCase "disabled component kinds" @@ -983,9 +983,9 @@ testTargetProblemsBuild config reportSubCase = do CmdBuild.selectPackageTargets CmdBuild.selectComponentTarget [mkTargetPackage "p-0.1"] - [ ("p-0.1-inplace", (CLibName LMainLibName)) - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") + [ (WithStage Host "p-0.1-inplace", (CLibName LMainLibName)) + , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe") + , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp") ] reportSubCase "requested component kinds" @@ -1000,8 +1000,8 @@ testTargetProblemsBuild config reportSubCase = do [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] - [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + [ (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite") ] testTargetProblemsRepl :: ProjectConfig -> (String -> IO ()) -> Assertion @@ -1088,8 +1088,8 @@ testTargetProblemsRepl config reportSubCase = do [ mkTargetComponent "p-0.1" (CExeName "p1") , mkTargetComponent "p-0.1" (CExeName "p2") ] - [ ("p-0.1-inplace-p1", CExeName "p1") - , ("p-0.1-inplace-p2", CExeName "p2") + [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1") + , (WithStage Host "p-0.1-inplace-p2", CExeName "p2") ] reportSubCase "libs-disabled" @@ -1158,7 +1158,7 @@ testTargetProblemsRepl config reportSubCase = do (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [TargetPackage TargetExplicitNamed ["p-0.1"] Nothing] - [("p-0.1-inplace", (CLibName LMainLibName))] + [(WithStage Host "p-0.1-inplace", (CLibName LMainLibName))] -- When we select the package with an explicit filter then we get those -- components even though we did not explicitly enable tests/benchmarks assertProjectDistinctTargets @@ -1166,13 +1166,13 @@ testTargetProblemsRepl config reportSubCase = do (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind)] - [("p-0.1-inplace-a-testsuite", CTestName "a-testsuite")] + [(WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite")] assertProjectDistinctTargets elaboratedPlan (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind)] - [("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")] + [(WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")] testTargetProblemsListBin :: ProjectConfig -> (String -> IO ()) -> Assertion testTargetProblemsListBin config reportSubCase = do @@ -1185,7 +1185,7 @@ testTargetProblemsListBin config reportSubCase = do CmdListBin.selectComponentTarget [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing ] - [ ("p-0.1-inplace-p1", CExeName "p1") + [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1") ] reportSubCase "multiple-exes" @@ -1222,8 +1222,8 @@ testTargetProblemsListBin config reportSubCase = do [ mkTargetComponent "p-0.1" (CExeName "p1") , mkTargetComponent "p-0.1" (CExeName "p2") ] - [ ("p-0.1-inplace-p1", CExeName "p1") - , ("p-0.1-inplace-p2", CExeName "p2") + [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1") + , (WithStage Host "p-0.1-inplace-p2", CExeName "p2") ] reportSubCase "exes-disabled" @@ -1270,7 +1270,7 @@ testTargetProblemsRun config reportSubCase = do CmdRun.selectComponentTarget [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing ] - [ ("p-0.1-inplace-p1", CExeName "p1") + [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1") ] reportSubCase "multiple-exes" @@ -1307,8 +1307,8 @@ testTargetProblemsRun config reportSubCase = do [ mkTargetComponent "p-0.1" (CExeName "p1") , mkTargetComponent "p-0.1" (CExeName "p2") ] - [ ("p-0.1-inplace-p1", CExeName "p1") - , ("p-0.1-inplace-p2", CExeName "p2") + [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1") + , (WithStage Host "p-0.1-inplace-p2", CExeName "p2") ] reportSubCase "exes-disabled" @@ -1711,11 +1711,11 @@ testTargetProblemsHaddock config reportSubCase = do (CmdHaddock.selectPackageTargets haddockFlags) CmdHaddock.selectComponentTarget [mkTargetPackage "p-0.1"] - [ ("p-0.1-inplace", (CLibName LMainLibName)) - , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") + [ (WithStage Host "p-0.1-inplace", (CLibName LMainLibName)) + , (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe") + , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp") ] reportSubCase "disabled component kinds" @@ -1727,7 +1727,7 @@ testTargetProblemsHaddock config reportSubCase = do (CmdHaddock.selectPackageTargets haddockFlags) CmdHaddock.selectComponentTarget [mkTargetPackage "p-0.1"] - [("p-0.1-inplace", (CLibName LMainLibName))] + [(WithStage Host "p-0.1-inplace", (CLibName LMainLibName))] reportSubCase "requested component kinds" -- When we selecting the package with an explicit filter then it does not @@ -1742,10 +1742,10 @@ testTargetProblemsHaddock config reportSubCase = do , TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] - [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") + [ (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe") + , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp") ] where mkHaddockFlags flib exe test bench = @@ -1763,7 +1763,7 @@ assertProjectDistinctTargets -> (forall k. TargetSelector -> [AvailableTarget k] -> Either (TargetProblem err) [k]) -> (forall k. SubComponentTarget -> AvailableTarget k -> Either (TargetProblem err) k) -> [TargetSelector] - -> [(UnitId, ComponentName)] + -> [(WithStage UnitId, ComponentName)] -> Assertion assertProjectDistinctTargets elaboratedPlan @@ -2252,7 +2252,7 @@ executePlan , elaboratedPlan , elaboratedShared ) = do - let targets :: Map.Map UnitId [ComponentTarget] + let targets :: Map.Map (WithStage UnitId) [ComponentTarget] targets = Map.fromList [ (unitid, [ComponentTarget cname WholeComponent]) @@ -2354,7 +2354,7 @@ expectPackagePreExisting :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId - -> IO InstalledPackageInfo + -> IO (WithStage InstalledPackageInfo) expectPackagePreExisting plan buildOutcomes pkgid = do planpkg <- expectPlanPackage plan pkgid case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of From 22812d450c8fb00d9d509fd5450a4b85b08fb926 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 7 Aug 2025 13:59:33 +0800 Subject: [PATCH 27/54] fix(cabal-install): rewrite instantiateInstallPlan --- .../Distribution/Client/ProjectPlanning.hs | 303 ++++++++++-------- 1 file changed, 167 insertions(+), 136 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 70b81937f7d..29f5eac0611 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -206,7 +206,7 @@ import Distribution.Types.PackageVersionConstraint import Distribution.Types.PkgconfigDependency import Distribution.Types.UnqualComponentName -import Distribution.Backpack +import Distribution.Backpack hiding (mkDefUnitId) import Distribution.Backpack.ComponentsGraph import Distribution.Backpack.ConfiguredComponent import Distribution.Backpack.FullUnitId @@ -233,7 +233,7 @@ import qualified Distribution.Compat.Graph as Graph import Control.Exception (assert) import Control.Monad (mapM_, sequence) import Control.Monad.IO.Class (liftIO) -import Control.Monad.State as State (State, execState, runState, state) +import Control.Monad.State (State, execState, gets, modify) import Data.Foldable (fold) import Data.List (deleteBy, groupBy) import qualified Data.List.NonEmpty as NE @@ -2857,7 +2857,7 @@ binDirectories layout config package = case elabBuildStyle package of distBuildDirectory layout (elabDistDirParams config package) "build" -type InstS = Map UnitId ElaboratedPlanPackage +type InstS = Map (WithStage UnitId) ElaboratedPlanPackage type InstM a = State InstS a getComponentId @@ -2942,67 +2942,75 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = where pkgs = InstallPlan.toList plan - cmap = Map.fromList [(getComponentId pkg, pkg) | pkg <- pkgs] + cmap = Map.fromList [(WithStage (stageOf pkg) (getComponentId pkg), pkg) | pkg <- pkgs] instantiateUnitId - :: ComponentId + :: Stage + -> ComponentId + -- \^ The id of the component being instantiated -> Map ModuleName (Module, BuildStyle) + -- \^ A mapping from module names (the "holes" or signatures in Backpack) + -- to the concrete modules (and their build styles) that should fill those + -- holes. -> InstM (DefUnitId, BuildStyle) - instantiateUnitId cid insts = state $ \s -> - case Map.lookup uid s of - Nothing -> - -- Knot tied - -- TODO: I don't think the knot tying actually does - -- anything useful - let (r, s') = - runState - (instantiateComponent uid cid insts) - (Map.insert uid r s) - in ((def_uid, extractElabBuildStyle r), Map.insert uid r s') - Just r -> ((def_uid, extractElabBuildStyle r), s) + instantiateUnitId stage cid insts = + gets (Map.lookup (WithStage stage uid)) >>= \case + Nothing -> do + r <- instantiateComponent uid (WithStage stage cid) insts + modify (Map.insert (WithStage stage uid) r) + return (unsafeMkDefUnitId uid, extractElabBuildStyle r) + Just r -> + return (unsafeMkDefUnitId uid, extractElabBuildStyle r) where - def_uid = mkDefUnitId cid (fmap fst insts) - uid = unDefUnitId def_uid + uid = mkDefUnitId cid (fmap fst insts) -- No need to InplaceT; the inplace-ness is properly computed for -- the ElaboratedPlanPackage, so that will implicitly pass it on instantiateComponent :: UnitId - -> ComponentId + -- \^ The unit id to assign to the instantiated component + -> WithStage ComponentId + -- \^ The id of the component being instantiated -> Map ModuleName (Module, BuildStyle) + -- \^ A mapping from module names (the "holes" or signatures in Backpack) + -- to the concrete modules (and their build styles) that should fill those + -- holes. -> InstM ElaboratedPlanPackage - instantiateComponent uid cid insts - | Just planpkg <- Map.lookup cid cmap = + instantiateComponent uid cidws@(WithStage stage cid) insts = + case Map.lookup cidws cmap of + Nothing -> error ("instantiateComponent: " ++ prettyShow cid) + Just planpkg -> case planpkg of - InstallPlan.Configured - ( elab0@ElaboratedConfiguredPackage - { elabPkgOrComp = ElabComponent comp - } - ) -> do - deps <- - traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp) - let build_style = fold (fmap snd insts) - let getDep (Module dep_uid _) = [dep_uid] - elab1 = - fixupBuildStyle build_style $ - elab0 - { elabUnitId = uid - , elabComponentId = cid - , elabIsCanonical = Map.null (fmap fst insts) - , elabPkgOrComp = - ElabComponent - comp - { compOrderLibDependencies = - [newSimpleUnitId cid | not (Map.null insts)] - ++ ordNub - ( map - unDefUnitId - (deps ++ concatMap (getDep . fst) (Map.elems insts)) - ) - , compInstantiatedWith = fmap fst insts - } - } - elab = + InstallPlan.Installed{} -> return planpkg + InstallPlan.PreExisting{} -> return planpkg + InstallPlan.Configured elab0 -> + case elabPkgOrComp elab0 of + ElabPackage{} -> return planpkg + ElabComponent comp -> do + deps <- traverse (fmap fst . instantiateUnit stage insts) (compLinkedLibDependencies comp) + let build_style = fold (fmap snd insts) + let getDep (Module dep_uid _) = [dep_uid] + elab1 = + fixupBuildStyle build_style $ + elab0 + { elabUnitId = uid + , elabComponentId = cid + , elabIsCanonical = Map.null (fmap fst insts) + , elabPkgOrComp = + ElabComponent + comp + { compOrderLibDependencies = + (if Map.null insts then [] else [newSimpleUnitId cid]) + ++ ordNub + ( map + unDefUnitId + (deps ++ concatMap (getDep . fst) (Map.elems insts)) + ) + , compInstantiatedWith = fmap fst insts + } + } + return $ + InstallPlan.Configured elab1 { elabInstallDirs = computeInstallDirs @@ -3011,112 +3019,135 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = elaboratedShared elab1 } - return $ InstallPlan.Configured elab - _ -> return planpkg - | otherwise = error ("instantiateComponent: " ++ prettyShow cid) - substUnitId :: Map ModuleName (Module, BuildStyle) -> OpenUnitId -> InstM (DefUnitId, BuildStyle) - substUnitId _ (DefiniteUnitId uid) = + -- \| Instantiates an OpenUnitId into a concrete UnitId, producing a concrete UnitId and its associated BuildStyle. + -- + -- This function recursively applies a module substitution to an OpenUnitId, producing a fully instantiated + -- (definite) unit and its build style. This is a key step in Backpack-style instantiation, where "holes" in + -- a package are filled with concrete modules. + -- + -- Behavior + -- + -- If given a DefiniteUnitId, it returns the id and a default build style (BuildAndInstall). + -- + -- If given an IndefFullUnitId, it: + -- Recursively applies the substitution to each module in the instantiation map using substSubst. + -- Calls instantiateUnitId to create or retrieve the fully instantiated unit id and build style for this instantiation. + -- + instantiateUnit + :: Stage + -> Map ModuleName (Module, BuildStyle) + -- \^ A mapping from module names to their corresponding modules and build styles. + -> OpenUnitId + -- \^ The unit to instantiate. This can be: + -- DefiniteUnitId uid: already fully instantiated (no holes). + -- IndefFullUnitId cid insts: an indefinite unit (with holes), described by a component id and a mapping of holes to modules. + -> InstM (DefUnitId, BuildStyle) + instantiateUnit _stage _subst (DefiniteUnitId def_uid) = -- This COULD actually, secretly, be an inplace package, but in -- that case it doesn't matter as it's already been recorded -- in the package that depends on this - return (uid, BuildAndInstall) - substUnitId subst (IndefFullUnitId cid insts) = do - insts' <- substSubst subst insts - instantiateUnitId cid insts' - - -- NB: NOT composition - substSubst - :: Map ModuleName (Module, BuildStyle) - -> Map ModuleName OpenModule - -> InstM (Map ModuleName (Module, BuildStyle)) - substSubst subst insts = traverse (substModule subst) insts - - substModule :: Map ModuleName (Module, BuildStyle) -> OpenModule -> InstM (Module, BuildStyle) - substModule subst (OpenModuleVar mod_name) + return (def_uid, BuildAndInstall) + instantiateUnit stage subst (IndefFullUnitId cid insts) = do + insts' <- traverse (instantiateModule stage subst) insts + instantiateUnitId stage cid insts' + + -- \| Instantiates an OpenModule into a concrete Module producing a concrete Module + -- and its associated BuildStyle. + instantiateModule + :: Stage + -> Map ModuleName (Module, BuildStyle) + -- \^ A mapping from module names to their corresponding modules and build styles. + -> OpenModule + -- \^ The module to substitute, which can be: + -- OpenModuleVar mod_name: a hole (variable) named mod_name + -- OpenModule uid mod_name: a module from a specific unit (uid). + -> InstM (Module, BuildStyle) + instantiateModule _stage subst (OpenModuleVar mod_name) | Just m <- Map.lookup mod_name subst = return m | otherwise = error "substModule: non-closing substitution" - substModule subst (OpenModule uid mod_name) = do - (uid', build_style) <- substUnitId subst uid + instantiateModule stage subst (OpenModule uid mod_name) = do + (uid', build_style) <- instantiateUnit stage subst uid return (Module uid' mod_name, build_style) - indefiniteUnitId :: ComponentId -> InstM UnitId - indefiniteUnitId cid = do - let uid = newSimpleUnitId cid - r <- indefiniteComponent uid cid - state $ \s -> (uid, Map.insert uid r s) - - indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage - indefiniteComponent _uid cid - -- Only need Configured; this phase happens before improvement, so - -- there shouldn't be any Installed packages here. - | Just (InstallPlan.Configured epkg) <- Map.lookup cid cmap - , ElabComponent elab_comp <- elabPkgOrComp epkg = - do - -- We need to do a little more processing of the includes: some - -- of them are fully definite even without substitution. We - -- want to build those too; see #5634. - -- - -- This code mimics similar code in Distribution.Backpack.ReadyComponent; - -- however, unlike the conversion from LinkedComponent to - -- ReadyComponent, this transformation is done *without* - -- changing the type in question; and what we are simply - -- doing is enforcing tighter invariants on the data - -- structure in question. The new invariant is that there - -- is no IndefFullUnitId in compLinkedLibDependencies that actually - -- has no holes. We couldn't specify this invariant when - -- we initially created the ElaboratedPlanPackage because - -- we have no way of actually reifying the UnitId into a - -- DefiniteUnitId (that's what substUnitId does!) - new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid -> - if Set.null (openUnitIdFreeHoles uid) - then fmap (DefiniteUnitId . fst) (substUnitId Map.empty uid) - else return uid - -- NB: no fixupBuildStyle needed here, as if the indefinite - -- component depends on any inplace packages, it itself must - -- be indefinite! There is no substitution here, we can't - -- post facto add inplace deps - return . InstallPlan.Configured $ - epkg - { elabPkgOrComp = - ElabComponent - elab_comp - { compLinkedLibDependencies = new_deps - , -- I think this is right: any new definite unit ids we - -- minted in the phase above need to be built before us. - -- Add 'em in. This doesn't remove any old dependencies - -- on the indefinite package; they're harmless. - compOrderLibDependencies = - ordNub $ - compOrderLibDependencies elab_comp - ++ [unDefUnitId d | DefiniteUnitId d <- new_deps] - } - } - | Just planpkg <- Map.lookup cid cmap = - return planpkg - | otherwise = error ("indefiniteComponent: " ++ prettyShow cid) + indefiniteComponent + :: ElaboratedConfiguredPackage + -> InstM ElaboratedConfiguredPackage + indefiniteComponent epkg = + case elabPkgOrComp epkg of + ElabPackage{} -> return epkg + ElabComponent elab_comp -> do + -- We need to do a little more processing of the includes: some + -- of them are fully definite even without substitution. We + -- want to build those too; see #5634. + -- + -- This code mimics similar code in Distribution.Backpack.ReadyComponent; + -- however, unlike the conversion from LinkedComponent to + -- ReadyComponent, this transformation is done *without* + -- changing the type in question; and what we are simply + -- doing is enforcing tighter invariants on the data + -- structure in question. The new invariant is that there + -- is no IndefFullUnitId in compLinkedLibDependencies that actually + -- has no holes. We couldn't specify this invariant when + -- we initially created the ElaboratedPlanPackage because + -- we have no way of actually reifying the UnitId into a + -- DefiniteUnitId (that's what substUnitId does!) + new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid -> + if Set.null (openUnitIdFreeHoles uid) + then fmap (DefiniteUnitId . fst) (instantiateUnit (elabStage epkg) Map.empty uid) + else return uid + -- NB: no fixupBuildStyle needed here, as if the indefinite + -- component depends on any inplace packages, it itself must + -- be indefinite! There is no substitution here, we can't + -- post facto add inplace deps + return + epkg + { elabPkgOrComp = + ElabComponent + elab_comp + { compLinkedLibDependencies = new_deps + , -- I think this is right: any new definite unit ids we + -- minted in the phase above need to be built before us. + -- Add 'em in. This doesn't remove any old dependencies + -- on the indefinite package; they're harmless. + compOrderLibDependencies = + ordNub $ + compOrderLibDependencies elab_comp + ++ [unDefUnitId d | DefiniteUnitId d <- new_deps] + } + } fixupBuildStyle BuildAndInstall elab = elab - fixupBuildStyle _ (elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly{}}) = elab - fixupBuildStyle t@(BuildInplaceOnly{}) elab = + fixupBuildStyle _buildStyle (elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly{}}) = elab + fixupBuildStyle buildStyle@(BuildInplaceOnly{}) elab = elab - { elabBuildStyle = t + { elabBuildStyle = buildStyle , elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab , elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab , elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab } ready_map = execState work Map.empty - work = for_ pkgs $ \pkg -> case pkg of InstallPlan.Configured (elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp}) - | not (Map.null (compLinkedInstantiatedWith comp)) -> - indefiniteUnitId (elabComponentId elab) - >> return () + | not (Map.null (compLinkedInstantiatedWith comp)) -> do + r <- indefiniteComponent elab + modify (Map.insert (WithStage (elabStage elab) (elabUnitId elab)) (InstallPlan.Configured r)) _ -> - instantiateUnitId (getComponentId pkg) Map.empty - >> return () + void $ instantiateUnitId (stageOf pkg) (getComponentId pkg) Map.empty + +-- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation +-- with no holes. +-- +-- This function is defined in Cabal-syntax but only cabal-install +-- cares about it so I am putting it here. +-- +-- I am also not using the DefUnitId newtype since I believe it +-- provides little value in the code above. +mkDefUnitId :: ComponentId -> Map ModuleName Module -> UnitId +mkDefUnitId cid insts = + mkUnitId (unComponentId cid ++ maybe "" ("+" ++) (hashModuleSubst insts)) --------------------------- -- Build targets From 7948671a87433ca8ca1c7e495296d9808629448a Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 14 Jul 2025 12:42:15 +0800 Subject: [PATCH 28/54] refactor(cabal-install): reduce scope in ProjectPlanning --- .../Distribution/Client/ProjectPlanning.hs | 50 +++++++------------ 1 file changed, 17 insertions(+), 33 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 29f5eac0611..0f4b4740894 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1818,40 +1818,26 @@ elaborateInstallPlan , elabPkgOrComp = ElabComponent ( ElaboratedComponent - { compSolverName - , compComponentName - , compLibDependencies - , compLinkedLibDependencies - , compExeDependencies - , compPkgConfigDependencies - , compExeDependencyPaths - , compOrderLibDependencies - , compInstantiatedWith - , compLinkedInstantiatedWith + { compSolverName = CD.ComponentSetup + , compComponentName = Nothing + , compLibDependencies = + [ (configuredId cid, False) + | cid <- CD.setupDeps solverPkgLibDeps >>= elaborateLibSolverId mapDep + ] + , compLinkedLibDependencies = notImpl "compLinkedLibDependencies" + , compOrderLibDependencies = notImpl "compOrderLibDependencies" + , -- Not supported: + compExeDependencies = mempty + , compExeDependencyPaths = mempty + , compPkgConfigDependencies = mempty + , compInstantiatedWith = mempty + , compLinkedInstantiatedWith = Map.empty } ) } | otherwise = Nothing where - compSolverName = CD.ComponentSetup - compComponentName = Nothing - - dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps solverPkgLibDeps - - compLibDependencies = - -- MP: No idea what this function does - map (\cid -> (configuredId cid, False)) dep_pkgs - compLinkedLibDependencies = notImpl "compLinkedLibDependencies" - compOrderLibDependencies = notImpl "compOrderLibDependencies" - - -- Not supported: - compExeDependencies = [] - compExeDependencyPaths = [] - compPkgConfigDependencies = [] - compInstantiatedWith = mempty - compLinkedInstantiatedWith = Map.empty - notImpl f = error $ "Distribution.Client.ProjectPlanning.setupComponent: " @@ -1955,13 +1941,14 @@ elaborateInstallPlan { compSolverName , compComponentName , compLibDependencies - , compLinkedLibDependencies , compExeDependencies , compPkgConfigDependencies , compExeDependencyPaths - , compOrderLibDependencies , compInstantiatedWith = Map.empty , compLinkedInstantiatedWith = Map.empty + , -- filled later (in step 5) + compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" + , compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" } -- 3. Construct a preliminary ElaboratedConfiguredPackage, @@ -2053,9 +2040,6 @@ elaborateInstallPlan return ((cc_map', lc_map', exe_map'), elab) where - compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" - compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" - cname = Cabal.componentName comp compComponentName = Just cname compSolverName = CD.componentNameToComponent cname From a907ffcc87a56ea0f41658c3680f596b7b5c93ea Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 20 May 2025 15:36:13 +0800 Subject: [PATCH 29/54] refactor(cabal-install): readability improvements --- .../Distribution/Client/ProjectPlanning.hs | 198 +++++++++--------- 1 file changed, 96 insertions(+), 102 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 0f4b4740894..e10735decbb 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -2139,15 +2139,7 @@ elaborateInstallPlan -> LogProgress ElaboratedConfiguredPackage elaborateSolverToPackage pkgWhyNotPerComponent - pkg@( SolverPackage - _stage - _qpn - (SourcePackage pkgid _gpd _srcloc _descOverride) - _flags - _stanzas - _deps0 - _exe_deps0 - ) + pkg@SolverPackage{solverPkgSource = SourcePackage{srcpkgPackageId}} compGraph comps = do -- Knot tying: the final elab includes the @@ -2200,7 +2192,7 @@ elaborateInstallPlan pkgInstalledId | shouldBuildInplaceOnly pkg = - mkComponentId (prettyShow pkgid ++ "-inplace") + mkComponentId (prettyShow srcpkgPackageId ++ "-inplace") | otherwise = assert (isJust elabPkgSourceHash) $ hashedInstalledPackageId @@ -2211,7 +2203,7 @@ elaborateInstallPlan -- Need to filter out internal dependencies, because they don't -- correspond to anything real anymore. - isExternal confid = confSrcId confid /= pkgid + isExternal confid = confSrcId confid /= srcpkgPackageId isExternal' (WithStage stage confId) = stage /= elabStage || isExternal confId pkgLibDependencies = @@ -2259,16 +2251,20 @@ elaborateInstallPlan :: SolverPackage UnresolvedPkgLoc -> (ElaboratedConfiguredPackage, LogProgress ()) elaborateSolverToCommon - pkg@( SolverPackage - stage - _qpn - (SourcePackage pkgid gdesc srcloc descOverride) - flags - stanzas - deps0 - _exe_deps0 - ) = - (elaboratedPackage, wayWarnings pkgid >> buildOptionsAdjustmentWarnings) + pkg@SolverPackage + { solverPkgStage + , solverPkgSource = + SourcePackage + { srcpkgPackageId + , srcpkgDescription + , srcpkgSource + , srcpkgDescrOverride + } + , solverPkgFlags + , solverPkgStanzas + , solverPkgLibDeps + } = + elaboratedPackage where elaboratedPackage = ElaboratedConfiguredPackage{..} @@ -2288,33 +2284,32 @@ elaborateInstallPlan elabModuleShape = error "elaborateSolverToCommon: elabModuleShape" elabIsCanonical = True - elabPkgSourceId = pkgid + elabPkgSourceId = srcpkgPackageId - elabStage = stage - elabCompiler = toolchainCompiler (getStage toolchains stage) - elabPlatform = toolchainPlatform (getStage toolchains stage) - elabProgramDb = toolchainProgramDb (getStage toolchains stage) + elabStage = solverPkgStage + elabCompiler = toolchainCompiler (getStage toolchains solverPkgStage) + elabPlatform = toolchainPlatform (getStage toolchains solverPkgStage) + elabProgramDb = toolchainProgramDb (getStage toolchains solverPkgStage) elabPkgDescription = case PD.finalizePD - flags + solverPkgFlags elabEnabledSpec (const Satisfied) elabPlatform (compilerInfo elabCompiler) [] - gdesc of + srcpkgDescription of Right (desc, _) -> desc Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" - elabGPkgDescription = gdesc - elabFlagAssignment = flags + elabFlagAssignment = solverPkgFlags elabFlagDefaults = PD.mkFlagAssignment [ (PD.flagName flag, PD.flagDefault flag) - | flag <- PD.genPackageFlags gdesc + | flag <- PD.genPackageFlags srcpkgDescription ] - elabEnabledSpec = enableStanzas stanzas - elabStanzasAvailable = stanzas + elabEnabledSpec = enableStanzas solverPkgStanzas + elabStanzasAvailable = solverPkgStanzas elabStanzasRequested :: OptionalStanzaMap (Maybe Bool) elabStanzasRequested = optStanzaTabulate $ \o -> case o of @@ -2328,8 +2323,8 @@ elaborateInstallPlan BenchStanzas -> listToMaybe [v | v <- maybeToList benchmarks, _ <- PD.benchmarks elabPkgDescription] where tests, benchmarks :: Maybe Bool - tests = perPkgOptionMaybe pkgid packageConfigTests - benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks + tests = perPkgOptionMaybe srcpkgPackageId packageConfigTests + benchmarks = perPkgOptionMaybe srcpkgPackageId packageConfigBenchmarks -- This is a placeholder which will get updated by 'pruneInstallPlanPass1' -- and 'pruneInstallPlanPass2'. We can't populate it here @@ -2347,7 +2342,7 @@ elaborateInstallPlan elabHaddockTargets = [] elabBuildHaddocks = - perPkgOptionFlag pkgid False packageConfigDocumentation + perPkgOptionFlag srcpkgPackageId False packageConfigDocumentation -- `documentation: true` should imply `-haddock` for GHC addHaddockIfDocumentationEnabled :: ConfiguredProgram -> ConfiguredProgram @@ -2356,8 +2351,8 @@ elaborateInstallPlan then cp{programOverrideArgs = "-haddock" : programOverrideArgs} else cp - elabPkgSourceLocation = srcloc - elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes + elabPkgSourceLocation = srcpkgSource + elabPkgSourceHash = Map.lookup srcpkgPackageId sourcePackageHashes elabLocalToProject = isLocalToProject pkg elabBuildStyle = if shouldBuildInplaceOnly pkg @@ -2373,7 +2368,7 @@ elaborateInstallPlan elabSetupScriptStyle elabPkgDescription libDepGraph - deps0 + solverPkgLibDeps elabSetupPackageDBStack = buildAndRegisterDbs inplacePackageDbs = corePackageDbs ++ [distPackageDB (compilerId elabCompiler)] @@ -2388,7 +2383,7 @@ elaborateInstallPlan | shouldBuildInplaceOnly pkg = inplacePackageDbs | otherwise = corePackageDbs - elabPkgDescriptionOverride = descOverride + elabPkgDescriptionOverride = srcpkgDescrOverride -- Raw build options derived from per-package config. -- This is the cabal-install equivalent of Cabal's 'buildOptionsFromConfigFlags', @@ -2399,35 +2394,34 @@ elaborateInstallPlan -- 'elabBuildOptions' accurately reflects what will actually be built. elabBuildOptionsRaw = LBC.BuildOptions - { withVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively - , withSharedLib = canBuildSharedLibs && pkgid `Set.member` pkgsUseSharedLibrary - , withStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib + { withVanillaLib = perPkgOptionFlag srcpkgPackageId True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively + , withSharedLib = srcpkgPackageId `Set.member` pkgsUseSharedLibrary + , withStaticLib = perPkgOptionFlag srcpkgPackageId False packageConfigStaticLib , withDynExe = - perPkgOptionFlag pkgid False packageConfigDynExe + perPkgOptionFlag srcpkgPackageId False packageConfigDynExe -- We can't produce a dynamic executable if the user -- wants to enable executable profiling but the -- compiler doesn't support prof+dyn. && (okProfDyn || not profExe) - , withFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe - , withGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib -- TODO: [required feature] needs to default to enabled on windows still - , withProfExe = profExe - , withProfLib = canBuildProfilingLibs && pkgid `Set.member` pkgsUseProfilingLibrary - , withProfLibShared = canBuildProfilingSharedLibs && pkgid `Set.member` pkgsUseProfilingLibraryShared - , withBytecodeLib = perPkgOptionFlag pkgid False packageConfigBytecodeLib - , exeCoverage = perPkgOptionFlag pkgid False packageConfigCoverage - , libCoverage = perPkgOptionFlag pkgid False packageConfigCoverage - , withOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization - , splitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs - , splitSections = perPkgOptionFlag pkgid False packageConfigSplitSections - , stripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs - , stripExes = perPkgOptionFlag pkgid False packageConfigStripExes - , withDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo - , relocatable = perPkgOptionFlag pkgid False packageConfigRelocatable + , 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 + , withProfLibShared = srcpkgPackageId `Set.member` pkgsUseProfilingLibraryShared + , exeCoverage = perPkgOptionFlag srcpkgPackageId False packageConfigCoverage + , libCoverage = perPkgOptionFlag srcpkgPackageId False packageConfigCoverage + , withOptimization = perPkgOptionFlag srcpkgPackageId NormalOptimisation packageConfigOptimization + , splitObjs = perPkgOptionFlag srcpkgPackageId False packageConfigSplitObjs + , splitSections = perPkgOptionFlag srcpkgPackageId False packageConfigSplitSections + , stripLibs = perPkgOptionFlag srcpkgPackageId False packageConfigStripLibs + , stripExes = perPkgOptionFlag srcpkgPackageId False packageConfigStripExes + , withDebugInfo = perPkgOptionFlag srcpkgPackageId NoDebugInfo packageConfigDebugInfo + , relocatable = perPkgOptionFlag srcpkgPackageId False packageConfigRelocatable , withProfLibDetail = elabProfExeDetail , withProfExeDetail = elabProfLibDetail } okProfDyn = profilingDynamicSupportedOrUnknown elabCompiler - profExe = perPkgOptionFlag pkgid False packageConfigProf + profExe = perPkgOptionFlag srcpkgPackageId False packageConfigProf elabBuildOptions = Cabal.adjustBuildOptions compiler compilerprogdb elabBuildOptionsRaw @@ -2435,12 +2429,12 @@ elaborateInstallPlan , elabProfLibDetail ) = perPkgOptionLibExeFlag - pkgid + srcpkgPackageId ProfDetailDefault packageConfigProfDetail packageConfigProfLibDetail - elabDumpBuildInfo = perPkgOptionFlag pkgid NoDumpBuildInfo packageConfigDumpBuildInfo + elabDumpBuildInfo = perPkgOptionFlag srcpkgPackageId NoDumpBuildInfo packageConfigDumpBuildInfo -- Combine the configured compiler prog settings with the user-supplied -- config. For the compiler progs any user-supplied config was taken @@ -2452,7 +2446,7 @@ elaborateInstallPlan [ (programId prog, programPath prog) | prog <- configuredPrograms elabProgramDb ] - <> perPkgOptionMapLast pkgid packageConfigProgramPaths + <> perPkgOptionMapLast srcpkgPackageId packageConfigProgramPaths elabProgramArgs = Map.unionWith (++) @@ -2463,46 +2457,46 @@ elaborateInstallPlan , not (null args) ] ) - (perPkgOptionMapMappend pkgid packageConfigProgramArgs) - elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra + (perPkgOptionMapMappend srcpkgPackageId packageConfigProgramArgs) + elabProgramPathExtra = perPkgOptionNubList srcpkgPackageId packageConfigProgramPathExtra elabConfiguredPrograms = configuredPrograms elabProgramDb - elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs - elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs - elabExtraLibDirsStatic = perPkgOptionList pkgid packageConfigExtraLibDirsStatic - elabExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs - elabExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs - elabProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix - elabProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix - - elabHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle - elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml - elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation - elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs - elabHaddockForHackage = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage - elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables - elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites - elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks - elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal - elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss - elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource - elabHaddockQuickJump = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump - elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss - elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents - elabHaddockIndex = perPkgOptionMaybe pkgid packageConfigHaddockIndex - elabHaddockBaseUrl = perPkgOptionMaybe pkgid packageConfigHaddockBaseUrl - elabHaddockResourcesDir = perPkgOptionMaybe pkgid packageConfigHaddockResourcesDir - elabHaddockOutputDir = perPkgOptionMaybe pkgid packageConfigHaddockOutputDir - elabHaddockUseUnicode = perPkgOptionFlag pkgid False packageConfigHaddockUseUnicode - - elabTestMachineLog = perPkgOptionMaybe pkgid packageConfigTestMachineLog - elabTestHumanLog = perPkgOptionMaybe pkgid packageConfigTestHumanLog - elabTestShowDetails = perPkgOptionMaybe pkgid packageConfigTestShowDetails - elabTestKeepTix = perPkgOptionFlag pkgid False packageConfigTestKeepTix - elabTestWrapper = perPkgOptionMaybe pkgid packageConfigTestWrapper - elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites - elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions - - elabBenchmarkOptions = perPkgOptionList pkgid packageConfigBenchmarkOptions + elabConfigureScriptArgs = perPkgOptionList srcpkgPackageId packageConfigConfigureArgs + elabExtraLibDirs = perPkgOptionList srcpkgPackageId packageConfigExtraLibDirs + elabExtraLibDirsStatic = perPkgOptionList srcpkgPackageId packageConfigExtraLibDirsStatic + elabExtraFrameworkDirs = perPkgOptionList srcpkgPackageId packageConfigExtraFrameworkDirs + elabExtraIncludeDirs = perPkgOptionList srcpkgPackageId packageConfigExtraIncludeDirs + elabProgPrefix = perPkgOptionMaybe srcpkgPackageId packageConfigProgPrefix + elabProgSuffix = perPkgOptionMaybe srcpkgPackageId packageConfigProgSuffix + + elabHaddockHoogle = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockHoogle + elabHaddockHtml = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockHtml + elabHaddockHtmlLocation = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockHtmlLocation + elabHaddockForeignLibs = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockForeignLibs + elabHaddockForHackage = perPkgOptionFlag srcpkgPackageId Cabal.ForDevelopment packageConfigHaddockForHackage + elabHaddockExecutables = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockExecutables + elabHaddockTestSuites = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockTestSuites + elabHaddockBenchmarks = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockBenchmarks + elabHaddockInternal = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockInternal + elabHaddockCss = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockCss + elabHaddockLinkedSource = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockLinkedSource + elabHaddockQuickJump = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockQuickJump + elabHaddockHscolourCss = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockHscolourCss + elabHaddockContents = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockContents + elabHaddockIndex = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockIndex + elabHaddockBaseUrl = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockBaseUrl + elabHaddockResourcesDir = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockResourcesDir + elabHaddockOutputDir = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockOutputDir + elabHaddockUseUnicode = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockUseUnicode + + elabTestMachineLog = perPkgOptionMaybe srcpkgPackageId packageConfigTestMachineLog + elabTestHumanLog = perPkgOptionMaybe srcpkgPackageId packageConfigTestHumanLog + elabTestShowDetails = perPkgOptionMaybe srcpkgPackageId packageConfigTestShowDetails + elabTestKeepTix = perPkgOptionFlag srcpkgPackageId False packageConfigTestKeepTix + elabTestWrapper = perPkgOptionMaybe srcpkgPackageId packageConfigTestWrapper + elabTestFailWhenNoTestSuites = perPkgOptionFlag srcpkgPackageId False packageConfigTestFailWhenNoTestSuites + elabTestTestOptions = perPkgOptionList srcpkgPackageId packageConfigTestTestOptions + + elabBenchmarkOptions = perPkgOptionList srcpkgPackageId packageConfigBenchmarkOptions perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a From beeea52319766f26460e81ec41316947cbee73bf Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 27 May 2025 12:26:32 +0800 Subject: [PATCH 30/54] fix(cabal-install): use the correct stage for setup deps --- .../Distribution/Client/ProjectPlanning.hs | 6 +- .../Client/ProjectPlanning/Types.hs | 86 ++++++++++--------- 2 files changed, 50 insertions(+), 42 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index e10735decbb..c7f5d0a8eed 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -4024,9 +4024,9 @@ setupHsScriptOptions , usePackageDB = elabSetupPackageDBStack , usePackageIndex = Nothing , useDependencies = - [ (uid, srcid) - | (WithStage _ (ConfiguredId srcid (Just (CLibName LMainLibName)) uid), _) <- - elabSetupDependencies elab + [ (confInstId cid, confSrcId cid) + | -- TODO: we should filter for dependencies on libraries but that should be implicit in elabSetupLibDependencies + (WithStage _ cid, _promised) <- elabSetupLibDependencies elab ] , useDependenciesExclusive = True , useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index fc670b0a3bd..73679325324 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -24,7 +24,8 @@ module Distribution.Client.ProjectPlanning.Types , elabOrderLibDependencies , elabExeDependencies , elabOrderExeDependencies - , elabSetupDependencies + , elabSetupLibDependencies + , elabSetupExeDependencies , elabPkgConfigDependencies , elabInplaceDependencyBuildCacheFiles , elabRequiresRegistration @@ -586,25 +587,28 @@ elabDistDirParams shared elab = -- use 'elabLibDependencies'. This method is the same as -- 'nodeNeighbors'. -- --- NB: this method DOES include setup deps. +-- Note: this method DOES include setup deps. elabOrderDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderDependencies elab = elabOrderLibDependencies elab ++ elabOrderExeDependencies elab --- | Like 'elabOrderDependencies', but only returns dependencies on --- libraries. +-- | The result includes setup dependencies elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderLibDependencies elab = - case elabPkgOrComp elab of - ElabPackage pkg -> - ordNub - [ WithStage (pkgStage pkg) (newSimpleUnitId (confInstId cid)) - | cid <- CD.flatDeps (map fst <$> pkgLibDependencies pkg) - ] - ElabComponent comp -> - [ WithStage (elabStage elab) c - | c <- compOrderLibDependencies comp - ] + ordNub $ + [ fmap (newSimpleUnitId . confInstId) dep + | (dep, _promised) <- elabLibDependencies elab ++ elabSetupLibDependencies elab + ] + +-- | The result includes setup dependencies +elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] +elabOrderExeDependencies elab = + -- Compare with elabOrderLibDependencies. The setup dependencies here do not need + -- any special attention because the stage is already included in pkgExeDependencies. + map (fmap (newSimpleUnitId . confInstId)) $ + case elabPkgOrComp elab of + ElabPackage pkg -> CD.flatDeps (pkgExeDependencies pkg) + ElabComponent comp -> compExeDependencies comp -- | The library dependencies (i.e., the libraries we depend on, NOT -- the dependencies of the library), NOT including setup dependencies. @@ -622,20 +626,40 @@ elabLibDependencies elab = | (c, promised) <- compLibDependencies comp ] --- | Like 'elabOrderDependencies', but only returns dependencies on --- executables. (This coincides with 'elabExeDependencies'.) -elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] -elabOrderExeDependencies = - fmap (fmap newSimpleUnitId) . elabExeDependencies +-- | The setup dependencies (the library dependencies of the setup executable; +-- note that it is not legal for setup scripts to have executable +-- dependencies at the moment.) +elabSetupLibDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)] +elabSetupLibDependencies elab = + case elabPkgOrComp elab of + ElabPackage pkg -> + ordNub + [ (WithStage (prevStage (pkgStage pkg)) cid, promised) + | (cid, promised) <- CD.setupDeps (pkgLibDependencies pkg) + ] + -- TODO: Custom setups not supported for components yet. When + -- they are, need to do this differently + ElabComponent _ -> [] + +-- | This would not be allowed actually. See comment on elabSetupLibDependencies. +elabSetupExeDependencies :: ElaboratedConfiguredPackage -> [WithStage ComponentId] +elabSetupExeDependencies elab = + map (fmap confInstId) $ + case elabPkgOrComp elab of + ElabPackage pkg -> CD.setupDeps (pkgExeDependencies pkg) + -- TODO: Custom setups not supported for components yet. When + -- they are, need to do this differently + ElabComponent _ -> [] -- | The executable dependencies (i.e., the executables we depend on); -- these are the executables we must add to the PATH before we invoke -- the setup script. elabExeDependencies :: ElaboratedConfiguredPackage -> [WithStage ComponentId] -elabExeDependencies elab = fmap (fmap confInstId) $ - case elabPkgOrComp elab of - ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) - ElabComponent comp -> compExeDependencies comp +elabExeDependencies elab = + map (fmap confInstId) $ + case elabPkgOrComp elab of + ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) + ElabComponent comp -> compExeDependencies comp -- | This returns the paths of all the executables we depend on; we -- must add these paths to PATH before invoking the setup script. @@ -647,22 +671,6 @@ elabExeDependencyPaths elab = ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) ElabComponent comp -> map snd (compExeDependencyPaths comp) --- | The setup dependencies (the library dependencies of the setup executable; --- note that it is not legal for setup scripts to have executable --- dependencies at the moment.) -elabSetupDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)] -elabSetupDependencies elab = - case elabPkgOrComp elab of - -- FIXME: this should be wrong. Setup and its dependencies can be on a different stage. Where did that information go? - ElabPackage pkg -> - ordNub - [ (WithStage (pkgStage pkg) cid, promised) - | (cid, promised) <- CD.setupDeps (pkgLibDependencies pkg) - ] - -- TODO: Custom setups not supported for components yet. When - -- they are, need to do this differently - ElabComponent _ -> [] - elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} = pkgPkgConfigDependencies pkg From 4c8d003a8f2afb21f7435e6bdecd921446155489 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 27 May 2025 13:06:04 +0800 Subject: [PATCH 31/54] refactor(cabal-install): rebuildTargets Isolate the common logic between building and only downloading. _Push the ifs up and the loops down_ --- .../Distribution/Client/ProjectBuilding.hs | 109 +++++++++++------- .../Client/ProjectBuilding/Types.hs | 5 +- 2 files changed, 69 insertions(+), 45 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index e14bb5bd597..20b544525db 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -340,12 +340,57 @@ rebuildTargets -> BuildTimeSettings -> IO BuildOutcomes rebuildTargets + verbosity + projectConfig + distDirLayout + storeDirLayout + installPlan + sharedPackageConfig + pkgsBuildStatus + buildSettings + | buildSettingOnlyDownload buildSettings = do + rebuildTargets' verbosity projectConfig distDirLayout installPlan sharedPackageConfig pkgsBuildStatus buildSettings $ + \downloadMap _jobControl pkg pkgBuildStatus -> + rebuildTargetOnlyDownload + verbosity + downloadMap + pkg + pkgBuildStatus + | otherwise = do + registerLock <- newLock -- serialise registration + cacheLock <- newLock -- serialise access to setup exe cache + rebuildTargets' verbosity projectConfig distDirLayout installPlan sharedPackageConfig pkgsBuildStatus buildSettings $ + \downloadMap jobControl pkg pkgBuildStatus -> + rebuildTarget + verbosity + distDirLayout + storeDirLayout + (jobControlSemaphore jobControl) + buildSettings + downloadMap + registerLock + cacheLock + sharedPackageConfig + installPlan + pkg + pkgBuildStatus + +rebuildTargets' + :: Verbosity + -> ProjectConfig + -> DistDirLayout + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> BuildStatusMap + -> BuildTimeSettings + -> (AsyncFetchMap -> JobControl IO (Graph.Key (GenericReadyPackage ElaboratedConfiguredPackage), Either BuildFailure BuildResult) -> GenericReadyPackage ElaboratedConfiguredPackage -> BuildStatus -> IO BuildResult) + -> IO BuildOutcomes +rebuildTargets' verbosity ProjectConfig { projectConfigBuildOnly = config } - distDirLayout@DistDirLayout{..} - storeDirLayout + DistDirLayout{..} installPlan sharedPackageConfig pkgsBuildStatus @@ -353,10 +398,9 @@ rebuildTargets { buildSettingNumJobs , buildSettingKeepGoing } + act | fromFlagOrDefault False (projectConfigOfflineMode config) && not (null packagesToDownload) = return offlineError | otherwise = do - registerLock <- newLock -- serialise registration - cacheLock <- newLock -- serialise access to setup exe cache -- TODO: [code cleanup] eliminate setup exe cache info verbosity $ "Executing install plan " @@ -384,26 +428,13 @@ rebuildTargets InstallPlan.execute jobControl keepGoing - (BuildFailure Nothing . DependentFailed . packageId) + (BuildFailure Nothing . DependentFailed . Graph.nodeKey) installPlan $ \pkg -> -- TODO: review exception handling handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ do let pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") (nodeKey pkg) pkgsBuildStatus - - rebuildTarget - verbosity - distDirLayout - storeDirLayout - (jobControlSemaphore jobControl) - buildSettings - downloadMap - registerLock - cacheLock - sharedPackageConfig - installPlan - pkg - pkgBuildStatus + act downloadMap jobControl pkg pkgBuildStatus where keepGoing = buildSettingKeepGoing withRepoCtx = @@ -433,29 +464,6 @@ rebuildTargets _ -> pure () _ -> pure () - -- createPackageDBIfMissing _ _ _ _ = return () - - -- -- all the package dbs we may need to create - -- (Set.toList . Set.fromList) - -- [ pkgdb - -- | InstallPlan.Configured elab <- InstallPlan.toList installPlan - -- , pkgdb <- - -- concat - -- [ elabBuildPackageDBStack elab - -- , elabRegisterPackageDBStack elab - -- , elabSetupPackageDBStack elab - -- ] - -- ] - -- createPackageDBIfMissing - -- verbosity - -- compiler - -- progdb - -- (SpecificPackageDB dbPath) = do - -- exists <- Cabal.doesPackageDBExist dbPath - -- unless exists $ do - -- createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) - -- Cabal.createPackageDB verbosity compiler progdb False dbPath - -- createPackageDBIfMissing _ _ _ _ = return () offlineError :: BuildOutcomes offlineError = Map.fromList . map makeBuildOutcome $ packagesToDownload where @@ -624,6 +632,23 @@ rebuildTarget srcdir builddir +rebuildTargetOnlyDownload + :: Verbosity + -> AsyncFetchMap + -> GenericReadyPackage ElaboratedConfiguredPackage + -> BuildStatus + -> IO BuildResult +rebuildTargetOnlyDownload + verbosity + downloadMap + (ReadyPackage pkg) + pkgBuildStatus = do + case pkgBuildStatus of + BuildStatusDownload -> + void $ waitAsyncPackageDownload verbosity downloadMap pkg + _ -> return () + return $ BuildResult DocsNotTried TestsNotTried Nothing + -- TODO: [nice to have] do we need to use a with-style for the temp -- files for downloading http packages, or are we going to cache them -- persistently? diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs index 3d8b9ff9082..8a54b494f76 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs @@ -25,10 +25,9 @@ import Prelude () import Distribution.Client.FileMonitor (MonitorChangedReason (..)) import Distribution.Client.Types (DocsResult, TestsResult) -import Distribution.Client.ProjectPlanning.Types (ElaboratedPlanPackage) +import Distribution.Client.ProjectPlanning.Types (ElaboratedConfiguredPackage, ElaboratedPlanPackage) import qualified Distribution.Compat.Graph as Graph import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Package (PackageId) import Distribution.Simple.LocalBuildInfo (ComponentName) ------------------------------------------------------------------------------ @@ -162,7 +161,7 @@ instance Exception BuildFailure -- | Detail on the reason that a package failed to build. data BuildFailureReason - = DependentFailed PackageId + = DependentFailed (Graph.Key ElaboratedConfiguredPackage) | GracefulFailure String | DownloadFailed SomeException | UnpackFailed SomeException From e231fcc722c03cb07b8c25db4892dfef4bcc6dc7 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 27 May 2025 13:30:38 +0800 Subject: [PATCH 32/54] feat(cabal-install): more logging in buildAndRegisterUnpackedPackage More logging in ProjectBuilding --- .../Distribution/Client/ProjectBuilding.hs | 12 ++- .../Client/ProjectBuilding/UnpackedPackage.hs | 74 ++++++------------- 2 files changed, 32 insertions(+), 54 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 20b544525db..aca1d70e2ab 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -542,7 +542,8 @@ rebuildTarget void $ waitAsyncPackageDownload verbosity downloadMap pkg _ -> return () return $ BuildResult DocsNotTried TestsNotTried Nothing - | otherwise = + | otherwise = do + info verbosity $ "[rebuildTarget] Rebuilding " ++ prettyShow (nodeKey pkg) ++ " with current status " ++ buildStatusToString pkgBuildStatus -- We rely on the 'BuildStatus' to decide which phase to start from: case pkgBuildStatus of BuildStatusDownload -> downloadPhase @@ -585,7 +586,8 @@ rebuildTarget -- would only start from download or unpack phases. -- rebuildPhase :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> IO BuildResult - rebuildPhase buildStatus srcdir = + rebuildPhase buildStatus srcdir = do + info verbosity $ "[rebuildPhase] Rebuilding " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir assert (isInplaceBuildStyle $ elabBuildStyle pkg) buildInplace @@ -600,7 +602,8 @@ rebuildTarget -- TODO: [nice to have] ^^ do this relative stuff better buildAndInstall :: SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult - buildAndInstall srcdir builddir = + buildAndInstall srcdir builddir = do + info verbosity $ "[buildAndInstall] Building and installing " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir buildAndInstallUnpackedPackage verbosity distDirLayout @@ -616,8 +619,9 @@ rebuildTarget builddir buildInplace :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult - buildInplace buildStatus srcdir builddir = + buildInplace buildStatus srcdir builddir = do -- TODO: [nice to have] use a relative build dir rather than absolute + info verbosity $ "[buildInplace] Building inplace " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir buildInplaceUnpackedPackage verbosity distDirLayout diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 22e88e63ccf..71c750010c7 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -125,6 +125,7 @@ import Distribution.Client.Errors import Distribution.Compat.Directory (listDirectory) import Distribution.Client.ProjectBuilding.PackageFileMonitor +import qualified Distribution.Compat.Graph as Graph import Distribution.System (Platform (..)) -- | Each unpacked package is processed in the following phases: -- @@ -193,54 +194,39 @@ buildAndRegisterUnpackedPackage builddir mlogFile delegate = do + info verbosity $ "\n\nbuildAndRegisterUnpackedPackage: " ++ prettyShow (Graph.nodeKey pkg) -- Configure phase - mbLBI <- - delegate $ - PBConfigurePhase $ - annotateFailure mlogFile ConfigureFailed $ - setup - configureCommand - Cabal.configCommonFlags - configureFlags - configureArgs - (InLibraryArgs $ InLibraryConfigureArgs pkgshared rpkg) + delegate $ + PBConfigurePhase $ + annotateFailure mlogFile ConfigureFailed $ do + info verbosity $ "--- Configure phase " ++ prettyShow (Graph.nodeKey pkg) + setup configureCommand Cabal.configCommonFlags configureFlags configureArgs -- Build phase delegate $ PBBuildPhase $ annotateFailure mlogFile BuildFailed $ do - setup - buildCommand - Cabal.buildCommonFlags - (return . buildFlags) - buildArgs - (InLibraryArgs $ InLibraryPostConfigureArgs SBuildPhase mbLBI) + info verbosity $ "--- Build phase " ++ prettyShow (Graph.nodeKey pkg) + setup buildCommand Cabal.buildCommonFlags (return . buildFlags) buildArgs -- Haddock phase whenHaddock $ delegate $ PBHaddockPhase $ annotateFailure mlogFile HaddocksFailed $ do - setup - haddockCommand - Cabal.haddockCommonFlags - (return . haddockFlags) - haddockArgs - (InLibraryArgs $ InLibraryPostConfigureArgs SHaddockPhase mbLBI) + info verbosity $ "--- Haddock phase " ++ prettyShow (Graph.nodeKey pkg) + setup haddockCommand Cabal.haddockCommonFlags (return . haddockFlags) haddockArgs -- Install phase delegate $ PBInstallPhase { runCopy = \destdir -> - annotateFailure mlogFile InstallFailed $ - setup - Cabal.copyCommand - Cabal.copyCommonFlags - (return . copyFlags destdir) - copyArgs - (InLibraryArgs $ InLibraryPostConfigureArgs SCopyPhase mbLBI) + annotateFailure mlogFile InstallFailed $ do + info verbosity $ "--- Install phase, copy " ++ prettyShow (Graph.nodeKey pkg) + setup Cabal.copyCommand Cabal.copyCommonFlags (return . copyFlags destdir) copyArgs , runRegister = \pkgDBStack registerOpts -> annotateFailure mlogFile InstallFailed $ do + info verbosity $ "--- Install phase, register " ++ prettyShow (Graph.nodeKey pkg) -- We register ourselves rather than via Setup.hs. We need to -- grab and modify the InstalledPackageInfo. We decide what -- the installed package id is, not the build system. @@ -262,37 +248,25 @@ buildAndRegisterUnpackedPackage whenTest $ delegate $ PBTestPhase $ - annotateFailure mlogFile TestsFailed $ - setup - testCommand - Cabal.testCommonFlags - (return . testFlags) - testArgs - (InLibraryArgs $ InLibraryPostConfigureArgs STestPhase mbLBI) + annotateFailure mlogFile TestsFailed $ do + info verbosity $ "--- Test phase " ++ prettyShow (Graph.nodeKey pkg) + setup testCommand Cabal.testCommonFlags (return . testFlags) testArgs -- Bench phase whenBench $ delegate $ PBBenchPhase $ - annotateFailure mlogFile BenchFailed $ - setup - benchCommand - Cabal.benchmarkCommonFlags - (return . benchFlags) - benchArgs - (InLibraryArgs $ InLibraryPostConfigureArgs SBenchPhase mbLBI) + annotateFailure mlogFile BenchFailed $ do + info verbosity $ "--- Benchmark phase " ++ prettyShow (Graph.nodeKey pkg) + setup benchCommand Cabal.benchmarkCommonFlags (return . benchFlags) benchArgs -- Repl phase whenRepl $ delegate $ PBReplPhase $ - annotateFailure mlogFile ReplFailed $ - setupInteractive - replCommand - Cabal.replCommonFlags - (return . replFlags) - replArgs - (InLibraryArgs $ InLibraryPostConfigureArgs SReplPhase mbLBI) + annotateFailure mlogFile ReplFailed $ do + info verbosity $ "--- Repl phase " ++ prettyShow (Graph.nodeKey pkg) + setupInteractive replCommand Cabal.replCommonFlags replFlags replArgs return () where From f7d5e2f0404b55a7e48c3d2cfbb46472030fad1c Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 25 Jun 2025 16:28:25 +0800 Subject: [PATCH 33/54] fix(cabal-install): use the correct packagedb for setup --- .../Distribution/Client/ProjectPlanning.hs | 38 +++++++++++-------- 1 file changed, 23 insertions(+), 15 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index c7f5d0a8eed..1f10d540eaa 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -2266,6 +2266,11 @@ elaborateInstallPlan } = elaboratedPackage where + compilers = fmap toolchainCompiler toolchains + platforms = fmap toolchainPlatform toolchains + programDbs = fmap toolchainProgramDb toolchains + packageDbs = fmap toolchainPackageDBs toolchains + elaboratedPackage = ElaboratedConfiguredPackage{..} buildOptionsAdjustmentWarnings :: LogProgress () @@ -2287,9 +2292,9 @@ elaborateInstallPlan elabPkgSourceId = srcpkgPackageId elabStage = solverPkgStage - elabCompiler = toolchainCompiler (getStage toolchains solverPkgStage) - elabPlatform = toolchainPlatform (getStage toolchains solverPkgStage) - elabProgramDb = toolchainProgramDb (getStage toolchains solverPkgStage) + elabCompiler = getStage compilers elabStage + elabPlatform = getStage platforms elabStage + elabProgramDb = getStage programDbs elabStage elabPkgDescription = case PD.finalizePD solverPkgFlags @@ -2358,9 +2363,10 @@ elaborateInstallPlan if shouldBuildInplaceOnly pkg then BuildInplaceOnly OnDisk else BuildAndInstall - elabPackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain sharedPackageConfig)) - elabBuildPackageDBStack = buildAndRegisterDbs - elabRegisterPackageDBStack = buildAndRegisterDbs + + elabPackageDbs = getStage packageDbs elabStage + elabBuildPackageDBStack = buildAndRegisterDbs elabStage + elabRegisterPackageDBStack = buildAndRegisterDbs elabStage elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription elabSetupScriptCliVersion = @@ -2369,19 +2375,21 @@ elaborateInstallPlan elabPkgDescription libDepGraph solverPkgLibDeps - elabSetupPackageDBStack = buildAndRegisterDbs + elabSetupPackageDBStack = buildAndRegisterDbs (prevStage elabStage) - inplacePackageDbs = corePackageDbs ++ [distPackageDB (compilerId elabCompiler)] + -- Same as corePackageDbs but with the addition of the in-place packagedb. + inplacePackageDbs stage = corePackageDbs stage ++ [SpecificPackageDB (distDirectory "packagedb" prettyShow stage prettyShow (compilerId (getStage compilers stage)))] - corePackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain sharedPackageConfig)) ++ [storePackageDB storeDirLayout elabCompiler] + -- The project packagedbs (typically the global packagedb but others can be added) followed by the store. + corePackageDbs stage = getStage packageDbs stage ++ [storePackageDB storeDirLayout (getStage compilers stage)] - elabInplaceBuildPackageDBStack = inplacePackageDbs - elabInplaceRegisterPackageDBStack = inplacePackageDbs - elabInplaceSetupPackageDBStack = inplacePackageDbs + elabInplaceBuildPackageDBStack = inplacePackageDbs elabStage + elabInplaceRegisterPackageDBStack = inplacePackageDbs elabStage + elabInplaceSetupPackageDBStack = inplacePackageDbs (prevStage elabStage) - buildAndRegisterDbs - | shouldBuildInplaceOnly pkg = inplacePackageDbs - | otherwise = corePackageDbs + buildAndRegisterDbs stage + | shouldBuildInplaceOnly pkg = inplacePackageDbs stage + | otherwise = corePackageDbs stage elabPkgDescriptionOverride = srcpkgDescrOverride From ab85b21ec347c334be34eb3d352dd68d5f2ac61a Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 28 May 2025 10:32:52 +0800 Subject: [PATCH 34/54] fix(cabal-install): fix pkgsToBuildInPlaceOnly Determine packages to build in-place by their solver id, not their package id. --- .../src/Distribution/Client/ProjectPlanning.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 1f10d540eaa..8416a8f395b 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -2551,16 +2551,17 @@ elaborateInstallPlan shouldBuildInplaceOnly :: SolverPackage loc -> Bool shouldBuildInplaceOnly pkg = Set.member - (packageId pkg) + (solverId (ResolverPackage.Configured pkg)) pkgsToBuildInplaceOnly - pkgsToBuildInplaceOnly :: Set PackageId + -- The reverse dependencies of solver packages which match a package id in pkgLocalToProject. + pkgsToBuildInplaceOnly :: Set SolverId pkgsToBuildInplaceOnly = Set.fromList - [ packageId pkg - | stage <- stages - , let solverIds = [PlannedId stage pkgId | pkgId <- Set.toList pkgsLocalToProject] - , pkg <- SolverInstallPlan.reverseDependencyClosure solverPlan solverIds + [ solverId pkg + | spkg <- SolverInstallPlan.toList solverPlan + , packageId spkg `elem` pkgsLocalToProject + , pkg <- SolverInstallPlan.reverseDependencyClosure solverPlan [solverId spkg] ] isLocalToProject :: Package pkg => pkg -> Bool From d8c738189f80740e41223127c446ad8acb14aa16 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Sat, 26 Jul 2025 09:49:55 +0800 Subject: [PATCH 35/54] refactor(cabal-install): seprate build directories and drop -inplace --- .../src/Distribution/Client/DistDirLayout.hs | 27 ++++--------------- .../Distribution/Client/ProjectPlanning.hs | 14 +++++----- .../Client/ProjectPlanning/Types.hs | 3 ++- .../src/Distribution/Client/ScriptUtils.hs | 3 ++- 4 files changed, 16 insertions(+), 31 deletions(-) diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index 0a6e51b09e7..8067c12ecb1 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -34,6 +34,7 @@ import Distribution.Client.Config ( defaultLogsDir , defaultStoreDir ) +import Distribution.Client.Toolchain (Stage) import Distribution.Compiler import Distribution.Package ( ComponentId @@ -51,7 +52,6 @@ import Distribution.Simple.Compiler import Distribution.Simple.Configure (interpretPackageDbFlags) import Distribution.System import Distribution.Types.ComponentName -import Distribution.Types.LibraryName -- | Information which can be used to construct the path to -- the build directory of a build. This is LESS fine-grained @@ -59,7 +59,8 @@ import Distribution.Types.LibraryName -- and for good reason: we don't want this path to change if -- the user, say, adds a dependency to their project. data DistDirParams = DistDirParams - { distParamUnitId :: UnitId + { distParamStage :: Stage + , distParamUnitId :: UnitId , distParamPackageId :: PackageId , distParamComponentId :: ComponentId , distParamComponentName :: Maybe ComponentName @@ -199,28 +200,10 @@ defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir = distBuildDirectory :: DistDirParams -> FilePath distBuildDirectory params = distBuildRootDirectory + prettyShow (distParamStage params) prettyShow (distParamPlatform params) prettyShow (distParamCompilerId params) - prettyShow (distParamPackageId params) - ( case distParamComponentName params of - Nothing -> "" - Just (CLibName LMainLibName) -> "" - Just (CLibName (LSubLibName name)) -> "l" prettyShow name - Just (CFLibName name) -> "f" prettyShow name - Just (CExeName name) -> "x" prettyShow name - Just (CTestName name) -> "t" prettyShow name - Just (CBenchName name) -> "b" prettyShow name - ) - ( case distParamOptimization params of - NoOptimisation -> "noopt" - NormalOptimisation -> "" - MaximumOptimisation -> "opt" - ) - ( let uid_str = prettyShow (distParamUnitId params) - in if uid_str == prettyShow (distParamComponentId params) - then "" - else uid_str - ) + prettyShow (distParamUnitId params) distUnpackedSrcRootDirectory :: FilePath distUnpackedSrcRootDirectory = distDirectory "src" diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 8416a8f395b..e96c67dc336 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1958,21 +1958,21 @@ elaborateInstallPlan elab0 { elabPkgOrComp = ElabComponent elab_comp } + + -- This is where the component id is computed. cid = case elabBuildStyle elab0 of BuildInplaceOnly{} -> mkComponentId $ - prettyShow pkgid - ++ "-inplace" - ++ ( case Cabal.componentNameString cname of - Nothing -> "" - Just s -> "-" ++ prettyShow s - ) + case Cabal.componentNameString cname of + Nothing -> prettyShow pkgid + Just n -> prettyShow pkgid ++ "-" ++ prettyShow n BuildAndInstall -> hashedInstalledPackageId ( packageHashInputs elaboratedSharedConfig elab1 -- knot tied ) + cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} infoProgress $ hang (text "configured component:") 4 (dispConfiguredComponent cc) @@ -2192,7 +2192,7 @@ elaborateInstallPlan pkgInstalledId | shouldBuildInplaceOnly pkg = - mkComponentId (prettyShow srcpkgPackageId ++ "-inplace") + mkComponentId (prettyShow srcpkgPackageId) | otherwise = assert (isJust elabPkgSourceHash) $ hashedInstalledPackageId diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 73679325324..5f611bdcab1 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -566,7 +566,8 @@ elabConfiguredName verbosity elab elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams elabDistDirParams shared elab = DistDirParams - { distParamUnitId = installedUnitId elab + { distParamStage = elabStage elab + , distParamUnitId = installedUnitId elab , distParamComponentId = elabComponentId elab , distParamPackageId = elabPkgSourceId elab , distParamComponentName = case elabPkgOrComp elab of diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index fa530f64ee3..8484ef5489d 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -433,7 +433,8 @@ scriptExeFileName scriptPath = "cabal-script-" ++ takeFileName scriptPath scriptDistDirParams :: FilePath -> ProjectBaseContext -> Compiler -> Platform -> DistDirParams scriptDistDirParams scriptPath ctx compiler platform = DistDirParams - { distParamUnitId = newSimpleUnitId cid + { distParamStage = Host + , distParamUnitId = newSimpleUnitId cid , distParamPackageId = fakePackageId , distParamComponentId = cid , distParamComponentName = Just $ CExeName cn From 67139dd01ef84876985b8ff5cb9c886225c4530f Mon Sep 17 00:00:00 2001 From: Moritz Angermann Date: Thu, 22 May 2025 11:07:51 +0000 Subject: [PATCH 36/54] fix(Cabal): do not use GHC to configure LD Cabal uses a peculiar c program to check if LD supports and should use -x. To do this, it shells out to GHC to compiler the C file. This however requires that GHC will not bail out, yet cabal does not pass --package-db flags to this GHC invocation, and as such we can run into situations where GHC bails out, especially during GHC bootstrap phases where not all boot packages are available. We however do not need GHC to compiler a c program, and can rely on the C compiler. Fundamentally cabal does not allow modelling program dependencies in the program db, as such we must configure gcc first before using it. We make a small change to lib:Cabal (specifically the GHC module, and it's Internal companion) to allow it to configure gcc first, before trying to configure ld, and thus having gcc in scope while configuring ld. This removes the need for the awkward ghc invocation to compiler the test program. --- Cabal/src/Distribution/Simple/GHC.hs | 26 +----- Cabal/src/Distribution/Simple/GHC/Internal.hs | 84 +++++++++++-------- 2 files changed, 49 insertions(+), 61 deletions(-) diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index 68e6d0be374..ba5b1060f44 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -312,30 +312,8 @@ compilerProgramDb verbosity comp progdb1 hcPkgPath = do ghcProg = fromJust $ lookupProgram ghcProgram progdb1 ghcVersion = compilerVersion comp - -- configure gcc, ld, ar etc... based on the paths stored - -- in the GHC settings file - progdb3 = - Internal.configureToolchain - (ghcVersionImplInfo ghcVersion) - ghcProg - (compilerProperties comp) - progdb2 - - -- This is slightly tricky, we have to configure ghc first, then we use the - -- location of ghc to help find ghc-pkg in the case that the user did not - -- specify the location of ghc-pkg directly: - (ghcPkgProg, ghcPkgVersion, progdb4) <- - requireProgramVersion - verbosity - ghcPkgProgram' - anyVersion - progdb3 - - when (ghcVersion /= ghcPkgVersion) $ - dieWithException verbosity $ - VersionMismatchGHC (programPath ghcProg) ghcVersion (programPath ghcPkgProg) ghcPkgVersion - - return progdb4 + -- configure gcc, ld, ar etc... based on the paths stored in the GHC settings file + Internal.configureToolchain verbosity (ghcVersionImplInfo ghcVersion) ghcProg (compilerProperties comp) progdb3 -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find -- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs index f32b0e34eb3..cd26038facf 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -100,37 +100,48 @@ targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo -- | Adjust the way we find and configure gcc and ld configureToolchain - :: GhcImplInfo + :: Verbosity + -> GhcImplInfo -> ConfiguredProgram -> Map String String -> ProgramDb - -> ProgramDb -configureToolchain _implInfo ghcProg ghcInfo = - addKnownProgram - gccProgram - { programFindLocation = findProg gccProgramName extraGccPath - , programPostConf = configureGcc - } - . addKnownProgram - gppProgram - { programFindLocation = findProg gppProgramName extraGppPath - , programPostConf = configureGpp - } - . addKnownProgram - ldProgram - { programFindLocation = findProg ldProgramName extraLdPath - , programPostConf = \v cp -> - -- Call any existing configuration first and then add any new configuration - configureLd v =<< programPostConf ldProgram v cp - } - . addKnownProgram - arProgram - { programFindLocation = findProg arProgramName extraArPath - } - . addKnownProgram - stripProgram - { programFindLocation = findProg stripProgramName extraStripPath - } + -> IO ProgramDb +configureToolchain verbosity _implInfo ghcProg ghcInfo db = do + -- this is a bit of a hack. We have a dependency of ld on gcc. + -- ld needs to compiler a c program, to check an ld feature. + -- we _could_ use ghc as a c frontend, but we do not pass all + -- db stack appropriately, and thus we can run into situations + -- where GHC will fail if it's stricter in it's wired-in-unit + -- selction and has the wrong db stack. However we don't need + -- ghc to compile a _test_ c program. So we configure `gcc` + -- first and then use `gcc` (the generic c compiler in cabal + -- terminology) to compile the test program. + let db' = + flip addKnownProgram db $ + gccProgram + { programFindLocation = findProg gccProgramName extraGccPath + , programPostConf = configureGcc + } + (gccProg, db'') <- requireProgram verbosity gccProgram db' + return $ + flip addKnownPrograms db'' $ + [ gppProgram + { programFindLocation = findProg gppProgramName extraGppPath + , programPostConf = configureGpp + } + , ldProgram + { programFindLocation = findProg ldProgramName extraLdPath + , programPostConf = \v cp -> + -- Call any existing configuration first and then add any new configuration + configureLd gccProg v =<< programPostConf ldProgram v cp + } + , arProgram + { programFindLocation = findProg arProgramName extraArPath + } + , stripProgram + { programFindLocation = findProg stripProgramName extraStripPath + } + ] where compilerDir, base_dir, mingwBinDir :: FilePath compilerDir = takeDirectory (programPath ghcProg) @@ -228,27 +239,26 @@ configureToolchain _implInfo ghcProg ghcInfo = ++ cxxFlags } - configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram - configureLd v ldProg = do - ldProg' <- configureLd' v ldProg + configureLd :: ConfiguredProgram -> Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd gccProg v ldProg = do + ldProg' <- configureLd' gccProg v ldProg return ldProg' { programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags } -- we need to find out if ld supports the -x flag - configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram - configureLd' verbosity ldProg = do + configureLd' :: ConfiguredProgram -> Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd' gccProg v ldProg = do ldx <- withTempFile ".c" $ \testcfile testchnd -> withTempFile ".o" $ \testofile testohnd -> do hPutStrLn testchnd "int foo() { return 0; }" hClose testchnd hClose testohnd runProgram - verbosity - ghcProg - [ "-hide-all-packages" - , "-c" + v + gccProg + [ "-c" , testcfile , "-o" , testofile From 7371984a6f7ab188222a52820c6a8c97e8501f45 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 10 Jul 2025 16:52:55 +0800 Subject: [PATCH 37/54] feat(cabal-install): add parser for UserQualExe --- cabal-install/src/Distribution/Client/Targets.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs index 042c3465f23..05a7e3057d4 100644 --- a/cabal-install/src/Distribution/Client/Targets.hs +++ b/cabal-install/src/Distribution/Client/Targets.hs @@ -722,9 +722,10 @@ instance Parsec UserConstraint where withColon :: PackageName -> m UserConstraintQualifier withColon pn = - UserQualified (UserQualSetup pn) - <$ P.string "setup." - <*> parsec + P.choice + [ UserQualified (UserQualSetup pn) <$> (P.string "setup." *> parsec) + , UserQualified . UserQualExe pn <$> (P.string "exe:" *> parsec) <*> (P.char '.' *> parsec) + ] -- >>> eitherParsec "foo > 1.2.3.4" :: Either String UserConstraint -- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified UserQualToplevel (PackageName "foo"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) @@ -746,3 +747,6 @@ instance Parsec UserConstraint where -- -- >>> eitherParsec "build:ghc-internal installed" :: Either String UserConstraint -- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "ghc-internal"))) PackagePropertyInstalled) +-- +-- >>> eitherParsec "foo:exe:bar.baz > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified (UserQualExe (PackageName "foo") (PackageName "bar")) (PackageName "baz"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) From 588e26b48251ef99d85569d0ee799d284de7b3c5 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 10 Jul 2025 16:52:55 +0800 Subject: [PATCH 38/54] feat(cabal-install): add ScopeAnyExeQualifier and UserAnyExeQualifier --- .../Solver/Types/PackageConstraint.hs | 33 +++++++++++-------- .../src/Distribution/Client/Targets.hs | 26 +++++++++++---- 2 files changed, 39 insertions(+), 20 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index 9a6c2a665b0..4a7856c877a 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -57,11 +57,11 @@ data ConstraintQualifier = ScopeTarget PackageName -- | The package with the specified name and qualifier. | ScopeQualified Qualifier PackageName - -- | The package with the specified name when it has a - -- setup qualifier. + -- | The package with the specified name when it has a setup qualifier. | ScopeAnySetupQualifier PackageName - -- | The package with the specified name regardless of - -- qualifier. + -- | The package with the specified name when it has an exe qualifier. + | ScopeAnyExeQualifier PackageName + -- | The package with the specified name regardless of qualifier. | ScopeAnyQualifier PackageName deriving (Eq, Show) @@ -76,6 +76,7 @@ scopeToPackageName :: ConstraintScope -> PackageName scopeToPackageName (ConstraintScope _stage (ScopeTarget pn)) = pn scopeToPackageName (ConstraintScope _stage (ScopeQualified _ pn)) = pn scopeToPackageName (ConstraintScope _stage (ScopeAnySetupQualifier pn)) = pn +scopeToPackageName (ConstraintScope _stage (ScopeAnyExeQualifier pn)) = pn scopeToPackageName (ConstraintScope _stage (ScopeAnyQualifier pn)) = pn constraintScopeMatches :: ConstraintScope -> QPN -> Bool @@ -83,15 +84,20 @@ constraintScopeMatches (ConstraintScope mstage qualifier) (Q (PackagePath stage' maybe True (== stage') mstage && constraintQualifierMatches qualifier q pn' constraintQualifierMatches :: ConstraintQualifier -> Qualifier -> PackageName -> Bool -constraintQualifierMatches (ScopeTarget pn) q pn' = - q == QualToplevel && pn == pn' -constraintQualifierMatches (ScopeQualified q pn) q' pn' = - q == q' && pn == pn' -constraintQualifierMatches (ScopeAnySetupQualifier pn) (QualSetup _) pn' = - pn == pn' -constraintQualifierMatches (ScopeAnyQualifier pn) _ pn' = - pn == pn' -constraintQualifierMatches _ _ _ = False +constraintQualifierMatches (ScopeTarget pn) QualToplevel pn' = pn == pn' +constraintQualifierMatches (ScopeTarget _) (QualSetup _) _ = False +constraintQualifierMatches (ScopeTarget _) (QualExe _ _) _ = False +constraintQualifierMatches (ScopeTarget _) (QualBase _) _ = False +constraintQualifierMatches (ScopeQualified q pn) q' pn' = q == q' && pn == pn' +constraintQualifierMatches (ScopeAnySetupQualifier _) QualToplevel _ = False +constraintQualifierMatches (ScopeAnySetupQualifier _) (QualExe _ _) _ = False +constraintQualifierMatches (ScopeAnySetupQualifier pn) (QualSetup _) pn' = pn == pn' +constraintQualifierMatches (ScopeAnySetupQualifier _) (QualBase _) _ = False +constraintQualifierMatches (ScopeAnyExeQualifier pn) (QualExe _ _) pn' = pn == pn' +constraintQualifierMatches (ScopeAnyExeQualifier _) QualToplevel _ = False +constraintQualifierMatches (ScopeAnyExeQualifier _) (QualSetup _) _compile = False +constraintQualifierMatches (ScopeAnyExeQualifier _) (QualBase _) _ = False +constraintQualifierMatches (ScopeAnyQualifier pn) _ pn' = pn == pn' instance Pretty ConstraintScope where pretty (ConstraintScope mstage qualifier) = @@ -101,6 +107,7 @@ instance Pretty ConstraintQualifier where pretty (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn pretty (ScopeQualified q pn) = dispQualifier q <<>> pretty pn pretty (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn + pretty (ScopeAnyExeQualifier pn) = Disp.text "exe." <<>> pretty pn pretty (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn -- | A package property is a logical predicate on packages. diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs index 05a7e3057d4..842ae94eb57 100644 --- a/cabal-install/src/Distribution/Client/Targets.hs +++ b/cabal-install/src/Distribution/Client/Targets.hs @@ -625,6 +625,8 @@ data UserConstraintQualifier UserQualified UserQualifier PackageName | -- | Scope that applies to the package when it has a setup qualifier. UserAnySetupQualifier PackageName + | -- | Scope that applies to the package when it has a setup qualifier. + UserAnyExeQualifier PackageName | -- | Scope that applies to the package when it has any qualifier. UserAnyQualifier PackageName deriving (Eq, Show, Generic) @@ -642,6 +644,8 @@ fromUserConstraintScope (UserConstraintScope mstage (UserQualified q pn)) = ConstraintScope mstage (ScopeQualified (fromUserQualifier q) pn) fromUserConstraintScope (UserConstraintScope mstage (UserAnySetupQualifier pn)) = ConstraintScope mstage (ScopeAnySetupQualifier pn) +fromUserConstraintScope (UserConstraintScope mstage (UserAnyExeQualifier pn)) = + ConstraintScope mstage (ScopeAnyExeQualifier pn) fromUserConstraintScope (UserConstraintScope mstage (UserAnyQualifier pn)) = ConstraintScope mstage (ScopeAnyQualifier pn) @@ -667,6 +671,7 @@ userConstraintPackageName (UserConstraintX (UserConstraintScope _stage qualifier scopePN (UserQualified _ pn) = pn scopePN (UserAnyQualifier pn) = pn scopePN (UserAnySetupQualifier pn) = pn + scopePN (UserAnyExeQualifier pn) = pn userToPackageConstraint :: UserConstraint -> PackageConstraint userToPackageConstraint (UserConstraintX scope prop) = @@ -718,6 +723,7 @@ instance Parsec UserConstraint where withDot pn | pn == mkPackageName "any" = UserAnyQualifier <$> parsec | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec + | pn == mkPackageName "exe" = UserAnyExeQualifier <$> parsec | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn withColon :: PackageName -> m UserConstraintQualifier @@ -733,20 +739,26 @@ instance Parsec UserConstraint where -- >>> eitherParsec "foo ^>= 1.2.3.4" :: Either String UserConstraint -- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified UserQualToplevel (PackageName "foo"))) (PackagePropertyVersion (MajorBoundVersion (mkVersion [1,2,3,4])))) -- +-- >>> eitherParsec "any.bar > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnyQualifier (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "setup.bar > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "exe.bar > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnyExeQualifier (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) +-- -- >>> eitherParsec "foo:setup.bar > 1.2.3.4" :: Either String UserConstraint -- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified (UserQualSetup (PackageName "foo")) (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) -- --- >>> eitherParsec "setup.any source" :: Either String UserConstraint --- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "any"))) PackagePropertySource) --- -- >>> eitherParsec "build:rts source" :: Either String UserConstraint -- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "rts"))) PackagePropertySource) -- --- >>> eitherParsec "setup.any installed" :: Either String UserConstraint --- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "any"))) PackagePropertyInstalled) +-- >>> eitherParsec "build:any.rts source" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope (Just Build) (UserAnyQualifier (PackageName "rts"))) PackagePropertySource) -- --- >>> eitherParsec "build:ghc-internal installed" :: Either String UserConstraint --- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "ghc-internal"))) PackagePropertyInstalled) +-- >>> eitherParsec "setup.ghc-internal installed" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "ghc-internal"))) PackagePropertyInstalled) -- -- >>> eitherParsec "foo:exe:bar.baz > 1.2.3.4" :: Either String UserConstraint -- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified (UserQualExe (PackageName "foo") (PackageName "bar")) (PackageName "baz"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) From f78f6f6ab2a5835648994000ab2e386ac15f6b3e Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 28 Jul 2025 12:10:29 +0800 Subject: [PATCH 39/54] refactor(cabal-install): refactor InstallPlan.problems Split the function into multiple ones. --- .../src/Distribution/Client/InstallPlan.hs | 78 ++++++++++++++----- 1 file changed, 59 insertions(+), 19 deletions(-) diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index f9edbde6fe0..fd9b3e88772 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -1056,11 +1056,19 @@ valid loc graph = ps -> internalError loc ('\n' : unlines (map showPlanProblem ps)) data PlanProblem ipkg srcpkg - = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [GraphKey ipkg srcpkg] - | PackageCycle [GenericPlanPackage ipkg srcpkg] + = PackageMissingDeps + (GenericPlanPackage ipkg srcpkg) + -- ^ The package that is missing dependencies + [GraphKey ipkg srcpkg] + -- ^ The missing dependencies + | -- | The packages involved in a dependency cycle + PackageCycle + [GenericPlanPackage ipkg srcpkg] | PackageStateInvalid (GenericPlanPackage ipkg srcpkg) + -- ^ The package that is in an invalid state (GenericPlanPackage ipkg srcpkg) + -- ^ The package that it depends on which is in an invalid state showPlanProblem :: ( IsGraph ipkg srcpkg @@ -1095,6 +1103,18 @@ problems => Graph (GenericPlanPackage ipkg srcpkg) -> [PlanProblem ipkg srcpkg] problems graph = + concat + [ checkForMissingDeps graph + , checkForCycles graph + , -- , checkForDependencyInconsistencies graph + checkForPackageStateInconsistencies graph + ] + +checkForMissingDeps + :: IsGraph ipkg srcpkg + => Graph (GenericPlanPackage ipkg srcpkg) + -> [PlanProblem ipkg srcpkg] +checkForMissingDeps graph = [ PackageMissingDeps pkg ( mapMaybe @@ -1103,23 +1123,43 @@ problems graph = ) | (pkg, missingDeps) <- Graph.broken graph ] - ++ [ PackageCycle cycleGroup - | cycleGroup <- Graph.cycles graph - ] - {- - ++ [ PackageInconsistency name inconsistencies - | (name, inconsistencies) <- - dependencyInconsistencies indepGoals graph ] - --TODO: consider re-enabling this one, see SolverInstallPlan - -} - ++ [ PackageStateInvalid pkg pkg' - | pkg <- Foldable.toList graph - , Just pkg' <- - map - (`Graph.lookup` graph) - (nodeNeighbors pkg) - , not (stateDependencyRelation pkg pkg') - ] + +checkForCycles + :: IsGraph ipkg srcpkg + => Graph (GenericPlanPackage ipkg srcpkg) + -> [PlanProblem ipkg srcpkg] +checkForCycles graph = + [PackageCycle cycleGroup | cycleGroup <- Graph.cycles graph] + +-- TODO: consider re-enabling this one, see SolverInstallPlan +-- +-- checkForDependencyInconsistencies +-- :: ( IsGraph ipkg srcpkg +-- , Pretty (GraphKey ipkg srcpkg) +-- , Key srcpkg ~ PlanProblem ipkg srcpkg +-- , Key ipkg ~ GraphKey ipkg srcpkg +-- ) +-- => Graph (GenericPlanPackage ipkg srcpkg) +-- -> [PlanProblem ipkg srcpkg] +-- checkForDependencyInconsistencies graph = +-- [ PackageInconsistency name inconsistencies +-- | (name, inconsistencies) <- +-- dependencyInconsistencies indepGoals graph +-- ] + +checkForPackageStateInconsistencies + :: IsGraph ipkg srcpkg + => Graph (GenericPlanPackage ipkg srcpkg) + -> [PlanProblem ipkg srcpkg] +checkForPackageStateInconsistencies graph = + [ PackageStateInvalid pkg pkg' + | pkg <- Foldable.toList graph + , Just pkg' <- + map + (flip Graph.lookup graph) + (nodeNeighbors pkg) + , not (stateDependencyRelation pkg pkg') + ] -- | The states of packages have that depend on each other must respect -- this relation. That is for very case where package @a@ depends on From 59d259ce78bb862a61e07bf8c1f3f888e94dccfa Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Fri, 1 Aug 2025 14:37:46 +0800 Subject: [PATCH 40/54] refactor(cabal-install): use LogProgress in InstallPlan --- Cabal/src/Distribution/Utils/LogProgress.hs | 5 + .../src/Distribution/Client/CmdBench.hs | 15 +- .../src/Distribution/Client/CmdBuild.hs | 26 ++- .../src/Distribution/Client/CmdGenBounds.hs | 12 +- .../src/Distribution/Client/CmdHaddock.hs | 13 +- .../Distribution/Client/CmdHaddockProject.hs | 12 +- .../src/Distribution/Client/CmdInstall.hs | 20 +- .../src/Distribution/Client/CmdListBin.hs | 13 +- .../src/Distribution/Client/CmdRepl.hs | 23 ++- .../src/Distribution/Client/CmdRun.hs | 13 +- .../src/Distribution/Client/CmdTest.hs | 13 +- .../src/Distribution/Client/InstallPlan.hs | 176 ++++++++++-------- .../Client/ProjectOrchestration.hs | 5 +- .../Distribution/Client/ProjectPlanning.hs | 44 +++-- .../Client/ProjectPlanning/Types.hs | 2 +- cabal-install/tests/IntegrationTests2.hs | 13 +- .../Distribution/Client/InstallPlan.hs | 41 ++-- 17 files changed, 252 insertions(+), 194 deletions(-) diff --git a/Cabal/src/Distribution/Utils/LogProgress.hs b/Cabal/src/Distribution/Utils/LogProgress.hs index ba55cdab294..3a5eb7846be 100644 --- a/Cabal/src/Distribution/Utils/LogProgress.hs +++ b/Cabal/src/Distribution/Utils/LogProgress.hs @@ -9,6 +9,7 @@ module Distribution.Utils.LogProgress , infoProgress , dieProgress , addProgressCtx + , eitherToLogProgress , ErrMsg ) where @@ -112,3 +113,7 @@ formatMsg ctx doc = doc $$ vcat ctx addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a addProgressCtx s (LogProgress m) = LogProgress $ \env -> m env{le_context = s : le_context env} + +eitherToLogProgress :: Either Doc a -> LogProgress a +eitherToLogProgress (Left err) = dieProgress err +eitherToLogProgress (Right a) = return a diff --git a/cabal-install/src/Distribution/Client/CmdBench.hs b/cabal-install/src/Distribution/Client/CmdBench.hs index f9adc80432b..177b8263a1a 100644 --- a/cabal-install/src/Distribution/Client/CmdBench.hs +++ b/cabal-install/src/Distribution/Client/CmdBench.hs @@ -50,6 +50,9 @@ import Distribution.Simple.Utils , warn , wrapText ) +import Distribution.Utils.LogProgress + ( runLogProgress + ) import Distribution.Verbosity ( normal ) @@ -133,11 +136,13 @@ benchAction flags targetStrings globalFlags = do Nothing targetSelectors - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBench - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionBench + targets + elaboratedPlan + return (elaboratedPlan', targets) printPlan verbosity baseCtx buildCtx diff --git a/cabal-install/src/Distribution/Client/CmdBuild.hs b/cabal-install/src/Distribution/Client/CmdBuild.hs index 7314187b815..b8ca8a3dfd2 100644 --- a/cabal-install/src/Distribution/Client/CmdBuild.hs +++ b/cabal-install/src/Distribution/Client/CmdBuild.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + -- | cabal-install CLI command: build module Distribution.Client.CmdBuild ( -- * The @build@ CLI and action @@ -26,6 +28,7 @@ import Distribution.Client.TargetProblem import qualified Data.Map as Map import Distribution.Client.Errors +import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.NixStyleOptions ( NixStyleFlags (..) , cfgVerbosity @@ -52,6 +55,7 @@ import Distribution.Simple.Utils ( dieWithException , wrapText ) +import Distribution.Utils.LogProgress (runLogProgress) import Distribution.Verbosity ( normal ) @@ -161,18 +165,20 @@ buildAction flags@NixStyleFlags{extraFlags = buildFlags} targetStrings globalFla Nothing targetSelectors - let elaboratedPlan' = - pruneInstallPlanToTargets - targetAction - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + targetAction + targets + elaboratedPlan + elaboratedPlan'' <- if buildSettingOnlyDeps (buildSettings baseCtx) - then - either (reportCannotPruneDependencies verbosity) return $ - pruneInstallPlanToDependencies - (Map.keysSet targets) - elaboratedPlan' + then case pruneInstallPlanToDependencies (Map.keysSet targets) elaboratedPlan' of + Left err -> + reportCannotPruneDependencies verbosity err + Right elaboratedPlan'' -> + runLogProgress verbosity $ InstallPlan.new' elaboratedPlan'' else return elaboratedPlan' return (elaboratedPlan'', targets) diff --git a/cabal-install/src/Distribution/Client/CmdGenBounds.hs b/cabal-install/src/Distribution/Client/CmdGenBounds.hs index 5989fb55e23..6188ef3d46a 100644 --- a/cabal-install/src/Distribution/Client/CmdGenBounds.hs +++ b/cabal-install/src/Distribution/Client/CmdGenBounds.hs @@ -27,6 +27,7 @@ import Distribution.Simple.Utils import Distribution.Version import Distribution.Client.Setup (GlobalFlags (..)) +import Distribution.Utils.LogProgress (runLogProgress) -- Project orchestration imports @@ -114,11 +115,12 @@ genBoundsAction flags targetStrings globalFlags = targetSelectors -- Step 3: Prune the install plan to the targets. - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan let -- Step 4a: Find the local packages from the install plan. These are the diff --git a/cabal-install/src/Distribution/Client/CmdHaddock.hs b/cabal-install/src/Distribution/Client/CmdHaddock.hs index a3cc048e210..d741211f286 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddock.hs @@ -75,6 +75,7 @@ import Distribution.Verbosity ) import Distribution.Client.Errors +import Distribution.Utils.LogProgress (runLogProgress) import qualified System.Exit (exitSuccess) newtype ClientHaddockFlags = ClientHaddockFlags {openInBrowser :: Flag Bool} @@ -189,11 +190,13 @@ haddockAction relFlags targetStrings globalFlags = do Nothing targetSelectors - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionHaddock - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionHaddock + targets + elaboratedPlan + return (elaboratedPlan', targets) printPlan verbosity baseCtx buildCtx diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index a530491c09d..c191171891e 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -98,6 +98,7 @@ import Distribution.Types.PackageDescription (PackageDescription (benchmarks, su import Distribution.Types.PackageId (pkgName) import Distribution.Types.PackageName (unPackageName) import Distribution.Types.UnitId (unUnitId) +import Distribution.Utils.LogProgress (runLogProgress) import Distribution.Verbosity as Verbosity ( defaultVerbosityHandles , mkVerbosity @@ -149,11 +150,12 @@ haddockProjectAction flags _extraArgs globalFlags = do Nothing targetSelectors - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan return (elaboratedPlan', targets) let elaboratedPlan :: ElaboratedInstallPlan diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 6fb13d63a9a..e06d51ca1e0 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -215,6 +215,9 @@ import Distribution.Types.VersionRange import Distribution.Utils.Generic ( writeFileAtomic ) +import Distribution.Utils.LogProgress + ( runLogProgress + ) import Distribution.Verbosity ( lessVerbose , modifyVerbosityFlags @@ -897,15 +900,18 @@ constructProjectBuildContext verbosity baseCtx targetSelectors = do Nothing targetSelectors - let prunedToTargetsElaboratedPlan = - pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan + prunedToTargetsElaboratedPlan <- + runLogProgress verbosity $ + pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan + prunedElaboratedPlan <- if buildSettingOnlyDeps (buildSettings baseCtx) - then - either (reportCannotPruneDependencies verbosity) return $ - pruneInstallPlanToDependencies - (Map.keysSet targets) - prunedToTargetsElaboratedPlan + then do + case pruneInstallPlanToDependencies (Map.keysSet targets) prunedToTargetsElaboratedPlan of + Left err -> + reportCannotPruneDependencies verbosity err + Right elaboratedPlan'' -> + runLogProgress verbosity $ InstallPlan.new' elaboratedPlan'' else return prunedToTargetsElaboratedPlan return (prunedElaboratedPlan, targets) diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index 4dc55162dc6..31ac72dad98 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -60,6 +60,7 @@ import Distribution.Client.Errors import qualified Distribution.Client.InstallPlan as IP import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Utils.LogProgress (runLogProgress) ------------------------------------------------------------------------------- -- Command @@ -127,11 +128,13 @@ listbinAction flags args globalFlags = do ) targets - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) (selectedUnitId, selectedComponent) <- diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index 1bab56d3e70..fa947c9fe5f 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -161,6 +161,9 @@ import Distribution.Types.VersionRange import Distribution.Utils.Generic ( safeHead ) +import Distribution.Utils.LogProgress + ( runLogProgress + ) import Distribution.Verbosity ( lessVerbose , modifyVerbosityFlags @@ -475,18 +478,14 @@ targetedRepl -- Recalculate with updated project. targets <- validatedTargets (projectConfigShared projectConfig) toolchainCompiler elaboratedPlan targetSelectors - let - elaboratedPlan' = - -- Guard against pruning with empty targets and failing an assertion - -- within pruneInstallPlanToTargets. - if null targets - then elaboratedPlan - else - pruneInstallPlanToTargets - TargetActionRepl - targets - elaboratedPlan - includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags) + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionRepl + targets + elaboratedPlan + + let includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags) pkgsBuildStatus <- rebuildTargetsDryRun diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index c6ce5f8b845..8d0be986894 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -124,6 +124,7 @@ import Distribution.Types.UnqualComponentName ( UnqualComponentName , unUnqualComponentName ) +import Distribution.Utils.LogProgress (runLogProgress) import Distribution.Utils.NubList ( fromNubList ) @@ -246,11 +247,13 @@ runAction flags targetAndArgs globalFlags = do ) targets - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) (selectedUnitId, selectedComponent) <- diff --git a/cabal-install/src/Distribution/Client/CmdTest.hs b/cabal-install/src/Distribution/Client/CmdTest.hs index 14b4b8a8d7d..563cea4c64d 100644 --- a/cabal-install/src/Distribution/Client/CmdTest.hs +++ b/cabal-install/src/Distribution/Client/CmdTest.hs @@ -67,6 +67,7 @@ import Distribution.Verbosity import qualified System.Exit (exitSuccess) import Distribution.Client.Errors +import Distribution.Utils.LogProgress (runLogProgress) import GHC.Environment ( getFullArgs ) @@ -151,11 +152,13 @@ testAction flags@NixStyleFlags{..} targetStrings globalFlags = do Nothing targetSelectors - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionTest - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionTest + targets + elaboratedPlan + return (elaboratedPlan', targets) printPlan verbosity baseCtx buildCtx diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index fd9b3e88772..dd18ba0b4c4 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -28,9 +28,11 @@ module Distribution.Client.InstallPlan , PlanPackage , GenericPlanPackage (..) , foldPlanPackage + , renderPlanPackageTag -- * Operations on 'InstallPlan's , new + , new' , toGraph , toList , toMap @@ -62,11 +64,13 @@ module Distribution.Client.InstallPlan , failed -- * Display - , showPlanGraph + , renderPlanGraph , ShowPlanNode (..) , showInstallPlan , showInstallPlan_gen - , showPlanPackageTag + , PlanProblem + , renderPlanProblem + , renderPlanProblems -- * Graph-like operations , dependencyClosure @@ -95,7 +99,6 @@ import Distribution.Package , HasUnitId (..) , Package (..) ) -import Distribution.Pretty (defaultStyle) import Distribution.Solver.Types.SolverPackage import Text.PrettyPrint @@ -117,6 +120,7 @@ import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import qualified Data.Foldable as Foldable (all, toList) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Compat.Graph (Graph, IsNode (..)) @@ -289,23 +293,6 @@ type InstallPlan = InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) --- | Smart constructor that deals with caching the 'Graph' representation. -mkInstallPlan - :: ( IsGraph ipkg srcpkg - , Pretty (GraphKey ipkg srcpkg) - ) - => String - -> Graph (GenericPlanPackage ipkg srcpkg) - -> IndependentGoals - -> GenericInstallPlan ipkg srcpkg -mkInstallPlan loc graph indepGoals = - assert - (valid loc graph) - GenericInstallPlan - { planGraph = graph - , planIndepGoals = indepGoals - } - internalError :: WithCallStack (String -> String -> a) internalError loc msg = error $ @@ -343,23 +330,24 @@ instance } = put graph >> put indepGoals get = do - graph <- get - indepGoals <- get - return $! mkInstallPlan "(instance Binary)" graph indepGoals + graph <- mkInstallPlan <$> get + return $! either (const (error "Deserialised invalid GenericInstallPlan")) id graph data ShowPlanNode = ShowPlanNode { showPlanHerald :: Doc , showPlanNeighbours :: [Doc] } -showPlanGraph :: [ShowPlanNode] -> String -showPlanGraph graph = - renderStyle defaultStyle $ - vcat (map dispPlanPackage graph) +renderPlanGraph :: [ShowPlanNode] -> Doc +renderPlanGraph graph = + vcat (map dispPlanPackage graph) where dispPlanPackage (ShowPlanNode herald neighbours) = hang herald 2 (vcat neighbours) +showPlanGraph :: [ShowPlanNode] -> String +showPlanGraph = render . renderPlanGraph + -- | Generic way to show a 'GenericInstallPlan' which elicits quite a lot of information showInstallPlan_gen :: forall ipkg srcpkg @@ -383,26 +371,59 @@ showInstallPlan = showInstallPlan_gen toShow toShow p = ShowPlanNode ( hsep - [ text (showPlanPackageTag p) + [ renderPlanPackageTag p , pretty (packageId p) , parens (pretty (nodeKey p)) ] ) (map pretty (nodeNeighbors p)) -showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String -showPlanPackageTag (PreExisting _) = "PreExisting" -showPlanPackageTag (Configured _) = "Configured" -showPlanPackageTag (Installed _) = "Installed" +renderPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> Doc +renderPlanPackageTag (PreExisting _) = text "pre-existing" +renderPlanPackageTag (Configured _) = text "configured" +renderPlanPackageTag (Installed _) = text "installed" + +-- | Smart constructor that deals with caching the 'Graph' representation. +mkInstallPlan + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) + => Graph (GenericPlanPackage ipkg srcpkg) + -> Either Doc (GenericInstallPlan ipkg srcpkg) +mkInstallPlan graph = + case NE.nonEmpty (problems graph) of + Just problems' -> Left $ renderPlanProblems (NE.toList problems') + Nothing -> Right $ GenericInstallPlan{planGraph = graph} + +mkInstallPlan' + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) + => Graph (GenericPlanPackage ipkg srcpkg) + -> Either (NonEmpty (PlanProblem ipkg srcpkg)) (GenericInstallPlan ipkg srcpkg) +mkInstallPlan' graph = + case NE.nonEmpty (problems graph) of + Just problems' -> Left problems' + Nothing -> Right $ GenericInstallPlan{planGraph = graph} --- | Build an installation plan from a valid set of resolved packages. +-- | Build an installation plan from a set of packages. new + :: ( IsGraph ipkg srcpkg + , Show (GraphKey ipkg srcpkg) + , Pretty (GraphKey ipkg srcpkg) + ) + => [GenericPlanPackage ipkg srcpkg] + -> LogProgress (GenericInstallPlan ipkg srcpkg) +new = eitherToLogProgress . mkInstallPlan . Graph.fromDistinctList + +-- | Build an installation plan from a graph of packages. +new' :: ( IsGraph ipkg srcpkg , Pretty (GraphKey ipkg srcpkg) ) => Graph (GenericPlanPackage ipkg srcpkg) - -> GenericInstallPlan ipkg srcpkg -new indepGoals graph = mkInstallPlan "new" graph indepGoals + -> LogProgress (GenericInstallPlan ipkg srcpkg) +new' = eitherToLogProgress . mkInstallPlan toGraph :: GenericInstallPlan ipkg srcpkg @@ -437,13 +458,9 @@ remove ) => (GenericPlanPackage ipkg srcpkg -> Bool) -> GenericInstallPlan ipkg srcpkg - -> GenericInstallPlan ipkg srcpkg + -> Either (NonEmpty (PlanProblem ipkg srcpkg)) (GenericInstallPlan' (Key srcpkg) ipkg srcpkg) remove shouldRemove plan = - mkInstallPlan "remove" newGraph (planIndepGoals plan) - where - newGraph = - Graph.fromDistinctList $ - filter (not . shouldRemove) (toList plan) + mkInstallPlan' $ Graph.fromDistinctList $ filter (not . shouldRemove) (toList plan) -- | Change a number of packages in the 'Configured' state to the 'Installed' -- state. @@ -603,11 +620,7 @@ fromSolverInstallPlanWithProgress f plan = do f' (Map.empty, []) (SolverInstallPlan.reverseTopologicalOrder plan) - return $ - mkInstallPlan - "fromSolverInstallPlanWithProgress" - (Graph.fromDistinctList pkgs'') - (SolverInstallPlan.planIndepGoals plan) + new' (Graph.fromDistinctList pkgs'') where f' (pMap, pkgs) pkg = do pkgs' <- f (mapDep pMap) pkg @@ -1039,22 +1052,6 @@ execute jobCtl keepGoing depFailure plan installPkg = -- ------------------------------------------------------------ --- | A valid installation plan is a set of packages that is closed, acyclic --- and respects the package state relation. --- --- * if the result is @False@ use 'problems' to get a detailed list. -valid - :: ( IsGraph ipkg srcpkg - , Pretty (GraphKey ipkg srcpkg) - ) - => String - -> Graph (GenericPlanPackage ipkg srcpkg) - -> Bool -valid loc graph = - case problems graph of - [] -> True - ps -> internalError loc ('\n' : unlines (map showPlanProblem ps)) - data PlanProblem ipkg srcpkg = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) @@ -1070,30 +1067,45 @@ data PlanProblem ipkg srcpkg (GenericPlanPackage ipkg srcpkg) -- ^ The package that it depends on which is in an invalid state -showPlanProblem +renderPlanProblems + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) + => [PlanProblem ipkg srcpkg] + -> Doc +renderPlanProblems = + vcat . map renderPlanProblem + +renderPlanProblem :: ( IsGraph ipkg srcpkg , Pretty (GraphKey ipkg srcpkg) ) => PlanProblem ipkg srcpkg - -> String -showPlanProblem (PackageMissingDeps pkg missingDeps) = - "Package " - ++ prettyShow (nodeKey pkg) - ++ " depends on the following packages which are missing from the plan: " - ++ intercalate ", " (map prettyShow missingDeps) -showPlanProblem (PackageCycle cycleGroup) = - "The following packages are involved in a dependency cycle " - ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup) -showPlanProblem (PackageStateInvalid pkg pkg') = - "Package " - ++ prettyShow (nodeKey pkg) - ++ " is in the " - ++ showPlanPackageTag pkg - ++ " state but it depends on package " - ++ prettyShow (nodeKey pkg') - ++ " which is in the " - ++ showPlanPackageTag pkg' - ++ " state" + -> Doc +renderPlanProblem (PackageMissingDeps pkg missingDeps) = + fsep + [ text "Package" + , pretty (nodeKey pkg) + , text "depends on the following packages which are missing from the plan:" + , fsep (punctuate comma (map pretty missingDeps)) + ] +renderPlanProblem (PackageCycle cycleGroup) = + fsep + [ text "The following packages are involved in a dependency cycle:" + , fsep (punctuate comma (map (pretty . nodeKey) cycleGroup)) + ] +renderPlanProblem (PackageStateInvalid pkg pkg') = + fsep + [ text "Package" + , pretty (nodeKey pkg) + , text "is in the" + , renderPlanPackageTag pkg + , text "state but it depends on package" + , pretty (nodeKey pkg') + , text "which is in the" + , renderPlanPackageTag pkg' + , text "state" + ] -- | For an invalid plan, produce a detailed list of problems as human readable -- error messages. This is mainly intended for debugging purposes. diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 5bdccc935a1..7c3f0ca700e 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -200,6 +200,9 @@ import Distribution.Types.Flag , diffFlagAssignment , showFlagAssignment ) +import Distribution.Utils.LogProgress + ( LogProgress + ) import Distribution.Utils.NubList ( fromNubList ) @@ -1043,7 +1046,7 @@ pruneInstallPlanToTargets :: TargetAction -> TargetsMapS -> ElaboratedInstallPlan - -> ElaboratedInstallPlan + -> LogProgress ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = assert (Map.size targetsMap > 0) $ ProjectPlanning.pruneInstallPlanToTargets diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index e96c67dc336..0b429cc2401 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -997,10 +997,9 @@ rebuildInstallPlan defaultInstallDirs <- liftIO $ userInstallDirTemplates (toolchainCompiler t) return $ fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) - (elaboratedPlan, elaboratedShared) <- - liftIO - . runLogProgress verbosity - $ elaborateInstallPlan + liftIO $ runLogProgress verbosity $ do + (elaboratedPlan, elaboratedShared) <- + elaborateInstallPlan verbosity toolchains pkgConfigDB @@ -1014,14 +1013,17 @@ rebuildInstallPlan projectConfigAllPackages projectConfigLocalPackages (getMapMappend projectConfigSpecificPackage) - let instantiatedPlan = - instantiateInstallPlan - cabalStoreDirLayout - installDirs - elaboratedShared - elaboratedPlan - liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan instantiatedPlan) - return (instantiatedPlan, elaboratedShared) + + instantiatedPlan <- + instantiateInstallPlan + cabalStoreDirLayout + installDirs + elaboratedShared + elaboratedPlan + + infoProgress $ text "Elaborated install plan:" $$ text (showElaboratedInstallPlan instantiatedPlan) + + return (instantiatedPlan, elaboratedShared) where withRepoCtx :: (RepoContext -> IO a) -> IO a withRepoCtx = @@ -2921,11 +2923,9 @@ instantiateInstallPlan -> Staged InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan - -> ElaboratedInstallPlan -instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = - InstallPlan.new - (IndependentGoals False) - (Graph.fromDistinctList (Map.elems ready_map)) + -> LogProgress ElaboratedInstallPlan +instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = do + InstallPlan.new (Map.elems ready_map) where pkgs = InstallPlan.toList plan @@ -3487,10 +3487,9 @@ pruneInstallPlanToTargets => TargetAction -> Map (Graph.Key ElaboratedPlanPackage) [ComponentTarget] -> ElaboratedInstallPlan - -> ElaboratedInstallPlan + -> LogProgress ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = - InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) - . Graph.fromDistinctList + InstallPlan.new -- We have to do the pruning in two passes . pruneInstallPlanPass2 . pruneInstallPlanPass1 @@ -3938,15 +3937,14 @@ pruneInstallPlanToDependencies -> ElaboratedInstallPlan -> Either CannotPruneDependencies - ElaboratedInstallPlan + (Graph.Graph ElaboratedPlanPackage) pruneInstallPlanToDependencies pkgTargets installPlan = assert ( all (isJust . InstallPlan.lookup installPlan) (Set.toList pkgTargets) ) - $ fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) - . checkBrokenDeps + $ checkBrokenDeps . Graph.fromDistinctList . filter (\pkg -> Graph.nodeKey pkg `Set.notMember` pkgTargets) . InstallPlan.toList diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 5f611bdcab1..a643a2576a7 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -190,7 +190,7 @@ showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode where herald = ( hsep - [ text (InstallPlan.showPlanPackageTag pkg) + [ InstallPlan.renderPlanPackageTag pkg , InstallPlan.foldPlanPackage (const mempty) in_mem pkg , pretty (packageId pkg) , parens (pretty (nodeKey pkg)) diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 2f1262961f2..0cef2e00b32 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -66,7 +66,8 @@ import qualified Distribution.Simple.Flag as Flag import Distribution.Simple.Setup (CommonSetupFlags (..), HaddockFlags (..), HaddockProjectFlags (..), defaultCommonSetupFlags, defaultHaddockFlags, defaultHaddockProjectFlags, toFlag) import Distribution.System import Distribution.Text -import Distribution.Utils.Path (unsafeMakeSymbolicPath) +import Distribution.Utils.LogProgress +import Distribution.Utils.Path (FileOrDir (File), Pkg, SymbolicPath, unsafeMakeSymbolicPath) import Distribution.Version import Data.List (isInfixOf) @@ -2263,10 +2264,12 @@ executePlan ts ] elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + either (error . show) id $ + runLogProgress' $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan pkgsBuildStatus <- rebuildTargetsDryRun diff --git a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs index 4088eafb9ad..a778981b103 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -31,6 +31,7 @@ import qualified Data.Set as Set import System.Random import Test.QuickCheck +import Distribution.Utils.LogProgress import Test.Tasty import Test.Tasty.QuickCheck @@ -256,24 +257,28 @@ arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do , let isRoot = n == 0 ] - ipkgs <- - sequenceA - [ mkIPkg pkgv depvs - | pkgv <- ipkgvs - , let depvs = graph ! pkgv - ] - srcpkgs <- - sequenceA - [ mkSrcPkg pkgv depvs - | pkgv <- srcpkgvs - , let depvs = graph ! pkgv - ] - let index = - Graph.fromDistinctList - ( map InstallPlan.PreExisting ipkgs - ++ map InstallPlan.Configured srcpkgs - ) - return $ InstallPlan.new (IndependentGoals False) index + let gen_plan :: Gen (Either ErrMsg (InstallPlan.GenericInstallPlan ipkg srcpkg)) + gen_plan = do + ipkgs <- + sequenceA + [ mkIPkg pkgv depvs + | pkgv <- ipkgvs + , let depvs = graph ! pkgv + ] + srcpkgs <- + sequenceA + [ mkSrcPkg pkgv depvs + | pkgv <- srcpkgvs + , let depvs = graph ! pkgv + ] + let index = + Graph.fromDistinctList + ( map InstallPlan.PreExisting ipkgs + ++ map InstallPlan.Configured srcpkgs + ) + return $ runLogProgress' $ InstallPlan.new' index + + gen_plan `suchThatMap` either (const Nothing) Just -- | Generate a random directed acyclic graph, based on the algorithm presented -- here From 92d6b67436ee30c26946e3f37d94227eee3a5d2e Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Fri, 1 Aug 2025 16:32:00 +0800 Subject: [PATCH 41/54] feat(cabal-install): implicilty monitor our own executable to burst stale cache --- cabal-install/src/Distribution/Client/RebuildMonad.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/cabal-install/src/Distribution/Client/RebuildMonad.hs b/cabal-install/src/Distribution/Client/RebuildMonad.hs index 14e2b4946bb..acb8faaf64c 100644 --- a/cabal-install/src/Distribution/Client/RebuildMonad.hs +++ b/cabal-install/src/Distribution/Client/RebuildMonad.hs @@ -75,6 +75,7 @@ import Control.Monad import Control.Monad.Reader as Reader import Control.Monad.State as State import qualified Data.Map.Strict as Map +import Distribution.Client.Compat.ExecutablePath (getExecutablePath) import System.Directory import System.FilePath @@ -133,6 +134,13 @@ rerunIfChanged verbosity monitor key action = do [x] -> return x _ -> error "rerunIfChanged: impossible!" +-- | Monitor our current executable file for changes. This is useful to prevent +-- stale cache when upgrading the cabal executable itself or while developing. +monitorOurselves :: Rebuild () +monitorOurselves = do + self <- liftIO getExecutablePath + monitorFiles [monitorFile self] + -- | Like 'rerunIfChanged' meets 'mapConcurrently': For when we want multiple actions -- that need to do be re-run-if-changed asynchronously. The function returns -- when all values have finished computing. @@ -143,6 +151,8 @@ rerunConcurrentlyIfChanged -> [(FileMonitor a b, a, Rebuild b)] -> Rebuild [b] rerunConcurrentlyIfChanged verbosity mkJobControl triples = do + -- Implicitly add a monitor on our own executable file + monitorOurselves rootDir <- askRoot dacts <- forM triples $ \(monitor, key, action) -> do let monitorName = takeFileName (fileMonitorCacheFile monitor) From 78ff09dbffaefe28bd24be8030ff6f23e9200222 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 4 Aug 2025 15:17:47 +0800 Subject: [PATCH 42/54] refactor(Cabal-syntax): Improve Graph.broken If a node has dangling edges, then the list of missing neighbours cannot be empty. --- Cabal-syntax/src/Distribution/Compat/Graph.hs | 27 ++++++++++++------- Cabal/src/Distribution/Backpack/Configure.hs | 4 +-- .../Distribution/Client/CmdErrorMessages.hs | 2 +- .../src/Distribution/Client/Install.hs | 2 +- .../src/Distribution/Client/InstallPlan.hs | 9 +++---- .../Distribution/Client/ProjectPlanning.hs | 4 +-- .../Distribution/Client/SolverInstallPlan.hs | 14 +++++----- 7 files changed, 35 insertions(+), 27 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Compat/Graph.hs b/Cabal-syntax/src/Distribution/Compat/Graph.hs index 0873fbbb1f4..bf3493c2a2a 100644 --- a/Cabal-syntax/src/Distribution/Compat/Graph.hs +++ b/Cabal-syntax/src/Distribution/Compat/Graph.hs @@ -100,10 +100,10 @@ import Distribution.Utils.Structured (Structure (..), Structured (..)) import qualified Data.Array as Array import qualified Data.Foldable as Foldable import qualified Data.Graph as G +import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Tree as Tree -import qualified Distribution.Compat.Prelude as Prelude import GHC.Stack (HasCallStack) -- | A graph of nodes @a@. The nodes are expected to have instance @@ -115,7 +115,7 @@ data Graph a = Graph , graphAdjoint :: G.Graph , graphVertexToNode :: G.Vertex -> a , graphKeyToVertex :: Key a -> Maybe G.Vertex - , graphBroken :: [(a, [Key a])] + , graphBroken :: [(a, NonEmpty (Key a))] } -- NB: Not a Functor! (or Traversable), because you need @@ -285,7 +285,7 @@ cycles g = [vs | CyclicSCC vs <- stronglyConnComp g] -- | /O(1)/. Return a list of nodes paired with their broken -- neighbors (i.e., neighbor keys which are not in the graph). -- Requires amortized construction of graph. -broken :: Graph a -> [(a, [Key a])] +broken :: Graph a -> [(a, NonEmpty (Key a))] broken g = graphBroken g -- | Lookup the immediate neighbors from a key in the graph. @@ -344,7 +344,7 @@ revTopSort g = map (graphVertexToNode g) $ G.topSort (graphAdjoint g) -- if you can't fulfill this invariant use @'fromList' ('Data.Map.elems' m)@ -- instead. The values of the map are assumed to already -- be in WHNF. -fromMap :: IsNode a => Map (Key a) a -> Graph a +fromMap :: forall a. (IsNode a, Eq (Key a)) => Map (Key a) a -> Graph a fromMap m = Graph { graphMap = m @@ -353,17 +353,26 @@ fromMap m = , graphAdjoint = G.transposeG g , graphVertexToNode = vertex_to_node , graphKeyToVertex = key_to_vertex - , graphBroken = broke + , graphBroken = + map (\ns'' -> (fst (NE.head ns''), NE.map snd ns'')) $ + NE.groupWith (nodeKey . fst) $ + brokenEdges' } where - try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k) + brokenEdges' :: [(a, Key a)] + brokenEdges' = concat brokenEdges + brokenEdges :: [[(a, Key a)]] (brokenEdges, edges) = - unzip $ - [ partitionEithers (map try_key_to_vertex (nodeNeighbors n)) + unzip + [ partitionEithers + [ case key_to_vertex n' of + Just v -> Right v + Nothing -> Left (n, n') + | n' <- nodeNeighbors n + ] | n <- ns ] - broke = filter (not . Prelude.null . snd) (zip ns brokenEdges) g = Array.listArray bounds edges diff --git a/Cabal/src/Distribution/Backpack/Configure.hs b/Cabal/src/Distribution/Backpack/Configure.hs index aec217ebd22..611537a7828 100644 --- a/Cabal/src/Distribution/Backpack/Configure.hs +++ b/Cabal/src/Distribution/Backpack/Configure.hs @@ -283,14 +283,14 @@ toComponentLocalBuildInfos [ "installed package " ++ prettyShow (packageId pkg) ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) + ++ intercalate ", " (map prettyShow $ toList deps) | (Left pkg, deps) <- broken ] ++ unlines [ "planned package " ++ prettyShow (packageId pkg) ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) + ++ intercalate ", " (map prettyShow $ toList deps) | (Right pkg, deps) <- broken ] diff --git a/cabal-install/src/Distribution/Client/CmdErrorMessages.hs b/cabal-install/src/Distribution/Client/CmdErrorMessages.hs index 7eece5701f5..8f9bf63c1ba 100644 --- a/cabal-install/src/Distribution/Client/CmdErrorMessages.hs +++ b/cabal-install/src/Distribution/Client/CmdErrorMessages.hs @@ -501,7 +501,7 @@ renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) = where -- throw away the details and just list the deps that are needed pkgids :: [PackageId] - pkgids = nub . map packageId . concatMap snd $ brokenPackages + pkgids = nub . map packageId . concatMap (NE.toList . snd) $ brokenPackages {- ++ "Syntax:\n" diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index 4ffdf31e821..b98df15d15b 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -716,7 +716,7 @@ pruneInstallPlan pkgSpecifiers = nub [ depid | SolverInstallPlan.PackageMissingDeps _ depids <- problems - , depid <- depids + , depid <- toList depids , packageName depid `elem` targetnames ] diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index dd18ba0b4c4..df0454a0803 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -1056,7 +1056,7 @@ data PlanProblem ipkg srcpkg = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) -- ^ The package that is missing dependencies - [GraphKey ipkg srcpkg] + (NonEmpty (GraphKey ipkg srcpkg)) -- ^ The missing dependencies | -- | The packages involved in a dependency cycle PackageCycle @@ -1087,7 +1087,7 @@ renderPlanProblem (PackageMissingDeps pkg missingDeps) = [ text "Package" , pretty (nodeKey pkg) , text "depends on the following packages which are missing from the plan:" - , fsep (punctuate comma (map pretty missingDeps)) + , fsep (punctuate comma (map pretty $ NE.toList missingDeps)) ] renderPlanProblem (PackageCycle cycleGroup) = fsep @@ -1129,10 +1129,7 @@ checkForMissingDeps checkForMissingDeps graph = [ PackageMissingDeps pkg - ( mapMaybe - (fmap nodeKey . flip Graph.lookup graph) - missingDeps - ) + missingDeps | (pkg, missingDeps) <- Graph.broken graph ] diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 0b429cc2401..72de2e70858 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -3966,7 +3966,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan = CannotPruneDependencies [ (pkg, missingDeps) | (pkg, missingDepIds) <- brokenPackages - , let missingDeps = mapMaybe lookupDep missingDepIds + , let missingDeps = NE.map (fromMaybe (error "should not happen") . lookupDep) missingDepIds ] where -- lookup in the original unpruned graph @@ -3981,7 +3981,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan = newtype CannotPruneDependencies = CannotPruneDependencies [ ( ElaboratedPlanPackage - , [ElaboratedPlanPackage] + , NonEmpty ElaboratedPlanPackage ) ] deriving (Show) diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs index 83490ceb927..6e896f5a8e7 100644 --- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs +++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs @@ -74,6 +74,7 @@ import Distribution.Solver.Types.SolverPackage import Data.Array ((!)) import qualified Data.Foldable as Foldable import qualified Data.Graph as OldGraph +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Distribution.Compat.Graph (Graph, IsNode (..)) import qualified Distribution.Compat.Graph as Graph @@ -179,7 +180,7 @@ valid indepGoals index = data SolverPlanProblem = PackageMissingDeps SolverPlanPackage - [PackageIdentifier] + (NE.NonEmpty PackageIdentifier) | PackageCycle [SolverPlanPackage] | PackageInconsistency QPN [(SolverId, SolverId)] | PackageStateInvalid SolverPlanPackage SolverPlanPackage @@ -189,7 +190,7 @@ showPlanProblem (PackageMissingDeps pkg missingDeps) = "Package " ++ prettyShow (packageId pkg) ++ " depends on the following packages which are missing from the plan: " - ++ intercalate ", " (map prettyShow missingDeps) + ++ intercalate ", " (map prettyShow (NE.toList missingDeps)) showPlanProblem (PackageCycle cycleGroup) = "The following packages are involved in a dependency cycle " ++ intercalate ", " (map (prettyShow . packageId) cycleGroup) @@ -229,10 +230,11 @@ problems problems _indepGoals index = [ PackageMissingDeps pkg - ( mapMaybe - (fmap packageId . flip Graph.lookup index) - missingDeps - ) + -- ( mapMaybe + -- (fmap packageId . flip Graph.lookup index) + -- missingDeps + -- ) + (NE.map (packageId . fromMaybe (error "should not happen") . flip Graph.lookup index) missingDeps) | (pkg, missingDeps) <- Graph.broken index ] ++ [ PackageCycle cycleGroup From ab2a804df069b51352c13dca220a23ab00f52245 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 4 Aug 2025 15:17:47 +0800 Subject: [PATCH 43/54] refactor(cabal-install): harmonise various dependency functions --- .../Distribution/Client/ProjectPlanning.hs | 7 +- .../Client/ProjectPlanning/Types.hs | 150 ++++++++++-------- 2 files changed, 86 insertions(+), 71 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 72de2e70858..7ca89e29e9c 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1920,7 +1920,7 @@ elaborateInstallPlan compExeDependencyPaths :: [(WithStage ConfiguredId, FilePath)] compExeDependencyPaths = -- External - [ (WithStage solverPkgStage confId, path) + [ (WithStage (stageOf pkg) confId, path) | pkg <- external_exe_dep_pkgs , let confId = configuredId pkg , confSrcId confId /= pkgid @@ -1977,8 +1977,6 @@ elaborateInstallPlan cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} - infoProgress $ hang (text "configured component:") 4 (dispConfiguredComponent cc) - -- 4. Perform mix-in linking let lookup_uid def_uid = case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of @@ -1999,7 +1997,6 @@ elaborateInstallPlan cc -- \^ configured component - infoProgress $ hang (text "linked component:") 4 (dispLinkedComponent lc) -- NB: elab is setup to be the correct form for an -- indefinite library, or a definite library with no holes. -- We will modify it in 'instantiateInstallPlan' to handle @@ -4033,7 +4030,7 @@ setupHsScriptOptions , useDependencies = [ (confInstId cid, confSrcId cid) | -- TODO: we should filter for dependencies on libraries but that should be implicit in elabSetupLibDependencies - (WithStage _ cid, _promised) <- elabSetupLibDependencies elab + (WithStage _ cid) <- elabSetupLibDependencies elab ] , useDependenciesExclusive = True , useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index a643a2576a7..b0ce160906e 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -25,7 +25,6 @@ module Distribution.Client.ProjectPlanning.Types , elabExeDependencies , elabOrderExeDependencies , elabSetupLibDependencies - , elabSetupExeDependencies , elabPkgConfigDependencies , elabInplaceDependencyBuildCacheFiles , elabRequiresRegistration @@ -580,6 +579,15 @@ elabDistDirParams shared elab = where Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains shared) (elabStage elab) +-- +-- Order dependencies +-- +-- Order dependencies are identified by their 'UnitId' and only used to define the +-- dependency relationships in the build graph. In particular they do not provide +-- any other information needed to build the component or package. We can consider +-- UnitId as a opaque identifier. +-- + -- | The full set of dependencies which dictate what order we -- need to build things in the install plan: "order dependencies" -- balls everything together. This is mostly only useful for @@ -591,66 +599,68 @@ elabDistDirParams shared elab = -- Note: this method DOES include setup deps. elabOrderDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderDependencies elab = - elabOrderLibDependencies elab ++ elabOrderExeDependencies elab + elabOrderLibDependencies elab <> elabOrderExeDependencies elab -- | The result includes setup dependencies elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderLibDependencies elab = - ordNub $ - [ fmap (newSimpleUnitId . confInstId) dep - | (dep, _promised) <- elabLibDependencies elab ++ elabSetupLibDependencies elab - ] + case elabPkgOrComp elab of + ElabPackage pkg -> + -- Note: flatDeps include the setup dependencies too + ordNub $ CD.flatDeps (pkgOrderLibDependencies pkg) + ElabComponent comp -> + map (WithStage (elabStage elab)) (compOrderLibDependencies comp) -- | The result includes setup dependencies elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderExeDependencies elab = - -- Compare with elabOrderLibDependencies. The setup dependencies here do not need - -- any special attention because the stage is already included in pkgExeDependencies. - map (fmap (newSimpleUnitId . confInstId)) $ - case elabPkgOrComp elab of - ElabPackage pkg -> CD.flatDeps (pkgExeDependencies pkg) - ElabComponent comp -> compExeDependencies comp - --- | The library dependencies (i.e., the libraries we depend on, NOT --- the dependencies of the library), NOT including setup dependencies. --- These are passed to the @Setup@ script via @--dependency@ or @--promised-dependency@. -elabLibDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)] -elabLibDependencies elab = case elabPkgOrComp elab of ElabPackage pkg -> - ordNub - [ (WithStage (pkgStage pkg) cid, promised) - | (cid, promised) <- CD.nonSetupDeps (pkgLibDependencies pkg) - ] + ordNub $ CD.flatDeps (pkgOrderExeDependencies pkg) ElabComponent comp -> - [ (WithStage (elabStage elab) c, promised) - | (c, promised) <- compLibDependencies comp - ] - --- | The setup dependencies (the library dependencies of the setup executable; --- note that it is not legal for setup scripts to have executable --- dependencies at the moment.) -elabSetupLibDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)] -elabSetupLibDependencies elab = - case elabPkgOrComp elab of - ElabPackage pkg -> - ordNub - [ (WithStage (prevStage (pkgStage pkg)) cid, promised) - | (cid, promised) <- CD.setupDeps (pkgLibDependencies pkg) - ] - -- TODO: Custom setups not supported for components yet. When - -- they are, need to do this differently - ElabComponent _ -> [] + map (fmap fromConfiguredId) (compExeDependencies comp) --- | This would not be allowed actually. See comment on elabSetupLibDependencies. -elabSetupExeDependencies :: ElaboratedConfiguredPackage -> [WithStage ComponentId] -elabSetupExeDependencies elab = - map (fmap confInstId) $ +-- | See 'elabOrderDependencies'. This gives the unflattened version, +-- which can be useful in some circumstances. +pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId] +pkgOrderDependencies pkg = + pkgOrderLibDependencies pkg <> pkgOrderExeDependencies pkg + +pkgOrderLibDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId] +pkgOrderLibDependencies pkg = + CD.fromList + [ (comp, map (WithStage stage . fromConfiguredId . fst) deps) + | (comp, deps) <- CD.toList (pkgLibDependencies pkg) + , let stage = + if comp == CD.ComponentSetup + then prevStage (pkgStage pkg) + else pkgStage pkg + ] + +pkgOrderExeDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId] +pkgOrderExeDependencies pkg = + fmap (map (fmap fromConfiguredId)) $ + pkgExeDependencies pkg + +fromConfiguredId :: ConfiguredId -> UnitId +fromConfiguredId = newSimpleUnitId . confInstId + +--- | Library dependencies. +--- +--- These are identified by their 'ConfiguredId' and are passed to the @Setup@ +--- script via @--dependency@ or @--promised-dependency@. +--- Note that setup dependencies (meaning the library dependencies of the setup +-- script) are not included here, they are handled separately. +elabLibDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)] +elabLibDependencies elab = + -- Library dependencies are always in the same stage as the component/package we are + -- building. + map (\(cid, promised) -> (WithStage (elabStage elab) cid, promised)) $ case elabPkgOrComp elab of - ElabPackage pkg -> CD.setupDeps (pkgExeDependencies pkg) - -- TODO: Custom setups not supported for components yet. When - -- they are, need to do this differently - ElabComponent _ -> [] + ElabPackage pkg -> + ordNub $ CD.nonSetupDeps (pkgLibDependencies pkg) + ElabComponent comp -> + compLibDependencies comp -- | The executable dependencies (i.e., the executables we depend on); -- these are the executables we must add to the PATH before we invoke @@ -659,7 +669,7 @@ elabExeDependencies :: ElaboratedConfiguredPackage -> [WithStage ComponentId] elabExeDependencies elab = map (fmap confInstId) $ case elabPkgOrComp elab of - ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) + ElabPackage pkg -> ordNub $ CD.nonSetupDeps (pkgExeDependencies pkg) ElabComponent comp -> compExeDependencies comp -- | This returns the paths of all the executables we depend on; we @@ -669,14 +679,33 @@ elabExeDependencies elab = elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath] elabExeDependencyPaths elab = case elabPkgOrComp elab of - ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) + ElabPackage pkg -> ordNub $ map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) ElabComponent comp -> map snd (compExeDependencyPaths comp) elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] -elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} = - pkgPkgConfigDependencies pkg -elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp} = - compPkgConfigDependencies comp +elabPkgConfigDependencies elab = + case elabPkgOrComp elab of + ElabPackage pkg -> pkgPkgConfigDependencies pkg + ElabComponent comp -> compPkgConfigDependencies comp + +-- | The setup dependencies (i.e. the library dependencies of the setup executable) +-- Note that it is not legal for setup scripts to have executable dependencies. +-- TODO: In that case we should probably not have this function at all, and +-- only use pkgSetupLibDependencies +elabSetupLibDependencies :: ElaboratedConfiguredPackage -> [WithStage ConfiguredId] +elabSetupLibDependencies elab = + case elabPkgOrComp elab of + ElabPackage pkg -> pkgSetupLibDependencies pkg + -- Custom setups not supported for components. + ElabComponent _ -> [] + +pkgSetupLibDependencies :: ElaboratedPackage -> [WithStage ConfiguredId] +pkgSetupLibDependencies pkg = + map (WithStage stage . fst) $ + ordNub $ + CD.setupDeps (pkgLibDependencies pkg) + where + stage = prevStage (pkgStage pkg) -- | The cache files of all our inplace dependencies which, -- when updated, require us to rebuild. See #4202 for @@ -751,7 +780,7 @@ data ElaboratedComponent = ElaboratedComponent , compOrderLibDependencies :: [UnitId] -- ^ The UnitIds of the libraries (identifying elaborated packages/ -- components) that must be built before this project. This - -- is used purely for ordering purposes. It can contain both + -- is used purely for ordering purposes. It can contain both -- references to definite and indefinite packages; an indefinite -- UnitId indicates that we must typecheck that indefinite package -- before we can build this one. @@ -834,17 +863,6 @@ whyNotPerComponent = \case CuzNoBuildableComponents -> "there are no buildable components" CuzDisablePerComponent -> "you passed --disable-per-component" --- | See 'elabOrderDependencies'. This gives the unflattened version, --- which can be useful in some circumstances. -pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId] -pkgOrderDependencies pkg = - fmap - (map (\(cid, _) -> WithStage (pkgStage pkg) (newSimpleUnitId $ confInstId cid))) - (pkgLibDependencies pkg) - <> fmap - (map (fmap (newSimpleUnitId . confInstId))) - (pkgExeDependencies pkg) - -- | This is used in the install plan to indicate how the package will be -- built. data BuildStyle From 71523498a42c0dae52ba803767a013a198f22d84 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 5 Aug 2025 10:36:56 +0800 Subject: [PATCH 44/54] refactor(cabal-install): rename, format and comment --- .../Distribution/Client/ProjectPlanning.hs | 857 +++++++++--------- 1 file changed, 437 insertions(+), 420 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 7ca89e29e9c..95d32832c1b 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1708,386 +1708,396 @@ elaborateInstallPlan => (SolverId -> [ElaboratedPlanPackage]) -> SolverPackage UnresolvedPkgLoc -> LogProgress [ElaboratedConfiguredPackage] - elaborateSolverToComponents mapDep spkg@SolverPackage{solverPkgStage, solverPkgLibDeps, solverPkgExeDeps} = - case mkComponentsGraph (elabEnabledSpec elab0) pd of - Right g -> do - let src_comps = componentsGraphToList g - infoProgress $ - hang - (text "Component graph for" <+> pretty (solverId (ResolverPackage.Configured spkg))) - 4 - (dispComponentsWithDeps src_comps) - (_, comps) <- - mapAccumM - buildComponent - (Map.empty, Map.empty, Map.empty) - (map fst src_comps) - let whyNotPerComp = why_not_per_component src_comps - case NE.nonEmpty whyNotPerComp of - Nothing -> do - elaborationWarnings - return comps - Just notPerCompReasons -> do - checkPerPackageOk comps notPerCompReasons - pkgComp <- - elaborateSolverToPackage - notPerCompReasons - spkg - g - (comps ++ maybeToList setupComponent) - return [pkgComp] - Left cns -> - dieProgress $ - hang - (text "Dependency cycle between the following components:") - 4 - (vcat (map (text . componentNameStanza) cns)) - where - bt = PD.buildType (elabPkgDescription elab0) - -- You are eligible to per-component build if this list is empty - why_not_per_component g = - cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag - where - -- Custom and Hooks are not implemented. Implementing - -- per-component builds with Custom would require us to create a - -- new 'ElabSetup' type, and teach all of the code paths how to - -- handle it. - -- Once you've implemented this, swap it for the code below. - -- (See #9986 for more information about this task.) - cuz_buildtype = - case bt of - PD.Configure -> [] - -- Configure is supported, but we only support configuring the - -- main library in cabal. Other components will need to depend - -- on the main library for configured data. - PD.Custom -> [CuzBuildType CuzCustomBuildType] - PD.Make -> [CuzBuildType CuzMakeBuildType] - PD.Simple -> [] - -- TODO: remove the following, once we make Setup a separate - -- component (task tracked at #9986). - PD.Hooks -> [CuzBuildType CuzHooksBuildType] - - -- cabal-format versions prior to 1.8 have different build-depends semantics - -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8 - -- see, https://github.com/haskell/cabal/issues/4121 - cuz_spec - | PD.specVersion pd >= CabalSpecV1_8 = [] - | otherwise = [CuzCabalSpecVersion] - -- In the odd corner case that a package has no components at all - -- then keep it as a whole package, since otherwise it turns into - -- 0 component graph nodes and effectively vanishes. We want to - -- keep it around at least for error reporting purposes. - cuz_length - | length g > 0 = [] - | otherwise = [CuzNoBuildableComponents] - -- For ease of testing, we let per-component builds be toggled - -- at the top level - cuz_flag - | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) = - [] - | otherwise = [CuzDisablePerComponent] - - -- \| Sometimes a package may make use of features which are only - -- supported in per-package mode. If this is the case, we should - -- give an error when this occurs. - checkPerPackageOk comps reasons = do - let is_sublib (CLibName (LSubLibName _)) = True - is_sublib _ = False - when (any (matchElabPkg is_sublib) comps) $ + elaborateSolverToComponents + mapDep + solverPkg@SolverPackage{solverPkgStage, solverPkgLibDeps, solverPkgExeDeps} = + case mkComponentsGraph (elabEnabledSpec elab0) pd of + Left cns -> dieProgress $ - text "Internal libraries only supported with per-component builds." - $$ text "Per-component builds were disabled because" - <+> fsep (punctuate comma $ map (text . whyNotPerComponent) $ toList reasons) - -- TODO: Maybe exclude Backpack too - - (elab0, elaborationWarnings) = elaborateSolverToCommon spkg - pkgid = elabPkgSourceId elab0 - pd = elabPkgDescription elab0 - - -- TODO: This is just a skeleton to get elaborateSolverToPackage - -- working correctly - -- TODO: When we actually support building these components, we - -- have to add dependencies on this from all other components - setupComponent :: Maybe ElaboratedConfiguredPackage - setupComponent - | bt `elem` [PD.Custom, PD.Hooks] = - Just - elab0 - { elabModuleShape = emptyModuleShape - , elabUnitId = notImpl "elabUnitId" - , elabComponentId = notImpl "elabComponentId" - , elabInstallDirs = notImpl "elabInstallDirs" - , elabPkgOrComp = - ElabComponent - ( ElaboratedComponent - { compSolverName = CD.ComponentSetup - , compComponentName = Nothing - , compLibDependencies = - [ (configuredId cid, False) - | cid <- CD.setupDeps solverPkgLibDeps >>= elaborateLibSolverId mapDep - ] - , compLinkedLibDependencies = notImpl "compLinkedLibDependencies" - , compOrderLibDependencies = notImpl "compOrderLibDependencies" - , -- Not supported: - compExeDependencies = mempty - , compExeDependencyPaths = mempty - , compPkgConfigDependencies = mempty - , compInstantiatedWith = mempty - , compLinkedInstantiatedWith = Map.empty - } - ) - } - | otherwise = - Nothing - where - notImpl f = - error $ - "Distribution.Client.ProjectPlanning.setupComponent: " - ++ f - ++ " not implemented yet" - - -- Note: this function is used to configure the components in a single package (`elab`, defined in the outer scope) - buildComponent - :: HasCallStack - => ( Map PackageName (Map ComponentName (AnnotatedId ComponentId)) - , Map ComponentId (OpenUnitId, ModuleShape) - , Map ComponentId FilePath - ) - -> Cabal.Component - -> LogProgress - ( ( Map PackageName (Map ComponentName (AnnotatedId ComponentId)) - , Map ComponentId (OpenUnitId, ModuleShape) - , Map ComponentId FilePath + hang + (text "Dependency cycle between the following components:") + 4 + (vcat (map (text . componentNameStanza) cns)) + Right g -> do + let src_comps = componentsGraphToList g + + infoProgress $ + hang + (text "Component graph for" <+> pretty (solverId (ResolverPackage.Configured solverPkg))) + 4 + (dispComponentsWithDeps src_comps) + + (_, comps) <- + mapAccumM + buildComponent + (Map.empty, Map.empty, Map.empty) + (map fst src_comps) + + let whyNotPerComp = why_not_per_component src_comps + + case NE.nonEmpty whyNotPerComp of + Nothing -> + return comps + Just notPerCompReasons -> do + checkPerPackageOk comps notPerCompReasons + pkgComp <- + elaborateSolverToPackage + notPerCompReasons + solverPkg + g + (comps ++ maybeToList setupComponent) + return [pkgComp] + where + bt = PD.buildType (elabPkgDescription elab0) + + -- You are eligible to per-component build if this list is empty + why_not_per_component g = + cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag + where + -- Custom and Hooks are not implemented. Implementing + -- per-component builds with Custom would require us to create a + -- new 'ElabSetup' type, and teach all of the code paths how to + -- handle it. + -- Once you've implemented this, swap it for the code below. + cuz_buildtype = + case bt of + PD.Configure -> [] + -- Configure is supported, but we only support configuring the + -- main library in cabal. Other components will need to depend + -- on the main library for configured data. + PD.Custom -> [CuzBuildType CuzCustomBuildType] + PD.Hooks -> [CuzBuildType CuzHooksBuildType] + PD.Make -> [CuzBuildType CuzMakeBuildType] + PD.Simple -> [] + -- cabal-format versions prior to 1.8 have different build-depends semantics + -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8 + -- see, https://github.com/haskell/cabal/issues/4121 + cuz_spec + | PD.specVersion pd >= CabalSpecV1_8 = [] + | otherwise = [CuzCabalSpecVersion] + -- In the odd corner case that a package has no components at all + -- then keep it as a whole package, since otherwise it turns into + -- 0 component graph nodes and effectively vanishes. We want to + -- keep it around at least for error reporting purposes. + cuz_length + | length g > 0 = [] + | otherwise = [CuzNoBuildableComponents] + -- For ease of testing, we let per-component builds be toggled + -- at the top level + cuz_flag + | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) = + [] + | otherwise = [CuzDisablePerComponent] + + -- \| Sometimes a package may make use of features which are only + -- supported in per-package mode. If this is the case, we should + -- give an error when this occurs. + checkPerPackageOk comps reasons = do + let is_sublib (CLibName (LSubLibName _)) = True + is_sublib _ = False + when (any (matchElabPkg is_sublib) comps) $ + dieProgress $ + text "Internal libraries only supported with per-component builds." + $$ text "Per-component builds were disabled because" + <+> fsep (punctuate comma $ map (text . whyNotPerComponent) $ toList reasons) + -- TODO: Maybe exclude Backpack too + + elab0 = elaborateSolverToCommon solverPkg + pkgid = elabPkgSourceId elab0 + pd = elabPkgDescription elab0 + + -- TODO: This is just a skeleton to get elaborateSolverToPackage + -- working correctly + -- TODO: When we actually support building these components, we + -- have to add dependencies on this from all other components + setupComponent :: Maybe ElaboratedConfiguredPackage + setupComponent + | bt `elem` [PD.Custom, PD.Hooks] = + Just + elab0 + { elabModuleShape = emptyModuleShape + , elabUnitId = notImpl "elabUnitId" + , elabComponentId = notImpl "elabComponentId" + , elabInstallDirs = notImpl "elabInstallDirs" + , elabPkgOrComp = + ElabComponent + ( ElaboratedComponent + { compSolverName = CD.ComponentSetup + , compComponentName = Nothing + , compLibDependencies = + [ (configuredId cid, False) + | cid <- CD.setupDeps solverPkgLibDeps >>= elaborateLibSolverId mapDep + ] + , compLinkedLibDependencies = notImpl "compLinkedLibDependencies" + , compOrderLibDependencies = notImpl "compOrderLibDependencies" + , -- Not supported: + compExeDependencies = mempty + , compExeDependencyPaths = mempty + , compPkgConfigDependencies = mempty + , compInstantiatedWith = mempty + , compLinkedInstantiatedWith = Map.empty + } + ) + } + | otherwise = + Nothing + where + notImpl f = + error $ + "Distribution.Client.ProjectPlanning.setupComponent: " + ++ f + ++ " not implemented yet" + + -- Note: this function is used to configure the components in a single package (`elab`, defined in the outer scope) + buildComponent + :: HasCallStack + => ( Map PackageName (Map ComponentName (AnnotatedId ComponentId)) + , Map ComponentId (OpenUnitId, ModuleShape) + , Map ComponentId FilePath + ) + -> Cabal.Component + -> LogProgress + ( ( Map PackageName (Map ComponentName (AnnotatedId ComponentId)) + , Map ComponentId (OpenUnitId, ModuleShape) + , Map ComponentId FilePath + ) + , ElaboratedConfiguredPackage ) - , ElaboratedConfiguredPackage + buildComponent (cc_map, lc_map, exe_map) comp = + addProgressCtx + ( text "In the stanza" + <+> quotes (text (componentNameStanza cname)) ) - buildComponent (cc_map, lc_map, exe_map) comp = - addProgressCtx - ( text "In the stanza" - <+> quotes (text (componentNameStanza cname)) - ) - $ do - let lib_dep_map = Map.unionWith Map.union external_lib_cc_map cc_map - -- TODO: is cc_map correct here? - exe_dep_map = Map.unionWith Map.union external_exe_cc_map cc_map - - -- 1. Configure the component, but with a place holder ComponentId. - infoProgress $ - hang (text "configuring component" <+> pretty cname) 4 $ - vcat - [ text "lib_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys lib_dep_map)) - , text "exe_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys exe_dep_map)) - ] - cc0 <- - toConfiguredComponent - pd - (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later") - lib_dep_map - exe_dep_map - comp - - let do_ cid = - let cid' = annotatedIdToConfiguredId . ci_ann_id $ cid - in (cid', False) -- filled in later in pruneInstallPlanPhase2) - - -- 2. Read out the dependencies from the ConfiguredComponent cc0 - let compLibDependencies = - -- Nub because includes can show up multiple times - ordNub - ( map - (\cid -> do_ cid) - (cc_includes cc0) - ) - - compExeDependencies :: [WithStage ConfiguredId] - compExeDependencies = - -- External - [ WithStage (stageOf pkg) confId - | pkg <- external_exe_dep_pkgs - , let confId = configuredId pkg - , -- only executables - Just (CExeName _) <- [confCompName confId] - , confSrcId confId /= pkgid - ] - <> - -- Internal, assume the same stage - [ WithStage solverPkgStage confId - | aid <- cc_exe_deps cc0 - , let confId = annotatedIdToConfiguredId aid - , confSrcId confId == pkgid + $ do + let lib_dep_map = Map.unionWith Map.union external_lib_cc_map cc_map + -- TODO: is cc_map correct here? + exe_dep_map = Map.unionWith Map.union external_exe_cc_map cc_map + + -- 1. Configure the component, but with a place holder ComponentId. + infoProgress $ + hang (text "configuring component" <+> pretty cname) 4 $ + vcat + [ text "lib_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys lib_dep_map)) + , text "exe_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys exe_dep_map)) ] - compExeDependencyPaths :: [(WithStage ConfiguredId, FilePath)] - compExeDependencyPaths = - -- External - [ (WithStage (stageOf pkg) confId, path) - | pkg <- external_exe_dep_pkgs - , let confId = configuredId pkg - , confSrcId confId /= pkgid - , -- only executables - Just (CExeName _) <- [confCompName confId] - , path <- planPackageExePaths pkg - ] - <> - -- Internal, assume the same stage - [ (WithStage solverPkgStage confId, path) - | aid <- cc_exe_deps cc0 - , let confId = annotatedIdToConfiguredId aid - , confSrcId confId == pkgid - , Just paths <- [Map.lookup (ann_id aid) exe_map1] - , path <- paths - ] - - elab_comp = - ElaboratedComponent - { compSolverName - , compComponentName - , compLibDependencies - , compExeDependencies - , compPkgConfigDependencies - , compExeDependencyPaths - , compInstantiatedWith = Map.empty - , compLinkedInstantiatedWith = Map.empty - , -- filled later (in step 5) - compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" - , compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" - } + cc0 <- + toConfiguredComponent + pd + (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later") + lib_dep_map + exe_dep_map + comp + + let do_ cid = + let cid' = annotatedIdToConfiguredId . ci_ann_id $ cid + in (cid', False) -- filled in later in pruneInstallPlanPhase2) + + -- 2. Read out the dependencies from the ConfiguredComponent cc0 + let compLibDependencies = + -- Nub because includes can show up multiple times + ordNub + ( map + (\cid -> do_ cid) + (cc_includes cc0) + ) - -- 3. Construct a preliminary ElaboratedConfiguredPackage, - -- and use this to compute the component ID. Fix up cc_id - -- correctly. - let elab1 = - elab0 - { elabPkgOrComp = ElabComponent elab_comp + compExeDependencies :: [WithStage ConfiguredId] + compExeDependencies = + -- External + [ WithStage (stageOf pkg) confId + | pkg <- external_exe_dep_pkgs + , let confId = configuredId pkg + , -- only executables + Just (CExeName _) <- [confCompName confId] + , confSrcId confId /= pkgid + ] + <> + -- Internal, assume the same stage + [ WithStage solverPkgStage confId + | aid <- cc_exe_deps cc0 + , let confId = annotatedIdToConfiguredId aid + , confSrcId confId == pkgid + ] + + compExeDependencyPaths :: [(WithStage ConfiguredId, FilePath)] + compExeDependencyPaths = + -- External + [ (WithStage (stageOf pkg) confId, path) + | pkg <- external_exe_dep_pkgs + , let confId = configuredId pkg + , confSrcId confId /= pkgid + , -- only executables + Just (CExeName _) <- [confCompName confId] + , path <- planPackageExePaths pkg + ] + <> + -- Internal, assume the same stage + [ (WithStage solverPkgStage confId, path) + | aid <- cc_exe_deps cc0 + , let confId = annotatedIdToConfiguredId aid + , confSrcId confId == pkgid + , Just paths <- [Map.lookup (ann_id aid) exe_map1] + , path <- paths + ] + + elab_comp = + ElaboratedComponent + { compSolverName + , compComponentName + , compLibDependencies + , compExeDependencies + , compPkgConfigDependencies + , compExeDependencyPaths + , compInstantiatedWith = Map.empty + , compLinkedInstantiatedWith = Map.empty + , -- filled later (in step 5) + compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" + , compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" + } + + -- 3. Construct a preliminary ElaboratedConfiguredPackage, + -- and use this to compute the component ID. Fix up cc_id + -- correctly. + let elab1 = + elab0 + { elabPkgOrComp = ElabComponent elab_comp + } + + -- This is where the component id is computed. + cid = case elabBuildStyle elab0 of + BuildInplaceOnly{} -> + mkComponentId $ + case Cabal.componentNameString cname of + Nothing -> prettyShow pkgid + Just n -> prettyShow pkgid ++ "-" ++ prettyShow n + BuildAndInstall -> + hashedInstalledPackageId + ( packageHashInputs + elaboratedSharedConfig + elab1 -- knot tied + ) + + cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} + + -- 4. Perform mix-in linking + let lookup_uid def_uid = + case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of + Just full -> full + Nothing -> error ("lookup_uid: " ++ prettyShow def_uid) + lc_dep_map = Map.union external_lc_map lc_map + lc <- + toLinkedComponent + verbosity + False + -- \^ whether there are any "promised" package dependencies which we won't find already installed + lookup_uid + -- \^ full db + (elabPkgSourceId elab0) + -- \^ the source package id + lc_dep_map + -- \^ linked component map + cc + -- \^ configured component + + -- NB: elab is setup to be the correct form for an + -- indefinite library, or a definite library with no holes. + -- We will modify it in 'instantiateInstallPlan' to handle + -- instantiated packages. + + -- 5. Construct the final ElaboratedConfiguredPackage + let + elab2 = + elab1 + { elabModuleShape = lc_shape lc + , elabUnitId = abstractUnitId (lc_uid lc) + , elabComponentId = lc_cid lc + , elabPkgOrComp = + ElabComponent $ + elab_comp + { compLinkedLibDependencies = + ordNub (map ci_id (lc_includes lc)) + , compOrderLibDependencies = + ordNub + ( map + (abstractUnitId . ci_id) + (lc_includes lc ++ lc_sig_includes lc) + ) + , compLinkedInstantiatedWith = + Map.fromList (lc_insts lc) + } } - - -- This is where the component id is computed. - cid = case elabBuildStyle elab0 of - BuildInplaceOnly{} -> - mkComponentId $ - case Cabal.componentNameString cname of - Nothing -> prettyShow pkgid - Just n -> prettyShow pkgid ++ "-" ++ prettyShow n - BuildAndInstall -> - hashedInstalledPackageId - ( packageHashInputs + elab = + elab2 + { elabInstallDirs = + computeInstallDirs + storeDirLayout + defaultInstallDirs elaboratedSharedConfig - elab1 -- knot tied - ) + elab2 + } - cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} - - -- 4. Perform mix-in linking - let lookup_uid def_uid = - case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of - Just full -> full - Nothing -> error ("lookup_uid: " ++ prettyShow def_uid) - lc_dep_map = Map.union external_lc_map lc_map - lc <- - toLinkedComponent - verbosity - False - -- \^ whether there are any "promised" package dependencies which we won't find already installed - lookup_uid - -- \^ full db - (elabPkgSourceId elab0) - -- \^ the source package id - lc_dep_map - -- \^ linked component map - cc - -- \^ configured component - - -- NB: elab is setup to be the correct form for an - -- indefinite library, or a definite library with no holes. - -- We will modify it in 'instantiateInstallPlan' to handle - -- instantiated packages. - - -- 5. Construct the final ElaboratedConfiguredPackage - let - elab2 = - elab1 - { elabModuleShape = lc_shape lc - , elabUnitId = abstractUnitId (lc_uid lc) - , elabComponentId = lc_cid lc - , elabPkgOrComp = - ElabComponent $ - elab_comp - { compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc)) - , compOrderLibDependencies = - ordNub - ( map - (abstractUnitId . ci_id) - (lc_includes lc ++ lc_sig_includes lc) - ) - , compLinkedInstantiatedWith = Map.fromList (lc_insts lc) - } - } - elab = - elab2 - { elabInstallDirs = - computeInstallDirs - storeDirLayout - defaultInstallDirs - elaboratedSharedConfig - elab2 - } + -- 6. Construct the updated local maps + let cc_map' = extendConfiguredComponentMap cc cc_map + lc_map' = extendLinkedComponentMap lc lc_map + exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map - -- 6. Construct the updated local maps - let cc_map' = extendConfiguredComponentMap cc cc_map - lc_map' = extendLinkedComponentMap lc lc_map - exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map + return ((cc_map', lc_map', exe_map'), elab) + where + cname = Cabal.componentName comp + compComponentName = Just cname + compSolverName = CD.componentNameToComponent cname - return ((cc_map', lc_map', exe_map'), elab) - where - cname = Cabal.componentName comp - compComponentName = Just cname - compSolverName = CD.componentNameToComponent cname + -- External dependencies. I.e. dependencies of the component on components of other packages. + external_lib_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgLibDeps - -- External dependencies. I.e. dependencies of the component on components of other packages. - external_lib_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgLibDeps + external_exe_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgExeDeps - external_exe_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgExeDeps + external_exe_map = + Map.fromList $ + [ (getComponentId pkg, planPackageExePaths pkg) + | pkg <- external_exe_dep_pkgs + ] - external_exe_map = - Map.fromList $ - [ (getComponentId pkg, planPackageExePaths pkg) - | pkg <- external_exe_dep_pkgs + exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map + + external_lib_cc_map = + Map.fromListWith Map.union $ + map mkCCMapping external_lib_dep_pkgs + + external_exe_cc_map = + Map.fromListWith Map.union $ + map mkCCMapping external_exe_dep_pkgs + + external_lc_map = + Map.fromList $ + map mkShapeMapping $ + external_lib_dep_pkgs ++ external_exe_dep_pkgs + + compPkgConfigDependencies = + [ ( pn + , fromMaybe + ( error $ + "compPkgConfigDependencies: impossible! " + ++ prettyShow pn + ++ " from " + ++ prettyShow (elabPkgSourceId elab0) + ) + (getStage pkgConfigDB (elabStage elab0) >>= \db -> pkgConfigDbPkgVersion db pn) + ) + | PkgconfigDependency pn _ <- + PD.pkgconfigDepends + (Cabal.componentBuildInfo comp) ] - exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map - - external_lib_cc_map = - Map.fromListWith Map.union $ - map mkCCMapping external_lib_dep_pkgs - external_exe_cc_map = - Map.fromListWith Map.union $ - map mkCCMapping external_exe_dep_pkgs - external_lc_map = - Map.fromList $ - map mkShapeMapping $ - external_lib_dep_pkgs ++ external_exe_dep_pkgs - - compPkgConfigDependencies = - [ ( pn - , fromMaybe - ( error $ - "compPkgConfigDependencies: impossible! " - ++ prettyShow pn - ++ " from " - ++ prettyShow (elabPkgSourceId elab0) - ) - (getStage pkgConfigDB (elabStage elab0) >>= \db -> pkgConfigDbPkgVersion db pn) - ) - | PkgconfigDependency pn _ <- - PD.pkgconfigDepends - (Cabal.componentBuildInfo comp) - ] - inplace_bin_dir elab = - binDirectoryFor - distDirLayout - elaboratedSharedConfig - elab - $ maybe "" prettyShow (Cabal.componentNameString cname) + inplace_bin_dir elab = + binDirectoryFor + distDirLayout + elaboratedSharedConfig + elab + $ case Cabal.componentNameString cname of + Just n -> prettyShow n + Nothing -> "" -- \| Given a 'SolverId' referencing a dependency on a library, return -- the 'ElaboratedPlanPackage' corresponding to the library. This @@ -2138,7 +2148,7 @@ elaborateInstallPlan -> LogProgress ElaboratedConfiguredPackage elaborateSolverToPackage pkgWhyNotPerComponent - pkg@SolverPackage{solverPkgSource = SourcePackage{srcpkgPackageId}} + solverPkg@SolverPackage{solverPkgSource = SourcePackage{srcpkgPackageId}} compGraph comps = do -- Knot tying: the final elab includes the @@ -2151,25 +2161,13 @@ elaborateInstallPlan { elabPkgSourceHash , elabStanzasRequested , elabStage - } = elaborateSolverToCommon pkg + } = elaborateSolverToCommon solverPkg elab1 = elab0 { elabUnitId = newSimpleUnitId pkgInstalledId , elabComponentId = pkgInstalledId - , elabPkgOrComp = - ElabPackage $ - ElaboratedPackage - { pkgStage = elabStage - , pkgInstalledId - , pkgLibDependencies - , pkgDependsOnSelfLib - , pkgExeDependencies - , pkgExeDependencyPaths - , pkgPkgConfigDependencies - , pkgStanzasEnabled - , pkgWhyNotPerComponent - } + , elabPkgOrComp = ElabPackage elabPkg , elabModuleShape = modShape } @@ -2190,7 +2188,7 @@ elaborateInstallPlan (find (matchElabPkg (== (CLibName LMainLibName))) comps) pkgInstalledId - | shouldBuildInplaceOnly pkg = + | shouldBuildInplaceOnly solverPkg = mkComponentId (prettyShow srcpkgPackageId) | otherwise = assert (isJust elabPkgSourceHash) $ @@ -2205,19 +2203,32 @@ elaborateInstallPlan isExternal confid = confSrcId confid /= srcpkgPackageId isExternal' (WithStage stage confId) = stage /= elabStage || isExternal confId - pkgLibDependencies = - buildComponentDeps (filter (isExternal . fst) . compLibDependencies) - - pkgExeDependencies = - buildComponentDeps (filter isExternal' . compExeDependencies) - - pkgExeDependencyPaths = - buildComponentDeps (filter (isExternal' . fst) . compExeDependencyPaths) - - -- TODO: Why is this flat? - pkgPkgConfigDependencies = - fold $ buildComponentDeps compPkgConfigDependencies + elabPkg = + ElaboratedPackage + { pkgStage = elabStage + , pkgInstalledId + , pkgLibDependencies = buildComponentDeps (filter (isExternal . fst) . compLibDependencies) + , pkgDependsOnSelfLib + , pkgExeDependencies = buildComponentDeps (filter isExternal' . compExeDependencies) + , pkgExeDependencyPaths = buildComponentDeps (filter (isExternal' . fst) . compExeDependencyPaths) + , -- Why is this flat? + pkgPkgConfigDependencies = CD.flatDeps $ buildComponentDeps compPkgConfigDependencies + , -- NB: This is not the final setting of 'pkgStanzasEnabled'. + -- See [Sticky enabled testsuites]; we may enable some extra + -- stanzas opportunistically when it is cheap to do so. + -- + -- However, we start off by enabling everything that was + -- requested, so that we can maintain an invariant that + -- pkgStanzasEnabled is a superset of elabStanzasRequested + pkgStanzasEnabled = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested + , pkgWhyNotPerComponent + } + -- This tells us which components depend on the main library of this package. + -- Note: the sublib case should not occur, because sub-libraries are not + -- supported without per-component builds. + -- TODO: Add a check somewhere that this is the case. + pkgDependsOnSelfLib :: CD.ComponentDeps [()] pkgDependsOnSelfLib = CD.fromList [ (CD.componentNameToComponent cn, [()]) @@ -2237,20 +2248,11 @@ elaborateInstallPlan | ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp} <- comps ] - -- NB: This is not the final setting of 'pkgStanzasEnabled'. - -- See [Sticky enabled testsuites]; we may enable some extra - -- stanzas opportunistically when it is cheap to do so. - -- - -- However, we start off by enabling everything that was - -- requested, so that we can maintain an invariant that - -- pkgStanzasEnabled is a superset of elabStanzasRequested - pkgStanzasEnabled = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested - elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc -> (ElaboratedConfiguredPackage, LogProgress ()) elaborateSolverToCommon - pkg@SolverPackage + solverPkg@SolverPackage { solverPkgStage , solverPkgSource = SourcePackage @@ -2295,17 +2297,20 @@ elaborateInstallPlan elabPlatform = getStage platforms elabStage elabProgramDb = getStage programDbs elabStage - elabPkgDescription = case PD.finalizePD - solverPkgFlags - elabEnabledSpec - (const Satisfied) - elabPlatform - (compilerInfo elabCompiler) - [] - srcpkgDescription of - Right (desc, _) -> desc - Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" + elabPkgDescription = + case PD.finalizePD + solverPkgFlags + elabEnabledSpec + (const Satisfied) + elabPlatform + (compilerInfo elabCompiler) + [] + srcpkgDescription of + Right (desc, _) -> desc + Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" + elabFlagAssignment = solverPkgFlags + elabFlagDefaults = PD.mkFlagAssignment [ (PD.flagName flag, PD.flagDefault flag) @@ -2356,10 +2361,13 @@ elaborateInstallPlan else cp elabPkgSourceLocation = srcpkgSource + elabPkgSourceHash = Map.lookup srcpkgPackageId sourcePackageHashes - elabLocalToProject = isLocalToProject pkg + + elabLocalToProject = isLocalToProject solverPkg + elabBuildStyle = - if shouldBuildInplaceOnly pkg + if shouldBuildInplaceOnly solverPkg then BuildInplaceOnly OnDisk else BuildAndInstall @@ -2368,12 +2376,14 @@ elaborateInstallPlan elabRegisterPackageDBStack = buildAndRegisterDbs elabStage elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription + elabSetupScriptCliVersion = packageSetupScriptSpecVersion elabSetupScriptStyle elabPkgDescription libDepGraph solverPkgLibDeps + elabSetupPackageDBStack = buildAndRegisterDbs (prevStage elabStage) -- Same as corePackageDbs but with the addition of the in-place packagedb. @@ -2387,7 +2397,7 @@ elaborateInstallPlan elabInplaceSetupPackageDBStack = inplacePackageDbs (prevStage elabStage) buildAndRegisterDbs stage - | shouldBuildInplaceOnly pkg = inplacePackageDbs stage + | shouldBuildInplaceOnly solverPkg = inplacePackageDbs stage | otherwise = corePackageDbs stage elabPkgDescriptionOverride = srcpkgDescrOverride @@ -2454,6 +2464,7 @@ elaborateInstallPlan | prog <- configuredPrograms elabProgramDb ] <> perPkgOptionMapLast srcpkgPackageId packageConfigProgramPaths + elabProgramArgs = Map.unionWith (++) @@ -2465,13 +2476,16 @@ elaborateInstallPlan ] ) (perPkgOptionMapMappend srcpkgPackageId packageConfigProgramArgs) + elabProgramPathExtra = perPkgOptionNubList srcpkgPackageId packageConfigProgramPathExtra elabConfiguredPrograms = configuredPrograms elabProgramDb elabConfigureScriptArgs = perPkgOptionList srcpkgPackageId packageConfigConfigureArgs + elabExtraLibDirs = perPkgOptionList srcpkgPackageId packageConfigExtraLibDirs elabExtraLibDirsStatic = perPkgOptionList srcpkgPackageId packageConfigExtraLibDirsStatic elabExtraFrameworkDirs = perPkgOptionList srcpkgPackageId packageConfigExtraFrameworkDirs elabExtraIncludeDirs = perPkgOptionList srcpkgPackageId packageConfigExtraIncludeDirs + elabProgPrefix = perPkgOptionMaybe srcpkgPackageId packageConfigProgPrefix elabProgSuffix = perPkgOptionMaybe srcpkgPackageId packageConfigProgSuffix @@ -2520,7 +2534,6 @@ elaborateInstallPlan where exe = fromFlagOrDefault def bothflag lib = fromFlagOrDefault def (bothflag <> libflag) - bothflag = lookupPerPkgOption pkgid fboth libflag = lookupPerPkgOption pkgid flib @@ -2692,6 +2705,7 @@ elaborateInstallPlan NonSetupLibDepSolverPlanPackage (SolverInstallPlan.toList solverPlan) + packagesWithLibDepsDownwardClosedProperty :: (PackageIdentifier -> Bool) -> Set PackageIdentifier packagesWithLibDepsDownwardClosedProperty property = Set.fromList . maybe [] (map packageId) @@ -2715,12 +2729,15 @@ elaborateInstallPlan -- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId -shouldBeLocal NamedPackage{} = Nothing -shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of - LocalUnpackedPackage _ -> Just (packageId pkg) - _ -> Nothing +shouldBeLocal (NamedPackage _ _) = + Nothing +shouldBeLocal (SpecificSourcePackage pkg) = + case srcpkgSource pkg of + LocalUnpackedPackage _ -> Just (packageId pkg) + _ -> Nothing -- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. +-- TODO: check the role of stage here. matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool matchPlanPkg p = InstallPlan.foldPlanPackage (\(WithStage _stage ipkg) -> p (ipiComponentName ipkg)) (matchElabPkg p) From 55fbb4f6abad682e8432a1b7b2b3951cd3386f44 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 5 Aug 2025 11:13:40 +0800 Subject: [PATCH 45/54] refactor(cabal-install): pkgDependsOnSelfLib should not hide failures Exceptions are not nice but this is an obvious invariant. Graph should provide a better API to make this unnecessary. --- .../src/Distribution/Client/ProjectPlanning.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 95d32832c1b..ead463a5d6f 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -2232,14 +2232,12 @@ elaborateInstallPlan pkgDependsOnSelfLib = CD.fromList [ (CD.componentNameToComponent cn, [()]) - | Graph.N _ cn _ <- fromMaybe [] mb_closure + | Graph.N _ cn _ <- closure ] where - mb_closure = Graph.revClosure compGraph [k | k <- Graph.keys compGraph, is_lib k] - -- NB: the sublib case should not occur, because sub-libraries - -- are not supported without per-component builds - is_lib (CLibName _) = True - is_lib _ = False + closure = + fromMaybe (error "elaborateSolverToPackage: internal error, no closure for main lib") $ + Graph.revClosure compGraph [k | k@(CLibName LMainLibName) <- Graph.keys compGraph] buildComponentDeps :: Monoid a => (ElaboratedComponent -> a) -> CD.ComponentDeps a buildComponentDeps f = From dd2faa15ce65bcb13ca5b5756f1823d2ede7e3b3 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 6 Aug 2025 13:11:51 +0800 Subject: [PATCH 46/54] fix(Cabal): do not print finalized package description, it loops Not really a fix. I do not know why this happens. --- Cabal/src/Distribution/Simple/Configure.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index a8a001f0727..2ba7e22e73a 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -95,7 +95,6 @@ import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Check hiding (doesFileExist, listDirectory) import Distribution.PackageDescription.Configuration -import Distribution.PackageDescription.PrettyPrint import Distribution.Simple.BuildTarget import Distribution.Simple.BuildToolDepends import Distribution.Simple.BuildWay @@ -1147,9 +1146,10 @@ configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform pa , extraCoverageFor = [] } - debug verbosity $ - "Finalized package description:\n" - ++ showPackageDescription pkg_descr2 + -- FIXME: Printing the package description loops indefinitely. + -- debug verbosity $ + -- "Finalized package description:\n" + -- ++ showPackageDescription pkg_descr2 return (lbc, pbd) From ec8c4f8e88398e325015dd5c5d2564b375818c92 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 6 Aug 2025 12:37:31 +0800 Subject: [PATCH 47/54] feature(cabal-install): improve logging of setup arguments --- .../src/Distribution/Client/SetupWrapper.hs | 52 +++++++++++++++++++ 1 file changed, 52 insertions(+) diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 83ac01efd55..918e0632b05 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -738,6 +738,36 @@ things: -- ------------------------------------------------------------ +-- | Run a Setup script by directly invoking the @Cabal@ library. +internalSetupMethod :: SetupRunner +internalSetupMethod verbosity options bt args = 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 +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) @@ -770,6 +800,28 @@ invoke verbosity path args options = do -- ------------------------------------------------------------ +-- * Self-Exec SetupMethod + +-- ------------------------------------------------------------ + +selfExecSetupMethod :: SetupRunner +selfExecSetupMethod verbosity options bt args0 = 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 -- ------------------------------------------------------------ From 9487f1ffedb32fcb69d5d9184f9997e0e8404f1a Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 7 Aug 2025 17:03:53 +0800 Subject: [PATCH 48/54] fix(Cabal): fix abi tag in case ghc's unit-id is the same as the compiler id --- Cabal/src/Distribution/Simple/GHC.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index ba5b1060f44..21e1e08ed5b 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -238,15 +238,13 @@ configureCompiler verbosity hcPath conf0 = do -- In this example, @AbiTag@ is "inplace". compilerAbiTag :: AbiTag compilerAbiTag = - maybe NoAbiTag (AbiTag . dropWhile (== '-') . stripCommonPrefix (prettyShow compilerId)) projectUnitId - - wiredInUnitIds = do - ghcInternalUnitId <- Map.lookup "ghc-internal Unit Id" ghcInfoMap - ghcUnitId <- projectUnitId - pure - [ (mkPackageName "ghc", mkUnitId ghcUnitId) - , (mkPackageName "ghc-internal", mkUnitId ghcInternalUnitId) - ] + case projectUnitId of + Nothing -> NoAbiTag + Just "" -> NoAbiTag + Just unitId -> + case dropWhile (== '-') $ stripCommonPrefix (prettyShow compilerId) unitId of + "" -> NoAbiTag + tag -> AbiTag tag let comp = Compiler From 78293759f7c03777ce5deb38d82f915e437a54fe Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 30 Jul 2025 14:03:35 +0800 Subject: [PATCH 49/54] fix(Cabal): disable logging of the response file It is duplicate information since we write the program invocation right after. --- Cabal/src/Distribution/Simple/Program/ResponseFile.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs index 35aa64687a2..c1e92a8b959 100644 --- a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs +++ b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs @@ -19,7 +19,7 @@ import System.IO (TextEncoding, hClose, hPutStr, hSetEncoding) import Prelude () import Distribution.Compat.Prelude -import Distribution.Simple.Utils (TempFileOptions, debug, withTempFileEx) +import Distribution.Simple.Utils (TempFileOptions, withTempFileEx) import Distribution.Utils.Path import Distribution.Verbosity @@ -34,7 +34,7 @@ withResponseFile -- ^ Arguments to put into response file. -> (FilePath -> IO a) -> IO a -withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f = +withResponseFile _verbosity tmpFileOpts fileNameTemplate encoding arguments f = withTempFileEx tmpFileOpts fileNameTemplate $ \responsePath hf -> do let responseFileName = getSymbolicPath responsePath traverse_ (hSetEncoding hf) encoding @@ -43,9 +43,6 @@ withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f = map escapeResponseFileArg arguments hPutStr hf responseContents hClose hf - debug verbosity $ responseFileName ++ " contents: <<<" - debug verbosity responseContents - debug verbosity $ ">>> " ++ responseFileName f responseFileName -- Support a gcc-like response file syntax. Each separate From 8d14cf8150cbbb9e6fea158bc5bf1c8495a5c236 Mon Sep 17 00:00:00 2001 From: Moritz Angermann Date: Tue, 26 Aug 2025 12:52:41 +0900 Subject: [PATCH 50/54] fixup! fix(Cabal): do not use GHC to configure LD --- Cabal/src/Distribution/Simple/GHC/Internal.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs index cd26038facf..bb9c9e949c1 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -116,13 +116,12 @@ configureToolchain verbosity _implInfo ghcProg ghcInfo db = do -- ghc to compile a _test_ c program. So we configure `gcc` -- first and then use `gcc` (the generic c compiler in cabal -- terminology) to compile the test program. - let db' = - flip addKnownProgram db $ - gccProgram - { programFindLocation = findProg gccProgramName extraGccPath - , programPostConf = configureGcc - } - (gccProg, db'') <- requireProgram verbosity gccProgram db' + let gccProgram' = gccProgram + { programFindLocation = findProg gccProgramName extraGccPath + , programPostConf = configureGcc + } + let db' = flip addKnownProgram db $ gccProgram' + (gccProg, db'') <- requireProgram verbosity gccProgram' db' return $ flip addKnownPrograms db'' $ [ gppProgram From 9b3438d4dec7e19a06204174651aaebc36e9d2cf Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 10 Dec 2025 17:24:55 +0800 Subject: [PATCH 51/54] Fix compilation with TH This is a partial revert of f47840db585dd53d0229c515c786f4f667ea6fd5 GHC toggles -dyanmic-too for TH and now we're missing shared interface files. --- Cabal/src/Distribution/Simple/GHC.hs | 26 +- Cabal/src/Distribution/Utils/LogProgress.hs | 2 +- .../src/Distribution/Solver/Modular.hs | 2 +- .../Distribution/Solver/Modular/Builder.hs | 3 +- .../Distribution/Solver/Modular/Explore.hs | 2 +- .../src/Distribution/Solver/Modular/Index.hs | 2 +- .../Distribution/Solver/Modular/Linking.hs | 7 +- .../Distribution/Solver/Modular/Package.hs | 7 +- .../Distribution/Solver/Modular/Validate.hs | 3 +- .../Distribution/Solver/Types/PackagePath.hs | 1 - .../src/Distribution/Solver/Types/Stage.hs | 1 + .../src/Distribution/Client/CmdPath.hs | 2 +- .../src/Distribution/Client/CmdRepl.hs | 21 +- .../src/Distribution/Client/Dependency.hs | 14 +- .../src/Distribution/Client/InLibrary.hs | 9 +- .../src/Distribution/Client/InstallPlan.hs | 4 +- .../Distribution/Client/ProjectBuilding.hs | 2 +- .../Client/ProjectBuilding/UnpackedPackage.hs | 21 +- .../Client/ProjectConfig/Types.hs | 1 + .../Client/ProjectOrchestration.hs | 2 +- .../Distribution/Client/ProjectPlanning.hs | 129 ++-- .../Client/ProjectPlanning/Types.hs | 5 +- .../src/Distribution/Client/RebuildMonad.hs | 2 +- .../src/Distribution/Client/ScriptUtils.hs | 4 +- .../src/Distribution/Client/SetupWrapper.hs | 592 ++++++++---------- .../Distribution/Client/SolverInstallPlan.hs | 6 +- .../src/Distribution/Client/Targets.hs | 2 + .../src/Distribution/Client/Toolchain.hs | 6 +- .../Distribution/Client/InstallPlan.hs | 1 + .../Distribution/Solver/Modular/DSL.hs | 2 +- .../Distribution/Solver/Modular/QuickCheck.hs | 1 - .../Distribution/Solver/Modular/Solver.hs | 2 +- 32 files changed, 417 insertions(+), 467 deletions(-) diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index 21e1e08ed5b..5f26028139d 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -246,6 +246,14 @@ configureCompiler verbosity hcPath conf0 = do "" -> NoAbiTag tag -> AbiTag tag + wiredInUnitIds = do + ghcInternalUnitId <- Map.lookup "ghc-internal Unit Id" ghcInfoMap + ghcUnitId <- projectUnitId + pure + [ (mkPackageName "ghc", mkUnitId ghcUnitId) + , (mkPackageName "ghc-internal", mkUnitId ghcInternalUnitId) + ] + let comp = Compiler { compilerId @@ -311,7 +319,23 @@ compilerProgramDb verbosity comp progdb1 hcPkgPath = do ghcVersion = compilerVersion comp -- configure gcc, ld, ar etc... based on the paths stored in the GHC settings file - Internal.configureToolchain verbosity (ghcVersionImplInfo ghcVersion) ghcProg (compilerProperties comp) progdb3 + progdb3 <- Internal.configureToolchain verbosity (ghcVersionImplInfo ghcVersion) ghcProg (compilerProperties comp) progdb2 + + -- This is slightly tricky, we have to configure ghc first, then we use the + -- location of ghc to help find ghc-pkg in the case that the user did not + -- specify the location of ghc-pkg directly: + (ghcPkgProg, ghcPkgVersion, progdb4) <- + requireProgramVersion + verbosity + ghcPkgProgram' + anyVersion + progdb3 + + when (ghcVersion /= ghcPkgVersion) $ + dieWithException verbosity $ + VersionMismatchGHC (programPath ghcProg) ghcVersion (programPath ghcPkgProg) ghcPkgVersion + + return progdb4 -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find -- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking diff --git a/Cabal/src/Distribution/Utils/LogProgress.hs b/Cabal/src/Distribution/Utils/LogProgress.hs index 3a5eb7846be..f2631d77100 100644 --- a/Cabal/src/Distribution/Utils/LogProgress.hs +++ b/Cabal/src/Distribution/Utils/LogProgress.hs @@ -80,7 +80,7 @@ runLogProgress' (LogProgress m) = foldProgress (\_ x -> x) Left Right (m env) where env = LogEnv - { le_verbosity = silent + { le_verbosity = mkVerbosity defaultVerbosityHandles silent , le_context = [] } diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index 5e9f75006f3..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 ( 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 875c9bf78c3..c9f1ac521c7 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs @@ -36,6 +36,7 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.ComponentDeps import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.Settings (IndependentGoals (..)) import qualified Distribution.Solver.Types.Stage as Stage -- | All state needed to build and link the search tree. It has a type variable @@ -113,7 +114,7 @@ scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo -> scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s where -- Qualify all package names - qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps + qfdeps = qualifyDeps qpn fdeps -- Introduce all package flags qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs -- Combine new package and flag goals diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs index 1a85feac1b8..5aa9b52c14e 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs @@ -270,7 +270,7 @@ exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I _stage v _) _) conflicts = let (PInfo deps _ _ _) = idx M.! pn M.! i - qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps + qdeps = qualifyDeps currentQPN deps couldBeResolved :: CS.Conflict -> Maybe ConflictSet couldBeResolved CS.OtherConflict = Nothing diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs index cfd8f94a64d..b0b576205ef 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs @@ -69,7 +69,7 @@ defaultQualifyOptions idx = QO { | -- Find all versions of base .. Just is <- [M.lookup base idx] -- .. which are installed .. - , (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is + , (I _ _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is -- .. and flatten all their dependencies .. , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps ] diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs index e14c0751de4..f99c34a64d1 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs @@ -101,7 +101,7 @@ validateLinking index = (`runReader` initVS) . go goP qpn@(Q _pp pn) opt@(POption i _) r = do vs <- ask let PInfo deps _ _ _ = vsIndex vs ! pn ! i - qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps + qdeps = qualifyDeps qpn deps newSaved = M.insert qpn qdeps (vsSaved vs) case execUpdateState (pickPOption qpn opt qdeps) vs of Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) @@ -274,9 +274,8 @@ linkDeps target = \deps -> do (Simple (LDep _ (Pkg _ _)) _, _) -> return () requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN) - requalify deps = do - vs <- get - return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps) + requalify deps = + return $ qualifyDeps target (unqualifyDeps deps) pickFlag :: QFN -> Bool -> UpdateState () pickFlag qfn b = do diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs index 0121e596e65..922020b745b 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs @@ -11,7 +11,6 @@ module Distribution.Solver.Modular.Package , QPV , instI , instUid - , makeIndependent , primaryPP , setupPP , showI @@ -75,7 +74,7 @@ instI (I _ _ (Inst _)) = True instI _ = False instUid :: UnitId -> I -> Bool -instUid uid (I _ (Inst uid')) = uid == uid' +instUid uid (I _ _ (Inst uid')) = uid == uid' instUid _ _ = False -- | Is the package in the primary group of packages. This is used to @@ -101,7 +100,3 @@ setupPP :: PackagePath -> Bool setupPP (PackagePath _ns (QualSetup _)) = True setupPP (PackagePath _ns _) = False --- | Qualify a target package with its own name so that its dependencies are not --- required to be consistent with other targets. -makeIndependent :: PN -> QPN -makeIndependent pn = Q (PackagePath (Independent pn) QualToplevel) pn diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs index 6cbe81424e7..f0c0566d6a1 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs @@ -201,12 +201,11 @@ 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 -- qualify the deps in the current scope - let qdeps = qualifyDeps qo qpn deps + let qdeps = qualifyDeps qpn deps -- the new active constraints are given by the instance we have chosen, -- plus the dependency information we have for that instance let newactives = extractAllDeps pfa psa qdeps diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs index 84bc59bb402..e752c0e6092 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} module Distribution.Solver.Types.PackagePath ( PackagePath(..) - , Namespace(..) , Qualifier(..) , dispQualifier , Qualified(..) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs b/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs index 7ca70f701cc..54880a0491b 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs @@ -37,6 +37,7 @@ data Stage instance Binary Stage instance Structured Stage +instance NFData Stage instance Pretty Stage where pretty = Disp.text . showStage diff --git a/cabal-install/src/Distribution/Client/CmdPath.hs b/cabal-install/src/Distribution/Client/CmdPath.hs index 895f68d6e49..12aadd25634 100644 --- a/cabal-install/src/Distribution/Client/CmdPath.hs +++ b/cabal-install/src/Distribution/Client/CmdPath.hs @@ -253,7 +253,7 @@ pathAction flags@NixStyleFlags{extraFlags = pathFlags'} cliTargetStrings globalF let Toolchain{..} = getStage toolchains Host compilerProg <- requireCompilerProg verbosity toolchainCompiler (configuredCompilerProg, _) <- requireProgram verbosity compilerProg toolchainProgramDb - pure $ Just $ mkCompilerInfo configuredCompilerProg toolchainCompiler + pure $ Just $ mkCompilerInfo configuredCompilerProg toolchainCompiler (cabalStoreDirLayout $ cabalDirLayout baseCtx) paths <- for (fromFlagOrDefault [] $ pathDirectories pathFlags) $ \p -> do t <- getPathLocation verbosity baseCtx p diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index fa947c9fe5f..ac00434a8b8 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -26,7 +26,8 @@ import Distribution.Compat.Lens import qualified Distribution.Types.Lens as L import Distribution.Client.CmdErrorMessages - ( Plural (..) + ( ComponentKind (..) + , Plural (..) , componentKind , renderComponentKind , renderListCommaAnd @@ -192,6 +193,7 @@ import Distribution.Client.ReplFlags ) import Distribution.Compat.Binary (decode) import qualified Distribution.Compat.Graph as Graph +import Distribution.Types.PackageName.Magic (fakePackageId) import Distribution.Simple.Flag (flagToMaybe, fromFlagOrDefault, pattern Flag) import Distribution.Simple.Program.Builtin (ghcProgram) import Distribution.Simple.Program.Db (requireProgram) @@ -608,12 +610,14 @@ targetedRepl go m ("PATH", Just s) = foldl' (\m' f -> Map.insertWith (+) f 1 m') m (splitSearchPath s) go m _ = m + projectRoot = distProjectRootDirectory $ distDirLayout ctx + distDir = distDirectory $ distDirLayout ctx verbosity = cfgVerbosity normal flags tempFileOptions = commonSetupTempFileOptions $ configCommonFlags configFlags -- FIXME: the compiler depends on the stage!! validatedTargets ctx compiler elaboratedPlan targetSelectors = do - let multi_repl_enabled = multiReplDecision ctx compiler r + let multi_repl_enabled = multiReplDecision ctx compiler replFlags -- Interpret the targets on the command line as repl targets -- (as opposed to say build or haddock targets). targets <- @@ -635,6 +639,17 @@ targetedRepl return targets +withCtx :: NixStyleFlags a -> [String] -> GlobalFlags -> TargetsAction [TargetSelector] b -> IO b +withCtx flags targetStrings globalFlags = + withContextAndSelectors + (cfgVerbosity normal flags) + (if null targetStrings then AcceptNoTargets else RejectNoTargets) + (Just LibKind) + flags + targetStrings + globalFlags + ReplCommand + -- | Create a constraint which requires a later version of Cabal. -- This is used for commands which require a specific feature from the Cabal library -- such as multi-repl or the --with-repl flag. @@ -685,7 +700,7 @@ validatedTargets -> Compiler -> ElaboratedInstallPlan -> [TargetSelector] - -> IO TargetsMap + -> IO TargetsMapS validatedTargets verbosity replFlags ctx compiler elaboratedPlan targetSelectors = do let multi_repl_enabled = multiReplDecision ctx compiler replFlags -- Interpret the targets on the command line as repl targets (as opposed to diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index ef3e53d45d7..bb8b17fc71c 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -137,7 +137,8 @@ import Distribution.Types.DependencySatisfaction ( DependencySatisfaction (..) ) import Distribution.Verbosity - ( deafening + ( VerbosityLevel (..) + , deafening , normal ) import Distribution.Version @@ -229,7 +230,7 @@ showDepResolverParams p = , hang (text "constraints:") 2 $ vcat [prettyLabeledConstraint lc | lc <- depResolverConstraints p] , hang (text "preferences:") 2 $ - if depResolverVerbosity p >= deafening + if depResolverVerbosity p >= Deafening then vcat [text (showPackagePreference pref) | pref <- depResolverPreferences p] else text "... increase verbosity to see" , hang (text "strategy:") 2 $ @@ -453,7 +454,7 @@ dependOnWiredIns compiler params = addConstraints extraConstraints params where extraConstraints = [ LabeledPackageConstraint - (PackageConstraint (ScopeAnyQualifier pkgName) (PackagePropertyInstalledSpecificUnitId unitId)) + (PackageConstraint (ConstraintScope Nothing (ScopeAnyQualifier pkgName)) (PackagePropertyInstalledSpecificUnitId unitId)) ConstraintSourceNonReinstallablePackage | (pkgName, unitId) <- fromMaybe [] $ compilerInfoWiredInUnitIds compiler ] @@ -796,7 +797,7 @@ standardInstallPolicy -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams standardInstallPolicy sourcePkgDb pkgSpecifiers = - addDefaultSetupDependencies mkDefaultSetupDeps $ + addDefaultSetupDependencies setImplicitSetupInfo mkDefaultSetupDeps $ basicInstallPolicy sourcePkgDb pkgSpecifiers @@ -858,6 +859,7 @@ resolveDependencies toolchains pkgConfigDB installedPkgIndex params = cntConflicts fineGrained minimize + indGoals noReinstalls shadowing strFlags @@ -904,6 +906,8 @@ resolveDependencies toolchains pkgConfigDB installedPkgIndex params = then dependOnWiredIns comp params else dontInstallNonReinstallablePackages params + comp = fst (getStage toolchains Host) + formatProgress :: Progress SummarizedMessage String a -> Progress String String a formatProgress p = foldProgress (\x xs -> Step (renderSummarizedMessage x) xs) Fail Done p @@ -978,7 +982,7 @@ validateSolverResult -> SolverInstallPlan validateSolverResult toolchains pkgs = case planPackagesProblems toolchains pkgs of - [] -> case SolverInstallPlan.new graph of + [] -> case SolverInstallPlan.new (IndependentGoals False) graph of Right plan -> plan Left problems -> error (formatPlanProblems problems) problems -> error (formatPkgProblems problems) diff --git a/cabal-install/src/Distribution/Client/InLibrary.hs b/cabal-install/src/Distribution/Client/InLibrary.hs index 7b6470ba73f..847222a14cd 100644 --- a/cabal-install/src/Distribution/Client/InLibrary.hs +++ b/cabal-install/src/Distribution/Client/InLibrary.hs @@ -37,6 +37,9 @@ 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 (..)) +import Distribution.Solver.Types.Stage (getStage) import Distribution.System (Platform) import Distribution.Types.BuildType import Distribution.Types.ComponentRequestedSpec @@ -86,8 +89,7 @@ libraryConfigureInputsFromElabPackage -- NB: don't use the ProgramDb from the ElaboratedSharedConfig; -- that one is only for the compiler itself and not for the package. ElaboratedSharedConfig - { pkgConfigPlatform = plat - , pkgConfigCompiler = compil + { pkgConfigToolchains = toolchains } (ReadyPackage pkg) userTargets = @@ -123,6 +125,9 @@ libraryConfigureInputsFromElabPackage where pkgDescr = elabPkgDescription pkg gpkgDescr = elabGPkgDescription pkg + hostToolchain = getStage toolchains Host + plat = toolchainPlatform hostToolchain + compil = toolchainCompiler hostToolchain configure :: LibraryConfigureInputs diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index df0454a0803..0ff295c4608 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -393,7 +393,7 @@ mkInstallPlan mkInstallPlan graph = case NE.nonEmpty (problems graph) of Just problems' -> Left $ renderPlanProblems (NE.toList problems') - Nothing -> Right $ GenericInstallPlan{planGraph = graph} + Nothing -> Right $ GenericInstallPlan{planGraph = graph, planIndepGoals = IndependentGoals False} mkInstallPlan' :: ( IsGraph ipkg srcpkg @@ -404,7 +404,7 @@ mkInstallPlan' mkInstallPlan' graph = case NE.nonEmpty (problems graph) of Just problems' -> Left problems' - Nothing -> Right $ GenericInstallPlan{planGraph = graph} + Nothing -> Right $ GenericInstallPlan{planGraph = graph, planIndepGoals = IndependentGoals False} -- | Build an installation plan from a set of packages. new diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index aca1d70e2ab..53eddd56baf 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -460,7 +460,7 @@ rebuildTargets' getStage (pkgConfigToolchains sharedPackageConfig) (elabStage elab) unless exists $ do createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) - Cabal.createPackageDB verbosity toolchainCompiler toolchainProgramDb False dbPath + Cabal.createPackageDB verbosity toolchainCompiler toolchainProgramDb dbPath _ -> pure () _ -> pure () diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 71c750010c7..2518d96599f 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -122,7 +122,6 @@ import GHC.Stack import Web.Browser (openBrowser) import Distribution.Client.Errors -import Distribution.Compat.Directory (listDirectory) import Distribution.Client.ProjectBuilding.PackageFileMonitor import qualified Distribution.Compat.Graph as Graph @@ -196,11 +195,13 @@ buildAndRegisterUnpackedPackage delegate = do info verbosity $ "\n\nbuildAndRegisterUnpackedPackage: " ++ prettyShow (Graph.nodeKey pkg) -- Configure phase - delegate $ - PBConfigurePhase $ - annotateFailure mlogFile ConfigureFailed $ do - info verbosity $ "--- Configure phase " ++ prettyShow (Graph.nodeKey pkg) - setup configureCommand Cabal.configCommonFlags configureFlags configureArgs + mbLBI <- + delegate $ + PBConfigurePhase $ + annotateFailure mlogFile ConfigureFailed $ do + info verbosity $ "--- Configure phase " ++ prettyShow (Graph.nodeKey pkg) + setup configureCommand Cabal.configCommonFlags configureFlags configureArgs + (InLibraryArgs $ InLibraryConfigureArgs pkgshared rpkg) -- Build phase delegate $ @@ -208,6 +209,7 @@ buildAndRegisterUnpackedPackage annotateFailure mlogFile BuildFailed $ do info verbosity $ "--- Build phase " ++ prettyShow (Graph.nodeKey pkg) setup buildCommand Cabal.buildCommonFlags (return . buildFlags) buildArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SBuildPhase mbLBI) -- Haddock phase whenHaddock $ @@ -216,6 +218,7 @@ buildAndRegisterUnpackedPackage annotateFailure mlogFile HaddocksFailed $ do info verbosity $ "--- Haddock phase " ++ prettyShow (Graph.nodeKey pkg) setup haddockCommand Cabal.haddockCommonFlags (return . haddockFlags) haddockArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SHaddockPhase mbLBI) -- Install phase delegate $ @@ -224,6 +227,7 @@ buildAndRegisterUnpackedPackage annotateFailure mlogFile InstallFailed $ do info verbosity $ "--- Install phase, copy " ++ prettyShow (Graph.nodeKey pkg) setup Cabal.copyCommand Cabal.copyCommonFlags (return . copyFlags destdir) copyArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SCopyPhase mbLBI) , runRegister = \pkgDBStack registerOpts -> annotateFailure mlogFile InstallFailed $ do info verbosity $ "--- Install phase, register " ++ prettyShow (Graph.nodeKey pkg) @@ -251,6 +255,7 @@ buildAndRegisterUnpackedPackage annotateFailure mlogFile TestsFailed $ do info verbosity $ "--- Test phase " ++ prettyShow (Graph.nodeKey pkg) setup testCommand Cabal.testCommonFlags (return . testFlags) testArgs + (InLibraryArgs $ InLibraryPostConfigureArgs STestPhase mbLBI) -- Bench phase whenBench $ @@ -259,6 +264,7 @@ buildAndRegisterUnpackedPackage annotateFailure mlogFile BenchFailed $ do info verbosity $ "--- Benchmark phase " ++ prettyShow (Graph.nodeKey pkg) setup benchCommand Cabal.benchmarkCommonFlags (return . benchFlags) benchArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SBenchPhase mbLBI) -- Repl phase whenRepl $ @@ -266,7 +272,8 @@ buildAndRegisterUnpackedPackage PBReplPhase $ annotateFailure mlogFile ReplFailed $ do info verbosity $ "--- Repl phase " ++ prettyShow (Graph.nodeKey pkg) - setupInteractive replCommand Cabal.replCommonFlags replFlags replArgs + setupInteractive replCommand Cabal.replCommonFlags (return . replFlags) replArgs + (InLibraryArgs $ InLibraryPostConfigureArgs SReplPhase mbLBI) return () where diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index 7dc5b714f69..e2c36da813f 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -376,6 +376,7 @@ instance NFData ProjectConfigToParse where instance NFData ProjectConfig instance NFData ProjectConfigBuildOnly +instance NFData ProjectConfigToolchain instance NFData ProjectConfigShared instance NFData ProjectConfigProvenance where diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 7c3f0ca700e..5baeb8b8346 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -1128,7 +1128,7 @@ printPlan (not . null) [ " -" , prettyShow (elabStage elab) - , if verbosity >= deafening + , if verbosityLevel verbosity >= Deafening then prettyShow (installedUnitId elab) else prettyShow (packageId elab) , case elabBuildStyle elab of diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index ead463a5d6f..9c72ebf204d 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -413,7 +413,7 @@ rebuildProjectConfig let fetchCompiler = do -- have to create the cache directory before configuring the compiler liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - toolchains <- configureToolchains verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) + toolchains <- configureToolchains verbosity distDirLayout (snd (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) -- The project configuration is always done with the host compiler let Toolchain{toolchainCompiler = compiler, toolchainPlatform = Platform arch os} = getStage toolchains Host return (os, arch, compiler) @@ -1802,7 +1802,7 @@ elaborateInstallPlan <+> fsep (punctuate comma $ map (text . whyNotPerComponent) $ toList reasons) -- TODO: Maybe exclude Backpack too - elab0 = elaborateSolverToCommon solverPkg + (elab0, _) = elaborateSolverToCommon solverPkg pkgid = elabPkgSourceId elab0 pd = elabPkgDescription elab0 @@ -2157,11 +2157,11 @@ elaborateInstallPlan elaborationWarnings return elab where - elab0@ElaboratedConfiguredPackage + (elab0@ElaboratedConfiguredPackage { elabPkgSourceHash , elabStanzasRequested , elabStage - } = elaborateSolverToCommon solverPkg + }, elaborationWarnings) = elaborateSolverToCommon solverPkg elab1 = elab0 @@ -2212,7 +2212,7 @@ elaborateInstallPlan , pkgExeDependencies = buildComponentDeps (filter isExternal' . compExeDependencies) , pkgExeDependencyPaths = buildComponentDeps (filter (isExternal' . fst) . compExeDependencyPaths) , -- Why is this flat? - pkgPkgConfigDependencies = CD.flatDeps $ buildComponentDeps compPkgConfigDependencies + pkgPkgConfigDependencies = concatMap snd . CD.toList $ buildComponentDeps compPkgConfigDependencies , -- NB: This is not the final setting of 'pkgStanzasEnabled'. -- See [Sticky enabled testsuites]; we may enable some extra -- stanzas opportunistically when it is cheap to do so. @@ -2263,7 +2263,7 @@ elaborateInstallPlan , solverPkgStanzas , solverPkgLibDeps } = - elaboratedPackage + (elaboratedPackage, buildOptionsAdjustmentWarnings) where compilers = fmap toolchainCompiler toolchains platforms = fmap toolchainPlatform toolchains @@ -2276,7 +2276,7 @@ elaborateInstallPlan buildOptionsAdjustmentWarnings = mapM_ (warnProgress . text) $ Cabal.buildOptionsAdjustmentWarnings - compiler + elabCompiler elabBuildOptionsRaw elabBuildOptions @@ -2307,6 +2307,8 @@ elaborateInstallPlan Right (desc, _) -> desc Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" + elabGPkgDescription = srcpkgDescription + elabFlagAssignment = solverPkgFlags elabFlagDefaults = @@ -2410,8 +2412,9 @@ elaborateInstallPlan elabBuildOptionsRaw = LBC.BuildOptions { withVanillaLib = perPkgOptionFlag srcpkgPackageId True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively - , withSharedLib = srcpkgPackageId `Set.member` pkgsUseSharedLibrary + , withSharedLib = srcpkgPackageId `Set.member` pkgsUseSharedLibrary elabCompiler , withStaticLib = perPkgOptionFlag srcpkgPackageId False packageConfigStaticLib + , withBytecodeLib = perPkgOptionFlag srcpkgPackageId False packageConfigBytecodeLib , withDynExe = perPkgOptionFlag srcpkgPackageId False packageConfigDynExe -- We can't produce a dynamic executable if the user @@ -2421,8 +2424,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 - , withProfLibShared = srcpkgPackageId `Set.member` pkgsUseProfilingLibraryShared + , withProfLib = srcpkgPackageId `Set.member` pkgsUseProfilingLibrary elabCompiler + , withProfLibShared = srcpkgPackageId `Set.member` pkgsUseProfilingLibraryShared elabCompiler , exeCoverage = perPkgOptionFlag srcpkgPackageId False packageConfigCoverage , libCoverage = perPkgOptionFlag srcpkgPackageId False packageConfigCoverage , withOptimization = perPkgOptionFlag srcpkgPackageId NormalOptimisation packageConfigOptimization @@ -2438,7 +2441,7 @@ elaborateInstallPlan okProfDyn = profilingDynamicSupportedOrUnknown elabCompiler profExe = perPkgOptionFlag srcpkgPackageId False packageConfigProf - elabBuildOptions = Cabal.adjustBuildOptions compiler compilerprogdb elabBuildOptionsRaw + elabBuildOptions = Cabal.adjustBuildOptions elabCompiler elabProgramDb elabBuildOptionsRaw ( elabProfExeDetail , elabProfLibDetail @@ -2586,11 +2589,11 @@ elaborateInstallPlan -- TODO: localPackages is a misnomer, it's all project packages -- here is where we decide which ones will be local! - pkgsUseSharedLibrary :: Set PackageId - pkgsUseSharedLibrary = - packagesWithLibDepsDownwardClosedProperty needsSharedLib + pkgsUseSharedLibrary :: Compiler -> Set PackageId + pkgsUseSharedLibrary compiler = + packagesWithLibDepsDownwardClosedProperty (needsSharedLib compiler) - needsSharedLib pkgid = + needsSharedLib compiler pkgid = fromMaybe compilerShouldUseSharedLibByDefault -- Case 1: --enable-shared or --disable-shared is passed explicitly, honour that. @@ -2615,63 +2618,48 @@ elaborateInstallPlan pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe pkgProf = perPkgOptionMaybe pkgid packageConfigProf - -- TODO: [code cleanup] move this into the Cabal lib. It's currently open - -- coded in Distribution.Simple.Configure, but should be made a proper - -- function of the Compiler or CompilerInfo. - compilerShouldUseSharedLibByDefault = - case compilerFlavor compiler of - GHC -> GHC.compilerBuildWay compiler == DynWay && canBuildSharedLibs - GHCJS -> GHCJS.isDynamic compiler - _ -> False - - compilerShouldUseProfilingLibByDefault = - case compilerFlavor compiler of - GHC -> GHC.compilerBuildWay compiler == ProfWay && canBuildProfilingLibs - _ -> False - - compilerShouldUseProfilingSharedLibByDefault = - case compilerFlavor compiler of - GHC -> GHC.compilerBuildWay compiler == ProfDynWay && canBuildProfilingSharedLibs - _ -> False - - -- Returns False if we definitely can't build shared libs - canBuildWayLibs predicate = case predicate compiler of - Just can_build -> can_build - -- If we don't know for certain, just assume we can - -- which matches behaviour in previous cabal releases - Nothing -> True - - canBuildSharedLibs = canBuildWayLibs dynamicSupported - canBuildProfilingLibs = canBuildWayLibs profilingVanillaSupported - canBuildProfilingSharedLibs = canBuildWayLibs profilingDynamicSupported - - wayWarnings pkg = do - when - (needsProfilingLib pkg && not canBuildProfilingLibs) - (warnProgress (text "Compiler does not support building p libraries, profiling is disabled")) - when - (needsSharedLib pkg && not canBuildSharedLibs) - (warnProgress (text "Compiler does not support building dyn libraries, dynamic libraries are disabled")) - when - (needsProfilingLibShared pkg && not canBuildProfilingSharedLibs) - (warnProgress (text "Compiler does not support building p_dyn libraries, profiling dynamic libraries are disabled.")) - - pkgsUseProfilingLibrary :: Set PackageId - pkgsUseProfilingLibrary = - packagesWithLibDepsDownwardClosedProperty needsProfilingLib - - needsProfilingLib pkg = + compilerShouldUseSharedLibByDefault = + case compilerFlavor compiler of + GHC -> GHC.compilerBuildWay compiler == DynWay && canBuildSharedLibs + GHCJS -> GHCJS.isDynamic compiler + _ -> False + + canBuildWayLibs predicate = case predicate compiler of + Just can_build -> can_build + -- If we don't know for certain, just assume we can + -- which matches behaviour in previous cabal releases + Nothing -> True + + canBuildSharedLibs = canBuildWayLibs dynamicSupported + canBuildProfilingSharedLibs = canBuildWayLibs profilingDynamicSupported + + pkgsUseProfilingLibrary :: Compiler -> Set PackageId + pkgsUseProfilingLibrary compiler = + packagesWithLibDepsDownwardClosedProperty (needsProfilingLib compiler) + + needsProfilingLib compiler pkg = fromFlagOrDefault compilerShouldUseProfilingLibByDefault (profBothFlag <> profLibFlag) where pkgid = packageId pkg profBothFlag = lookupPerPkgOption pkgid packageConfigProf profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib - pkgsUseProfilingLibraryShared :: Set PackageId - pkgsUseProfilingLibraryShared = - packagesWithLibDepsDownwardClosedProperty needsProfilingLibShared + compilerShouldUseProfilingLibByDefault = + case compilerFlavor compiler of + GHC -> GHC.compilerBuildWay compiler == ProfWay && canBuildProfilingLibs + _ -> False + + canBuildWayLibs predicate = case predicate compiler of + Just can_build -> can_build + Nothing -> True + + canBuildProfilingLibs = canBuildWayLibs profilingVanillaSupported - needsProfilingLibShared pkg = + pkgsUseProfilingLibraryShared :: Compiler -> Set PackageId + pkgsUseProfilingLibraryShared compiler = + packagesWithLibDepsDownwardClosedProperty (needsProfilingLibShared compiler) + + needsProfilingLibShared compiler pkg = fromMaybe compilerShouldUseProfilingSharedLibByDefault -- case 1: If --enable-profiling-shared is passed explicitly, honour that @@ -2695,6 +2683,17 @@ elaborateInstallPlan pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe pkgProf = perPkgOptionMaybe pkgid packageConfigProf + compilerShouldUseProfilingSharedLibByDefault = + case compilerFlavor compiler of + GHC -> GHC.compilerBuildWay compiler == ProfDynWay && canBuildProfilingSharedLibs + _ -> False + + canBuildWayLibs predicate = case predicate compiler of + Just can_build -> can_build + Nothing -> True + + canBuildProfilingSharedLibs = canBuildWayLibs profilingDynamicSupported + -- TODO: [code cleanup] unused: the old deprecated packageConfigProfExe libDepGraph = diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index b0ce160906e..3588d0719ff 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -128,6 +128,7 @@ import qualified Distribution.Types.LocalBuildConfig as LBC import Distribution.Types.PackageDescription (PackageDescription (..)) import Distribution.Types.PkgconfigVersion import Distribution.Utils.Path (getSymbolicPath) +import Distribution.Verbosity (Verbosity, VerbosityLevel (..), verbosityLevel) import Distribution.Version import qualified Data.ByteString.Lazy as LBS @@ -607,7 +608,7 @@ elabOrderLibDependencies elab = case elabPkgOrComp elab of ElabPackage pkg -> -- Note: flatDeps include the setup dependencies too - ordNub $ CD.flatDeps (pkgOrderLibDependencies pkg) + ordNub $ concatMap snd . CD.toList $ (pkgOrderLibDependencies pkg) ElabComponent comp -> map (WithStage (elabStage elab)) (compOrderLibDependencies comp) @@ -616,7 +617,7 @@ elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderExeDependencies elab = case elabPkgOrComp elab of ElabPackage pkg -> - ordNub $ CD.flatDeps (pkgOrderExeDependencies pkg) + ordNub $ concatMap snd . CD.toList $ (pkgOrderExeDependencies pkg) ElabComponent comp -> map (fmap fromConfiguredId) (compExeDependencies comp) diff --git a/cabal-install/src/Distribution/Client/RebuildMonad.hs b/cabal-install/src/Distribution/Client/RebuildMonad.hs index acb8faaf64c..2ba8b65aca2 100644 --- a/cabal-install/src/Distribution/Client/RebuildMonad.hs +++ b/cabal-install/src/Distribution/Client/RebuildMonad.hs @@ -75,7 +75,7 @@ import Control.Monad import Control.Monad.Reader as Reader import Control.Monad.State as State import qualified Data.Map.Strict as Map -import Distribution.Client.Compat.ExecutablePath (getExecutablePath) +import System.Environment (getExecutablePath) import System.Directory import System.FilePath diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index 8484ef5489d..68d4b48e48d 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -382,7 +382,7 @@ withContextAndSelectors verbosity noTargets kind flags@NixStyleFlags{..} targetS createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout baseCtx) toolchains <- - runRebuild projectRoot $ configureToolchains verbosity (distDirLayout baseCtx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig baseCtx) + runRebuild projectRoot $ configureToolchains verbosity (distDirLayout baseCtx) (snd (ignoreConditions projectCfgSkeleton) <> projectConfig baseCtx) let Toolchain{toolchainCompiler, toolchainPlatform = toolchainPlatform@(Platform arch os)} = getStage toolchains Host @@ -480,7 +480,7 @@ updateContextAndWriteProjectFile ctx scriptPath scriptExecutable = do let sourcePackage = fakeProjectSourcePackage projectRoot & lSrcpkgDescription . L.condExecutables - .~ [(scriptComponentName scriptPath, CondNode executable (targetBuildDepends $ buildInfo executable) [])] + .~ [(scriptComponentName scriptPath, CondNode executable [])] executable = scriptExecutable & L.modulePath .~ absScript diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 918e0632b05..bf2748b4ff3 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -59,6 +59,7 @@ import Distribution.PackageDescription , buildType , specVersion ) +import qualified Distribution.Make as Make import qualified Distribution.Simple as Simple import Distribution.Simple.Build.Macros ( generatePackageVersionMacros @@ -118,6 +119,9 @@ import Distribution.Client.Utils #endif , moreRecentFile , tryCanonicalizePath + , withEnv + , withEnvOverrides + , withExtraPathEnv ) import Distribution.Utils.Path hiding ( (), (<.>) ) @@ -178,6 +182,7 @@ 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 (..)) @@ -655,7 +660,7 @@ setupWrapper verbosity options mpkg cmd getCommonFlags getFlags getExtraArgs wra setupProgDb <- configCompilerProgDb verbosity - (pkgConfigCompiler elabSharedConfig) + (toolchainCompiler $ getStage (pkgConfigToolchains elabSharedConfig) Host) baseProgDb Nothing -- we use configProgramPaths instead lbi0 <- @@ -739,8 +744,8 @@ things: -- ------------------------------------------------------------ -- | Run a Setup script by directly invoking the @Cabal@ library. -internalSetupMethod :: SetupRunner -internalSetupMethod verbosity options bt args = do +internalSetupMethod :: SetupRunner UseGeneralSetup +internalSetupMethod verbosity options bt args NotInLibrary = do info verbosity $ "Using internal setup method with build-type " ++ show bt @@ -764,6 +769,7 @@ 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" @@ -804,8 +810,8 @@ invoke verbosity path args options = do -- ------------------------------------------------------------ -selfExecSetupMethod :: SetupRunner -selfExecSetupMethod verbosity options bt args0 = do +selfExecSetupMethod :: SetupRunner UseGeneralSetup +selfExecSetupMethod verbosity options bt args0 NotInLibrary = do let args = [ "act-as-setup" , "--build-type=" ++ prettyShow bt @@ -1103,351 +1109,243 @@ cachedSetupDirAndProg platform bt options' cabalLibVersion = do ++ "-" ++ compilerVersionString ) - installedVersion = do - (comp, progdb, options') <- configureToolchains options - (version, mipkgid, options'') <- - installedCabalVersion - options' - comp - progdb - updateSetupScript version bt - writeSetupVersionFile version - return (version, mipkgid, options'') - - savedVersion :: IO (Maybe Version) - savedVersion = do - versionString <- readFile (i setupVersionFile) `catchIO` \_ -> return "" - case reads versionString of - [(version, s)] | all isSpace s -> return (Just version) - _ -> return Nothing - - -- \| Update a Setup.hs script, creating it if necessary. - updateSetupScript :: Version -> BuildType -> IO () - updateSetupScript _ Custom = do - useHs <- doesFileExist customSetupHs - useLhs <- doesFileExist customSetupLhs - unless (useHs || useLhs) $ - dieWithException verbosity UpdateSetupScript - let src = (if useHs then customSetupHs else customSetupLhs) - srcNewer <- src `moreRecentFile` i setupHs - when srcNewer $ - if useHs - then copyFileVerbose verbosity src (i setupHs) - else runSimplePreProcessor ppUnlit src (i setupHs) verbosity - where - customSetupHs = workingDir options "Setup.hs" - customSetupLhs = workingDir options "Setup.lhs" - updateSetupScript cabalLibVersion Hooks = do - - let customSetupHooks = workingDir options "SetupHooks.hs" - useHs <- doesFileExist customSetupHooks - unless (useHs) $ - die' - verbosity - "Using 'build-type: Hooks' but there is no SetupHooks.hs file." - copyFileVerbose verbosity customSetupHooks (i setupHooks) - rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) --- rewriteFileLBS verbosity hooksHs hooksScript - updateSetupScript cabalLibVersion _ = - rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) - - buildTypeScript :: Version -> BS.ByteString - buildTypeScript cabalLibVersion = "{-# LANGUAGE NoImplicitPrelude #-}\n" <> case bt of - Simple -> "import Distribution.Simple; main = defaultMain\n" - Configure - | cabalLibVersion >= mkVersion [3, 13, 0] - -> "import Distribution.Simple; main = defaultMainWithSetupHooks autoconfSetupHooks\n" - | cabalLibVersion >= mkVersion [1, 3, 10] - -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n" - | otherwise - -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n" - Make -> "import Distribution.Make; main = defaultMain\n" - Hooks - | cabalLibVersion >= mkVersion [3, 13, 0] - -> "import Distribution.Simple; import SetupHooks; main = defaultMainWithSetupHooks setupHooks\n" - | otherwise - -> error "buildTypeScript Hooks with Cabal < 3.13" - Custom -> error "buildTypeScript Custom" - - installedCabalVersion - :: SetupScriptOptions - -> Compiler - -> ProgramDb - -> IO - ( Version - , Maybe InstalledPackageId - , SetupScriptOptions - ) - installedCabalVersion options' _ _ - | packageName pkg == mkPackageName "Cabal" - && bt == Custom = - return (packageVersion pkg, Nothing, options') - installedCabalVersion options' compiler progdb = do - index <- maybeGetInstalledPackages options' compiler progdb - let cabalDepName = mkPackageName "Cabal" - cabalDepVersion = useCabalVersion options' - options'' = options'{usePackageIndex = Just index} - case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of - [] -> - dieWithException verbosity $ InstalledCabalVersion (packageName pkg) (useCabalVersion options) - pkgs -> - let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs - err = error "Distribution.Client.installedCabalVersion: empty version list" - in return - ( packageVersion ipkginfo - , Just . IPI.installedComponentId $ ipkginfo - , options'' - ) - - bestVersion :: (a -> Version) -> [a] -> a - bestVersion f = firstMaximumBy (comparing (preference . f)) - where - -- Like maximumBy, but picks the first maximum element instead of the - -- last. In general, we expect the preferred version to go first in the - -- list. For the default case, this has the effect of choosing the version - -- installed in the user package DB instead of the global one. See #1463. - -- - -- Note: firstMaximumBy could be written as just - -- `maximumBy cmp . reverse`, but the problem is that the behaviour of - -- maximumBy is not fully specified in the case when there is not a single - -- greatest element. - firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a - firstMaximumBy _ [] = - error "Distribution.Client.firstMaximumBy: empty list" - firstMaximumBy cmp xs = foldl1' maxBy xs - where - maxBy x y = case cmp x y of GT -> x; EQ -> x; LT -> y - - preference version = - ( sameVersion - , sameMajorVersion - , stableVersion - , latestVersion - ) - where - sameVersion = version == cabalVersion - sameMajorVersion = majorVersion version == majorVersion cabalVersion - majorVersion = take 2 . versionNumbers - stableVersion = case versionNumbers version of - (_ : x : _) -> even x - _ -> False - latestVersion = version - - configureToolchains - :: SetupScriptOptions - -> IO (Compiler, ProgramDb, SetupScriptOptions) - configureToolchains options' = do - (comp, progdb) <- case useCompiler options' of - Just comp -> return (comp, useProgramDb options') - Nothing -> do - (comp, _, progdb) <- - configCompilerEx - (Just GHC) - Nothing - Nothing - (useProgramDb options') - verbosity - return (comp, progdb) - -- Whenever we need to call configureCompiler, we also need to access the - -- package index, so let's cache it in SetupScriptOptions. - index <- maybeGetInstalledPackages options' comp progdb - return - ( comp - , progdb - , options' - { useCompiler = Just comp - , usePackageIndex = Just index - , useProgramDb = progdb - } - ) - - -- \| Path to the setup exe cache directory and path to the cached setup - -- executable. - cachedSetupDirAndProg - :: SetupScriptOptions - -> Version - -> IO (FilePath, FilePath) - cachedSetupDirAndProg options' cabalLibVersion = do - cacheDir <- defaultCacheDir - let setupCacheDir = cacheDir "setup-exe-cache" - cachedSetupProgFile = - setupCacheDir - ( "setup-" - ++ buildTypeString - ++ "-" - ++ cabalVersionString - ++ "-" - ++ platformString - ++ "-" - ++ compilerVersionString - ) - <.> exeExtension buildPlatform - return (setupCacheDir, cachedSetupProgFile) - where - buildTypeString = show bt - cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion - compilerVersionString = - prettyShow $ - maybe buildCompilerId compilerId $ - useCompiler options' - platformString = prettyShow platform - - -- \| Look up the setup executable in the cache; update the cache if the setup - -- executable is not found. - getCachedSetupExecutable - :: SetupScriptOptions - -> Version - -> Maybe InstalledPackageId - -> IO FilePath - getCachedSetupExecutable - options' - cabalLibVersion - maybeCabalLibInstalledPkgId = do - (setupCacheDir, cachedSetupProgFile) <- - cachedSetupDirAndProg options' cabalLibVersion - cachedSetupExists <- doesFileExist cachedSetupProgFile - if cachedSetupExists + <.> exeExtension buildPlatform + return (setupCacheDir, cachedSetupProgFile) + where + buildTypeString = show bt + cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion + compilerVersionString = + prettyShow $ + maybe buildCompilerId compilerId $ + useCompiler options' + platformString = prettyShow platform + +getCachedSetupExecutable + :: Verbosity + -> Platform + -> PackageIdentifier + -> BuildType + -> SetupScriptOptions + -> Version + -> Maybe ComponentId + -> IO FilePath +getCachedSetupExecutable + verbosity + platform + pkgId + bt + options' + cabalLibVersion + maybeCabalLibInstalledPkgId = do + (setupCacheDir, cachedSetupProgFile) <- + cachedSetupDirAndProg platform bt options' cabalLibVersion + cachedSetupExists <- doesFileExist cachedSetupProgFile + if cachedSetupExists + then + debug verbosity $ + "Found cached setup executable: " ++ cachedSetupProgFile + else criticalSection' $ do + -- The cache may have been populated while we were waiting. + cachedSetupExists' <- doesFileExist cachedSetupProgFile + if cachedSetupExists' then debug verbosity $ "Found cached setup executable: " ++ cachedSetupProgFile - else criticalSection' $ do - -- The cache may have been populated while we were waiting. - cachedSetupExists' <- doesFileExist cachedSetupProgFile - if cachedSetupExists' - then - debug verbosity $ - "Found cached setup executable: " ++ cachedSetupProgFile - else do - debug verbosity $ "Setup executable not found in the cache." - src <- - compileSetupExecutable - options' - cabalLibVersion - maybeCabalLibInstalledPkgId - True - createDirectoryIfMissingVerbose verbosity True setupCacheDir - installExecutableFile verbosity src cachedSetupProgFile - -- Do not strip if we're using GHCJS, since the result may be a script - when (maybe True ((/= GHCJS) . compilerFlavor) $ useCompiler options') $ do - -- Add the relevant PATH overrides for the package to the - -- program database. - setupProgDb - <- prependProgramSearchPath verbosity - (useExtraPathEnv options) - (useExtraEnvOverrides options) - (useProgramDb options') - >>= configureAllKnownPrograms verbosity - Strip.stripExe - verbosity - platform - setupProgDb - cachedSetupProgFile - return cachedSetupProgFile - where - criticalSection' = maybe id criticalSection $ setupCacheLock options' - - -- \| If the Setup.hs is out of date wrt the executable then recompile it. - -- Currently this is GHC/GHCJS only. It should really be generalised. - compileSetupExecutable - :: SetupScriptOptions - -> Version - -> Maybe ComponentId - -> Bool - -> IO FilePath - compileSetupExecutable - options' - cabalLibVersion - maybeCabalLibInstalledPkgId - forceCompile = do - setupHsNewer <- i setupHs `moreRecentFile` i setupProgFile - cabalVersionNewer <- i setupVersionFile `moreRecentFile` i setupProgFile - let outOfDate = setupHsNewer || cabalVersionNewer - when (outOfDate || forceCompile) $ do - debug verbosity "Setup executable needs to be updated, compiling..." - (compiler, progdb, options'') <- configureToolchains options' - pkgDbs <- traverse (traverse (makeRelativeToDirS mbWorkDir)) (coercePackageDBStack (usePackageDB options'')) - let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion - (program, extraOpts) = - case compilerFlavor compiler of - GHCJS -> (ghcjsProgram, ["-build-runner"]) - _ -> (ghcProgram, ["-threaded"]) - cabalDep = - maybe - [] - (\ipkgid -> [(ipkgid, cabalPkgid)]) - maybeCabalLibInstalledPkgId - - -- With 'useDependenciesExclusive' and Custom build type, - -- we enforce the deps specified, so only the given ones can be used. - -- Otherwise we add on a dep on the Cabal library - -- (unless 'useDependencies' already contains one). - selectedDeps - | (useDependenciesExclusive options' && (bt /= Hooks)) - -- NB: to compile build-type: Hooks packages, we need Cabal - -- in order to compile @main = defaultMainWithSetupHooks setupHooks@. - || any (isCabalPkgId . snd) (useDependencies options') - = useDependencies options' - | otherwise = - useDependencies options' ++ cabalDep - addRenaming (ipid, _) = - -- Assert 'DefUnitId' invariant - ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) - , defaultRenaming - ) - cppMacrosFile = setupDir Cabal.Path. makeRelativePathEx "setup_macros.h" - ghcOptions = - mempty - { -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use - -- --ghc-option=-v instead! - ghcOptVerbosity = Flag (min verbosity normal) - , ghcOptMode = Flag GhcModeMake - , ghcOptInputFiles = toNubListR [setupHs] - , ghcOptOutputFile = Flag $ setupProgFile - , ghcOptObjDir = Flag $ setupDir - , ghcOptHiDir = Flag $ setupDir - , ghcOptSourcePathClear = Flag True - , ghcOptSourcePath = case bt of - Custom -> toNubListR [sameDirectory] - Hooks -> toNubListR [sameDirectory] - _ -> mempty - , ghcOptPackageDBs = pkgDbs - , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') - , ghcOptCabal = Flag (useDependenciesExclusive options') - , ghcOptPackages = toNubListR $ map addRenaming selectedDeps - -- With 'useVersionMacros', use a version CPP macros .h file. - , ghcOptCppIncludes = - toNubListR - [ cppMacrosFile - | useVersionMacros options' - ] - , ghcOptExtra = extraOpts - , ghcOptExtensions = toNubListR $ - if bt == Custom || any (isBasePkgId . snd) selectedDeps - then [] - else [ Simple.DisableExtension Simple.ImplicitPrelude ] - -- Pass -WNoImplicitPrelude to avoid depending on base - -- when compiling a Simple Setup.hs file. - , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler - } - let ghcCmdLine = renderGhcOptions compiler platform ghcOptions - when (useVersionMacros options') $ - rewriteFileEx verbosity (i cppMacrosFile) $ - generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps) - case useLoggingHandle options of - Nothing -> runDbProgramCwd verbosity mbWorkDir program progdb ghcCmdLine - -- If build logging is enabled, redirect compiler output to - -- the log file. - Just logHandle -> do - output <- - getDbProgramOutputCwd - verbosity - mbWorkDir - program - progdb - ghcCmdLine - hPutStr logHandle output - return $ i setupProgFile + else do + debug verbosity "Setup executable not found in the cache." + src <- + compileExe + verbosity + platform + pkgId + bt + WantSetup + options' + cabalLibVersion + maybeCabalLibInstalledPkgId + True + createDirectoryIfMissingVerbose verbosity True setupCacheDir + installExecutableFile verbosity src cachedSetupProgFile + when (maybe True ((/= GHCJS) . compilerFlavor) $ useCompiler options') $ do + setupProgDb + <- prependProgramSearchPath verbosity + (useExtraPathEnv options') + (useExtraEnvOverrides options') + (useProgramDb options') + >>= configureAllKnownPrograms verbosity + Strip.stripExe + verbosity + platform + setupProgDb + cachedSetupProgFile + return cachedSetupProgFile + where + criticalSection' = maybe id criticalSection $ setupCacheLock options' + +-- | If the Setup.hs is out of date wrt the executable then recompile it. +-- Currently this is GHC/GHCJS only. It should really be generalised. +compileExe + :: Verbosity + -> Platform + -> PackageIdentifier + -> BuildType + -> WantedExternalExe exe + -> SetupScriptOptions + -> Version + -> Maybe ComponentId + -> Bool + -> IO FilePath +compileExe verbosity platform pkgId bt wantedExe opts ver mbCompId forceCompile = + case wantedExe of + WantHooks -> + compileHooksScript verbosity platform pkgId opts ver mbCompId forceCompile + WantSetup -> + compileSetupScript verbosity platform pkgId bt opts ver mbCompId forceCompile + +compileSetupScript + :: Verbosity + -> Platform + -> PackageIdentifier + -> BuildType + -> SetupScriptOptions + -> Version + -> Maybe ComponentId + -> Bool + -> IO FilePath +compileSetupScript verbosity platform pkgId bt opts ver mbCompId forceCompile = + compileSetupX "Setup" + [setupHs opts] (setupProgFile opts) + verbosity platform pkgId bt opts ver mbCompId forceCompile + +compileHooksScript + :: Verbosity + -> Platform + -> PackageIdentifier + -> SetupScriptOptions + -> Version + -> Maybe ComponentId + -> Bool + -> IO FilePath +compileHooksScript verbosity platform pkgId opts ver mbCompId forceCompile = + compileSetupX "SetupHooks" + [setupHooks opts, hooksHs opts] (hooksProgFile opts) + verbosity platform pkgId Hooks opts ver mbCompId forceCompile + +setupDir :: SetupScriptOptions -> SymbolicPath Pkg (Dir setup) +setupDir opts = useDistPref opts Cabal.Path. makeRelativePathEx "setup" + +setupVersionFile :: SetupScriptOptions -> SymbolicPath Pkg File +setupVersionFile opts = setupDir opts Cabal.Path. makeRelativePathEx ("setup" <.> "version") + +setupHs, hooksHs, setupHooks, setupProgFile, hooksProgFile :: SetupScriptOptions -> SymbolicPath Pkg File +setupHs opts = setupDir opts Cabal.Path. makeRelativePathEx ("setup" <.> "hs") +hooksHs opts = setupDir opts Cabal.Path. makeRelativePathEx ("hooks" <.> "hs") +setupHooks opts = setupDir opts Cabal.Path. makeRelativePathEx ("SetupHooks" <.> "hs") +setupProgFile opts = setupDir opts Cabal.Path. makeRelativePathEx ("setup" <.> exeExtension buildPlatform) +hooksProgFile opts = setupDir opts Cabal.Path. makeRelativePathEx ("hooks" <.> exeExtension buildPlatform) + +compileSetupX + :: String + -> [SymbolicPath Pkg File] + -> SymbolicPath Pkg File + -> Verbosity + -> Platform + -> PackageIdentifier + -> BuildType + -> SetupScriptOptions + -> Version + -> Maybe ComponentId + -> Bool + -> IO FilePath +compileSetupX + what + inPaths outPath + verbosity + platform + pkgId + bt + options' + cabalLibVersion + maybeCabalLibInstalledPkgId + forceCompile = do + setupXHsNewer <- + or <$> for inPaths (\inPath -> i inPath `moreRecentFile` i outPath) + cabalVersionNewer <- i (setupVersionFile options') `moreRecentFile` i outPath + let outOfDate = setupXHsNewer || cabalVersionNewer + when (outOfDate || forceCompile) $ do + debug verbosity $ what ++ " executable needs to be updated, compiling..." + (compiler, progdb, options'') <- configureCompiler verbosity options' + pkgDbs <- traverse (traverse (makeRelativeToDirS mbWorkDir)) (coercePackageDBStack (usePackageDB options'')) + let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion + (program, extraOpts) = + case compilerFlavor compiler of + GHCJS -> (ghcjsProgram, ["-build-runner"]) + _ -> (ghcProgram, ["-threaded"]) + cabalDep = + maybe + [] + (\ipkgid -> [(ipkgid, cabalPkgid)]) + maybeCabalLibInstalledPkgId + selectedDeps + | (useDependenciesExclusive options' && (bt /= Hooks)) + || any (isCabalPkgId . snd) (useDependencies options') + = useDependencies options' + | otherwise = + useDependencies options' ++ cabalDep + addRenaming (ipid, _) = + ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) + , defaultRenaming + ) + cppMacrosFile = setupDir options' Cabal.Path. makeRelativePathEx "setup_macros.h" + ghcOptions = + mempty + { ghcOptVerbosity = Flag $ min (verbosityLevel verbosity) Normal + , ghcOptMode = Flag GhcModeMake + , ghcOptInputFiles = toNubListR inPaths + , ghcOptOutputFile = Flag outPath + , ghcOptObjDir = Flag (setupDir options') + , ghcOptHiDir = Flag (setupDir options') + , ghcOptSourcePathClear = Flag True + , ghcOptSourcePath = case bt of + Custom -> toNubListR [sameDirectory] + Hooks -> toNubListR [sameDirectory] + _ -> mempty + , ghcOptPackageDBs = pkgDbs + , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') + , ghcOptCabal = Flag (useDependenciesExclusive options') + , ghcOptPackages = toNubListR $ map addRenaming selectedDeps + , ghcOptCppIncludes = + toNubListR + [ cppMacrosFile + | useVersionMacros options' + ] + , ghcOptExtra = extraOpts + , ghcOptExtensions = toNubListR $ + [ Simple.DisableExtension Simple.ImplicitPrelude + | not $ bt == Custom || any (isBasePkgId . snd) selectedDeps + ] + , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler + } + let ghcCmdLine = renderGhcOptions compiler platform ghcOptions + when (useVersionMacros options') $ + rewriteFileEx verbosity (i cppMacrosFile) $ + generatePackageVersionMacros (pkgVersion pkgId) (map snd selectedDeps) + case useLoggingHandle options' of + Nothing -> runDbProgramCwd verbosity mbWorkDir program progdb ghcCmdLine + Just logHandle -> do + output <- + getDbProgramOutputCwd + verbosity + mbWorkDir + program + progdb + ghcCmdLine + hPutStr logHandle output + return $ i outPath + where + mbWorkDir = useWorkingDir options' + i :: SymbolicPathX allowAbs Pkg to -> FilePath + i = interpretSymbolicPath mbWorkDir isCabalPkgId, isBasePkgId :: PackageIdentifier -> Bool isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal" diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs index 6e896f5a8e7..b1f04f0e57e 100644 --- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs +++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs @@ -242,7 +242,7 @@ problems _indepGoals index = ] ++ [ PackageInconsistency name inconsistencies | (name, inconsistencies) <- - dependencyInconsistencies indepGoals index + dependencyInconsistencies index ] ++ [ PackageStateInvalid pkg pkg' | pkg <- Foldable.toList index @@ -271,7 +271,7 @@ dependencyInconsistencies index = -- Not Graph.closure!! map (nonSetupClosure index) - (rootSets indepGoals index) + (rootSets (IndependentGoals False) index) -- NB: When we check for inconsistencies, packages from the setup -- scripts don't count as part of the closure (this way, we @@ -426,7 +426,7 @@ closed = null . Graph.broken -- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to -- find out which packages are. consistent :: SolverPlanIndex -> Bool -consistent = null . dependencyInconsistencies (IndependentGoals False) +consistent = null . dependencyInconsistencies -- | The states of packages have that depend on each other must respect -- this relation. That is for very case where package @a@ depends on diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs index 842ae94eb57..d5db171187c 100644 --- a/cabal-install/src/Distribution/Client/Targets.hs +++ b/cabal-install/src/Distribution/Client/Targets.hs @@ -619,6 +619,7 @@ data UserConstraintScope = UserConstraintScope (Maybe Stage) UserConstraintQuali instance Binary UserConstraintScope instance Structured UserConstraintScope +instance NFData UserConstraintScope data UserConstraintQualifier = -- | Scope that applies to the package when it has the specified qualifier. @@ -633,6 +634,7 @@ data UserConstraintQualifier instance Binary UserConstraintQualifier instance Structured UserConstraintQualifier +instance NFData UserConstraintQualifier fromUserQualifier :: UserQualifier -> Qualifier fromUserQualifier UserQualToplevel = QualToplevel diff --git a/cabal-install/src/Distribution/Client/Toolchain.hs b/cabal-install/src/Distribution/Client/Toolchain.hs index e6023fdd91a..f64c85a2221 100644 --- a/cabal-install/src/Distribution/Client/Toolchain.hs +++ b/cabal-install/src/Distribution/Client/Toolchain.hs @@ -16,7 +16,7 @@ where import Distribution.Client.Setup (ConfigExFlags (..)) import Distribution.Simple (Compiler, CompilerFlavor) import Distribution.Simple.Compiler (interpretPackageDBStack) -import Distribution.Simple.Configure +import Distribution.Simple.Configure hiding (mkProgramDb) import Distribution.Simple.Program (ProgArg) import Distribution.Simple.Program.Db import Distribution.Simple.Setup @@ -24,7 +24,7 @@ import Distribution.Solver.Types.Stage import Distribution.Solver.Types.Toolchain import Distribution.System (Platform) import Distribution.Utils.NubList -import Distribution.Verbosity (Verbosity) +import Distribution.Verbosity (Verbosity, defaultVerbosityHandles, mkVerbosity) mkProgramDb :: Verbosity @@ -65,7 +65,7 @@ configToolchain configFlags@ConfigFlags{..} = do return Toolchain{..} where -- FIXME - verbosity = fromFlag (configVerbosity configFlags) + verbosity = mkVerbosity defaultVerbosityHandles (fromFlag (configVerbosity configFlags)) configToolchains :: Verbosity -> ConfigFlags -> ConfigExFlags -> IO (Staged Toolchain) configToolchains verbosity ConfigFlags{..} ConfigExFlags{..} = do diff --git a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs index a778981b103..b3b2c4bd794 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-} diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index d80598797b9..aa7540b3e56 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -879,7 +879,7 @@ exResolve setEnableBackjumping enableBj $ setSolveExecutables solveExes $ setGoalOrder goalOrder $ - setSolverVerbosity verbosity $ + setSolverVerbosity (C.verbosityLevel verbosity) $ standardInstallPolicy avaiIdx targets' toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index a994170db03..1ed0710709a 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -632,7 +632,6 @@ instance ArbitraryOrd pn => ArbitraryOrd (Variable pn) instance ArbitraryOrd a => ArbitraryOrd (P.Qualified a) instance ArbitraryOrd P.PackagePath instance ArbitraryOrd P.Qualifier -instance ArbitraryOrd P.Namespace instance ArbitraryOrd OptionalStanza instance ArbitraryOrd FlagName instance ArbitraryOrd PackageName diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs index e8ac96114a1..5cccc11ee1a 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -2081,7 +2081,7 @@ dbIndepGoals78 = -- If you specify `any.A == 2`, then that should apply inside an independent goal. testIndepGoals8 :: String -> SolverTest testIndepGoals8 name = - constraints [ExVersionConstraint (ScopeAnyQualifier "A") (V.thisVersion (V.mkVersion [2]))] $ + constraints [ExVersionConstraint (ConstraintScope Nothing (ScopeAnyQualifier "A")) (V.thisVersion (V.mkVersion [2]))] $ independentGoals $ mkTest dbIndepGoals78 name ["A"] $ solverSuccess [("A", 2)] From 793eef88499b39c2b36973e98111fbce8e69606b Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 18 May 2026 16:23:37 +0800 Subject: [PATCH 52/54] feat(testsuite): add --with-build-compiler flag to test runner --- .../BuildCompilerOption/cabal.project | 1 + .../BuildCompilerOption/cabal.test.hs | 7 ++++++ .../BuildCompilerOption/hello/Main.hs | 4 ++++ .../BuildCompilerOption/hello/hello.cabal | 10 ++++++++ cabal-testsuite/src/Test/Cabal/Monad.hs | 23 +++++++++++++++++++ 5 files changed, 45 insertions(+) create mode 100644 cabal-testsuite/PackageTests/BuildCompilerOption/cabal.project create mode 100644 cabal-testsuite/PackageTests/BuildCompilerOption/cabal.test.hs create mode 100644 cabal-testsuite/PackageTests/BuildCompilerOption/hello/Main.hs create mode 100644 cabal-testsuite/PackageTests/BuildCompilerOption/hello/hello.cabal diff --git a/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.project b/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.project new file mode 100644 index 00000000000..d2c5a6cfbb8 --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.project @@ -0,0 +1 @@ +packages: hello diff --git a/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.test.hs b/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.test.hs new file mode 100644 index 00000000000..41aa448a408 --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude + +-- Test that --with-build-compiler is accepted and the build succeeds. +-- Requires --with-build-compiler to be passed to the test runner; skipped otherwise. +main = cabalTest . recordMode DoNotRecord $ do + withBuildCompiler $ \bc -> + cabal "v2-build" ["--with-build-compiler=" ++ bc, "all"] diff --git a/cabal-testsuite/PackageTests/BuildCompilerOption/hello/Main.hs b/cabal-testsuite/PackageTests/BuildCompilerOption/hello/Main.hs new file mode 100644 index 00000000000..98f25e48d5a --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerOption/hello/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello, World!" diff --git a/cabal-testsuite/PackageTests/BuildCompilerOption/hello/hello.cabal b/cabal-testsuite/PackageTests/BuildCompilerOption/hello/hello.cabal new file mode 100644 index 00000000000..c343c4c8790 --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerOption/hello/hello.cabal @@ -0,0 +1,10 @@ +cabal-version: >= 1.10 +name: hello +version: 0.1.0.0 +license: BSD3 +build-type: Simple + +executable hello-world + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/src/Test/Cabal/Monad.hs b/cabal-testsuite/src/Test/Cabal/Monad.hs index 4fa81e2e069..47920a1a9e4 100644 --- a/cabal-testsuite/src/Test/Cabal/Monad.hs +++ b/cabal-testsuite/src/Test/Cabal/Monad.hs @@ -7,6 +7,7 @@ module Test.Cabal.Monad , setupTest , cabalTest , cabalTest' + , withBuildCompiler -- * The monad , TestM @@ -127,6 +128,7 @@ import Test.Cabal.Run data CommonArgs = CommonArgs { argCabalInstallPath :: Maybe FilePath , argGhcPath :: Maybe FilePath + , argBuildCompilerPath :: Maybe FilePath , argHackageRepoToolPath :: Maybe FilePath , argHaddockPath :: Maybe FilePath , argKeepTmpFiles :: Bool @@ -154,6 +156,14 @@ commonArgParser = <> metavar "PATH" ) ) + <*> optional + ( option + str + ( help "Path to the build compiler (cross-compile build stage). If omitted, tests requiring a separate build compiler are skipped." + <> long "with-build-compiler" + <> metavar "PATH" + ) + ) <*> optional ( option str @@ -184,6 +194,7 @@ renderCommonArgs :: CommonArgs -> [String] renderCommonArgs args = maybe [] (\x -> ["--with-cabal", x]) (argCabalInstallPath args) ++ maybe [] (\x -> ["--with-ghc", x]) (argGhcPath args) + ++ maybe [] (\x -> ["--with-build-compiler", x]) (argBuildCompilerPath args) ++ maybe [] (\x -> ["--with-haddock", x]) (argHaddockPath args) ++ maybe [] (\x -> ["--with-hackage-repo-tool", x]) (argHackageRepoToolPath args) ++ ["--accept" | argAccept args] @@ -329,6 +340,15 @@ cabalTest' mode m = runTestM mode $ do skipUnless "no cabal-install" =<< isAvailableProgram cabalProgram withReaderT (\nenv -> nenv{testCabalInstallAsSetup = True}) m +-- | Run a test only when @--with-build-compiler@ was supplied, passing the +-- build-compiler path to the action. Skips the test otherwise. +withBuildCompiler :: (FilePath -> TestM ()) -> TestM () +withBuildCompiler f = do + env <- getTestEnv + case testBuildCompilerPath env of + Nothing -> skip "no build compiler (pass --with-build-compiler)" + Just p -> f p + type TestM = ReaderT TestEnv IO gitProgram :: Program @@ -444,6 +464,7 @@ runTestM mode m = , testSetupPath = dist_dir "build" "setup" "setup" , testPackageDbPath = case testArgPackageDb args of [] -> Nothing; xs -> Just xs , testSkipSetupTests = argSkipSetupTests (testCommonArgs args) + , testBuildCompilerPath = argBuildCompilerPath cargs , testHaveCabalShared = runnerWithSharedLib senv , testEnvironment = -- Use UTF-8 output on all platforms. @@ -859,6 +880,8 @@ data TestEnv = TestEnv -- use when compiling custom setups, plus the store with possible dependencies of those setup packages. , testSkipSetupTests :: Bool -- ^ Skip Setup tests? + , testBuildCompilerPath :: Maybe FilePath + -- ^ Path to the build compiler for cross-compile tests; 'Nothing' means skip such tests. , testHaveCabalShared :: Bool -- ^ Do we have shared libraries for the Cabal-under-tests? -- This is used for example to determine whether we can build From 0dd7c97b9bddf5834ea6c5f17642bcddef1d09f0 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 18 May 2026 16:51:44 +0800 Subject: [PATCH 53/54] test: add BuildCompilerSetup integration test verifying build compiler usage Adds a test package with a Custom Setup.hs that injects the build compiler's GHC version as a CPP define (SETUP_GHC_VERSION) into the executable's cppOptions. The executable prints both the setup-injected version and its own __GLASGOW_HASKELL__, allowing the test to assert the build compiler was actually used. --- .../BuildCompilerSetup/cabal.project | 1 + .../BuildCompilerSetup/cabal.test.hs | 23 +++++++++++++++++ .../BuildCompilerSetup/client/Main.hs | 10 ++++++++ .../BuildCompilerSetup/client/Setup.hs | 25 +++++++++++++++++++ .../BuildCompilerSetup/client/client.cabal | 14 +++++++++++ 5 files changed, 73 insertions(+) create mode 100644 cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.project create mode 100644 cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.test.hs create mode 100644 cabal-testsuite/PackageTests/BuildCompilerSetup/client/Main.hs create mode 100644 cabal-testsuite/PackageTests/BuildCompilerSetup/client/Setup.hs create mode 100644 cabal-testsuite/PackageTests/BuildCompilerSetup/client/client.cabal diff --git a/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.project b/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.project new file mode 100644 index 00000000000..7c64e37f6d3 --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.project @@ -0,0 +1 @@ +packages: client diff --git a/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.test.hs b/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.test.hs new file mode 100644 index 00000000000..1a6ec419128 --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.test.hs @@ -0,0 +1,23 @@ +import Test.Cabal.Prelude + +main :: IO () +main = cabalTest . recordMode DoNotRecord $ do + withBuildCompiler $ \bc -> do + cabal "v2-build" ["--with-build-compiler=" ++ bc, "all"] + -- Ask the build compiler for its numeric version (e.g. "9.10.2") + -- and convert it to the __GLASGOW_HASKELL__ integer format (e.g. 910). + vr <- runM bc ["--numeric-version"] Nothing + let bcInt = ghcNumericVersionToGHC (head (lines (resultOutput vr))) + withPlan $ do + r <- runPlanExe' "client" "check-compiler" [] + assertOutputContains ("setup-ghc: " ++ show bcInt) r + +-- Convert a GHC numeric version string "M.N.P" to the __GLASGOW_HASKELL__ +-- integer M*100 + N (e.g. "9.10.2" -> 910). +ghcNumericVersionToGHC :: String -> Int +ghcNumericVersionToGHC s = major * 100 + minor + where + (majorStr, rest) = span (/= '.') s + (minorStr, _) = span (/= '.') (drop 1 rest) + major = read majorStr + minor = read minorStr diff --git a/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Main.hs b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Main.hs new file mode 100644 index 00000000000..c529d03ecb2 --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Main.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +module Main where + +main :: IO () +main = do + -- SETUP_GHC_VERSION is injected by Setup.hs using the build compiler's + -- __GLASGOW_HASKELL__ macro, so it reflects the build-stage GHC. + putStrLn $ "setup-ghc: " ++ show (SETUP_GHC_VERSION :: Int) + -- __GLASGOW_HASKELL__ here reflects the host compiler (the one compiling Main.hs). + putStrLn $ "self-ghc: " ++ show (__GLASGOW_HASKELL__ :: Int) diff --git a/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Setup.hs b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Setup.hs new file mode 100644 index 00000000000..f4a03e2b3ca --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Setup.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +module Main where + +import Distribution.Simple +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Setup +import Distribution.PackageDescription +import Distribution.Types.BuildInfo + +main :: IO () +main = defaultMainWithHooks simpleUserHooks{confHook = myConfHook} + +myConfHook + :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo +myConfHook pkg flags = do + lbi <- confHook simpleUserHooks pkg flags + -- __GLASGOW_HASKELL__ is the version of GHC compiling this Setup.hs, + -- i.e. the build compiler in a cross-compile scenario. + let define = "-DSETUP_GHC_VERSION=" ++ show (__GLASGOW_HASKELL__ :: Int) + addDefine bi = bi{cppOptions = define : cppOptions bi} + pd = localPkgDescr lbi + exes' = map (\e -> e{buildInfo = addDefine (buildInfo e)}) (executables pd) + return lbi{localPkgDescr = pd{executables = exes'}} diff --git a/cabal-testsuite/PackageTests/BuildCompilerSetup/client/client.cabal b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/client.cabal new file mode 100644 index 00000000000..153a5b08af1 --- /dev/null +++ b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/client.cabal @@ -0,0 +1,14 @@ +cabal-version: 2.0 +name: client +version: 0.1.0.0 +build-type: Custom + +custom-setup + setup-depends: + base + , Cabal >= 2.0 + +executable check-compiler + main-is: Main.hs + build-depends: base + default-language: Haskell2010 From de8db60c45062fd92fd710ec46dfcdd4e85acada Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 19 May 2026 14:30:13 +0800 Subject: [PATCH 54/54] fix: only apply installedPkgIndex filter to Host stage, not Build --- cabal-install/src/Distribution/Client/Dependency.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index bb8b17fc71c..0af476a1534 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- - +{-# LANGUAGE LambdaCase #-} -- | -- Module : Distribution.Client.Dependency -- Copyright : (c) David Himmelstrup 2005, @@ -873,7 +873,7 @@ resolveDependencies toolchains pkgConfigDB installedPkgIndex params = ) toolchains pkgConfigDB - (fmap installedPkgIndexM installedPkgIndex) + installedPkgIndex' sourcePkgIndex preferences constraints @@ -908,6 +908,10 @@ resolveDependencies toolchains pkgConfigDB installedPkgIndex params = comp = fst (getStage toolchains Host) + installedPkgIndex' = Staged $ \case + Build -> getStage installedPkgIndex Build + Host -> installedPkgIndexM (getStage installedPkgIndex Host) + formatProgress :: Progress SummarizedMessage String a -> Progress String String a formatProgress p = foldProgress (\x xs -> Step (renderSummarizedMessage x) xs) Fail Done p