From 4f4f0f91862a364206be3e0ea9b71c80074ef5d9 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 15 Mar 2024 12:11:33 +0000 Subject: [PATCH] Fix qualifiers in cabal freeze Qualifiers in the cabal freeze should definitely not always be "any". (it can cause inconsistencies, such as `cabal freeze --constraint=... && cabal build` being different from `cabal build --constraint=...` ) In this commit we propagate information on the scopes in which each package was solved to be able to generate a proper freeze file where each package solved is constrained in the scope it was solved in. Fixes #9799 --- .../Solver/Types/PackageConstraint.hs | 10 ++- .../Distribution/Solver/Types/PackagePath.hs | 6 +- .../src/Distribution/Client/CmdFreeze.hs | 75 ++++--------------- .../src/Distribution/Client/Dependency.hs | 12 ++- .../src/Distribution/Client/InstallPlan.hs | 26 +++++-- .../Distribution/Client/ProjectPlanning.hs | 5 +- .../Distribution/Client/SolverInstallPlan.hs | 11 ++- .../src/Distribution/Client/Targets.hs | 13 ++++ .../Distribution/Client/InstallPlan.hs | 2 +- .../Distribution/Solver/Modular/QuickCheck.hs | 1 - .../PackageTests/Freeze/T9799a/cabal.test.hs | 3 +- .../PackageTests/Freeze/T9799b/cabal.test.hs | 3 +- changelog.d/issue-9799 | 10 +++ 13 files changed, 93 insertions(+), 84 deletions(-) create mode 100644 changelog.d/issue-9799 diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index fbe56380e81..dcdff5e5f33 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -54,7 +54,10 @@ data ConstraintScope -- | The package with the specified name regardless of -- qualifier. | ScopeAnyQualifier PackageName - deriving (Eq, Show) + deriving (Eq, Ord, Show, Generic) + +instance Binary ConstraintScope +instance Structured ConstraintScope -- | Constructor for a common use case: the constraint applies to -- the package with the specified name when that package is a @@ -113,7 +116,10 @@ dispPackageProperty (PackagePropertyStanzas stanzas) = -- | A package constraint consists of a scope plus a property -- that must hold for all packages within that scope. data PackageConstraint = PackageConstraint ConstraintScope PackageProperty - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance Binary PackageConstraint +instance Structured PackageConstraint -- | Pretty-prints a package constraint. dispPackageConstraint :: PackageConstraint -> Disp.Doc diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs index 4fc4df25f97..51df43f1c9c 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.PackagePath ( PackagePath(..) , Namespace(..) @@ -68,7 +69,10 @@ 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 -- | Pretty-prints a qualifier. The result is either empty or -- ends in a period, so it can be prepended onto a package name. diff --git a/cabal-install/src/Distribution/Client/CmdFreeze.hs b/cabal-install/src/Distribution/Client/CmdFreeze.hs index 85c7eb137e2..1e855c4e950 100644 --- a/cabal-install/src/Distribution/Client/CmdFreeze.hs +++ b/cabal-install/src/Distribution/Client/CmdFreeze.hs @@ -29,14 +29,15 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning import Distribution.Client.Targets ( UserConstraint (..) - , UserConstraintScope (..) - , UserQualifier (..) + , toUserConstraintScope ) import Distribution.Solver.Types.ConstraintSource ( ConstraintSource (..) ) import Distribution.Solver.Types.PackageConstraint ( PackageProperty (..) + , PackageConstraint (..) + , scopeToPackageName ) import Distribution.Client.Setup @@ -46,11 +47,6 @@ import Distribution.Client.Setup import Distribution.Package ( PackageName , packageName - , packageVersion - ) -import Distribution.PackageDescription - ( FlagAssignment - , nullFlagAssignment ) import Distribution.Simple.Flag (Flag (..), fromFlagOrDefault) import Distribution.Simple.Utils @@ -61,12 +57,6 @@ import Distribution.Simple.Utils import Distribution.Verbosity ( normal ) -import Distribution.Version - ( VersionRange - , simplifyVersionRange - , thisVersion - , unionVersionRanges - ) import qualified Data.Map as Map @@ -177,8 +167,7 @@ projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 = mempty { projectConfigShared = mempty - { projectConfigConstraints = - concat (Map.elems (projectFreezeConstraints elaboratedPlan)) + { projectConfigConstraints = projectFreezeConstraints elaboratedPlan , projectConfigIndexState = Flag totalIndexState , projectConfigActiveRepos = Flag activeRepos } @@ -191,7 +180,7 @@ projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 = -- solver picks the same solution again in future in different environments. projectFreezeConstraints :: ElaboratedInstallPlan - -> Map PackageName [(UserConstraint, ConstraintSource)] + -> [(UserConstraint, ConstraintSource)] projectFreezeConstraints plan = -- -- TODO: [required eventually] this is currently an underapproximation @@ -207,53 +196,17 @@ projectFreezeConstraints plan = -- constraint would apply to both instances). We do however keep flag -- constraints of local packages. -- - deleteLocalPackagesVersionConstraints - (Map.unionWith (++) versionConstraints flagConstraints) - where - versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] - versionConstraints = - Map.mapWithKey - ( \p v -> - [ - ( UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v) - , ConstraintSourceFreeze - ) - ] - ) - versionRanges - - versionRanges :: Map PackageName VersionRange - versionRanges = - Map.map simplifyVersionRange $ - Map.fromListWith unionVersionRanges $ - [ (packageName pkg, thisVersion (packageVersion pkg)) - | InstallPlan.PreExisting pkg <- InstallPlan.toList plan - ] - ++ [ (packageName pkg, thisVersion (packageVersion pkg)) - | InstallPlan.Configured pkg <- InstallPlan.toList plan - ] + concat $ Map.elems $ + deleteLocalPackagesVersionConstraints $ + Map.fromListWith (++) $ + [ (scopeToPackageName cts, [(UserConstraint userct pp, ConstraintSourceFreeze)]) - flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] - flagConstraints = - Map.mapWithKey - ( \p f -> - [ - ( UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f) - , ConstraintSourceFreeze - ) - ] - ) - flagAssignments + | PackageConstraint cts pp <- InstallPlan.planPackageConstraints plan - flagAssignments :: Map PackageName FlagAssignment - flagAssignments = - Map.fromList - [ (pkgname, flags) - | InstallPlan.Configured elab <- InstallPlan.toList plan - , let flags = elabFlagAssignment elab - pkgname = packageName elab - , not (nullFlagAssignment flags) - ] + -- If this constraint scope is not a valid UserConstraint, we omit it from the freeze file. + , userct <- maybeToList (toUserConstraintScope cts) + ] + where -- As described above, remove the version constraints on local packages, -- but leave any flag constraints. diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 37e0cbdf1ee..d3f54c0fdbd 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- @@ -768,7 +770,7 @@ resolveDependencies -> Progress String String SolverInstallPlan resolveDependencies platform comp pkgConfigDB params = Step (showDepResolverParams finalparams) $ - fmap (validateSolverResult platform comp indGoals) $ + fmap (validateSolverResult platform comp indGoals pkgConstraints) $ runSolver ( SolverConfig reordGoals @@ -823,6 +825,9 @@ resolveDependencies platform comp pkgConfigDB params = then params else dontInstallNonReinstallablePackages params + pkgConstraints :: [PackageConstraint] + pkgConstraints = map (\case LabeledPackageConstraint pkgc _ -> pkgc) constraints + preferences :: PackageName -> PackagePreferences preferences = interpretPackagesPreference targets defpref prefs @@ -891,11 +896,12 @@ validateSolverResult :: Platform -> CompilerInfo -> IndependentGoals + -> [PackageConstraint] -> [ResolverPackage UnresolvedPkgLoc] -> SolverInstallPlan -validateSolverResult platform comp indepGoals pkgs = +validateSolverResult platform comp indepGoals pkgConstraints pkgs = case planPackagesProblems platform comp pkgs of - [] -> case SolverInstallPlan.new indepGoals graph of + [] -> case SolverInstallPlan.new indepGoals graph pkgConstraints of Right plan -> plan Left problems -> error (formatPlanProblems problems) problems -> error (formatPkgProblems problems) diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index 46212baaccc..8c146b401a2 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -36,6 +37,7 @@ module Distribution.Client.InstallPlan , keys , keysSet , planIndepGoals + , planPackageConstraints , depends , fromSolverInstallPlan , fromSolverInstallPlanWithProgress @@ -99,6 +101,7 @@ import Text.PrettyPrint import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.InstSolverPackage +import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId @@ -257,6 +260,10 @@ instance data GenericInstallPlan ipkg srcpkg = GenericInstallPlan { planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)) , planIndepGoals :: !IndependentGoals + , planPackageConstraints :: ![PackageConstraint] + -- ^ The package constraints from the solved plan that generated this + -- install plan. There may be more package constraints than packages in the + -- plan. } deriving (Typeable) @@ -272,13 +279,15 @@ mkInstallPlan => String -> Graph (GenericPlanPackage ipkg srcpkg) -> IndependentGoals + -> [PackageConstraint] -> GenericInstallPlan ipkg srcpkg -mkInstallPlan loc graph indepGoals = +mkInstallPlan loc graph indepGoals pkgConstranints = assert (valid loc graph) GenericInstallPlan { planGraph = graph , planIndepGoals = indepGoals + , planPackageConstraints = pkgConstranints } internalError :: WithCallStack (String -> String -> a) @@ -312,12 +321,14 @@ instance GenericInstallPlan { planGraph = graph , planIndepGoals = indepGoals - } = put graph >> put indepGoals + , planPackageConstraints = pkgConstraints + } = put graph >> put indepGoals >> put pkgConstraints get = do graph <- get indepGoals <- get - return $! mkInstallPlan "(instance Binary)" graph indepGoals + pkgConstraints <- get + return $! mkInstallPlan "(instance Binary)" graph indepGoals pkgConstraints data ShowPlanNode = ShowPlanNode { showPlanHerald :: Doc @@ -367,9 +378,10 @@ showPlanPackageTag (Installed _) = "Installed" new :: (IsUnit ipkg, IsUnit srcpkg) => IndependentGoals + -> [PackageConstraint] -> Graph (GenericPlanPackage ipkg srcpkg) -> GenericInstallPlan ipkg srcpkg -new indepGoals graph = mkInstallPlan "new" graph indepGoals +new indepGoals pkgConstraints graph = mkInstallPlan "new" graph indepGoals pkgConstraints toGraph :: GenericInstallPlan ipkg srcpkg @@ -398,12 +410,12 @@ 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) + :: (IsUnit ipkg, IsUnit srcpkg, Package ipkg, Package srcpkg) => (GenericPlanPackage ipkg srcpkg -> Bool) -> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg remove shouldRemove plan = - mkInstallPlan "remove" newGraph (planIndepGoals plan) + mkInstallPlan "remove" newGraph (planIndepGoals plan) (planPackageConstraints plan) where newGraph = Graph.fromDistinctList $ @@ -524,6 +536,7 @@ fromSolverInstallPlan f plan = "fromSolverInstallPlan" (Graph.fromDistinctList pkgs'') (SolverInstallPlan.planIndepGoals plan) + (SolverInstallPlan.planPackageConstraints plan) where (_, _, pkgs'') = foldl' @@ -570,6 +583,7 @@ fromSolverInstallPlanWithProgress f plan = do "fromSolverInstallPlanWithProgress" (Graph.fromDistinctList pkgs'') (SolverInstallPlan.planIndepGoals plan) + (SolverInstallPlan.planPackageConstraints plan) where f' (pidMap, ipiMap, pkgs) pkg = do pkgs' <- f (mapDep pidMap ipiMap) pkg diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 6344249a8a6..c75f50b43f6 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -2600,6 +2600,7 @@ instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> E instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = InstallPlan.new (IndependentGoals False) + (InstallPlan.planPackageConstraints plan) (Graph.fromDistinctList (Map.elems ready_map)) where pkgs = InstallPlan.toList plan @@ -3129,7 +3130,7 @@ pruneInstallPlanToTargets -> ElaboratedInstallPlan -> ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = - InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) + InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) (InstallPlan.planPackageConstraints elaboratedPlan) . Graph.fromDistinctList -- We have to do the pruning in two passes . pruneInstallPlanPass2 @@ -3591,7 +3592,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan = (isJust . InstallPlan.lookup installPlan) (Set.toList pkgTargets) ) - $ fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) + $ fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan) (InstallPlan.planPackageConstraints installPlan)) . checkBrokenDeps . Graph.fromDistinctList . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs index f4422080a4b..bdf35d5dab8 100644 --- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs +++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs @@ -73,6 +73,7 @@ import Distribution.Version ( Version ) +import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.ResolverPackage import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId @@ -92,6 +93,9 @@ type SolverPlanIndex = Graph SolverPlanPackage data SolverInstallPlan = SolverInstallPlan { planIndex :: !SolverPlanIndex , planIndepGoals :: !IndependentGoals + , planPackageConstraints :: ![PackageConstraint] + -- ^ The solved package constraints. There may be more package constraints + -- than packages in the index. } deriving (Typeable, Generic) @@ -145,10 +149,11 @@ showPlanPackage (Configured spkg) = new :: IndependentGoals -> SolverPlanIndex + -> [PackageConstraint] -> Either [SolverPlanProblem] SolverInstallPlan -new indepGoals index = +new indepGoals index pkgConstraints = case problems indepGoals index of - [] -> Right (SolverInstallPlan index indepGoals) + [] -> Right (SolverInstallPlan index indepGoals pkgConstraints) probs -> Left probs toList :: SolverInstallPlan -> [SolverPlanPackage] @@ -169,7 +174,7 @@ remove [SolverPlanProblem] (SolverInstallPlan) remove shouldRemove plan = - new (planIndepGoals plan) newIndex + new (planIndepGoals plan) newIndex (planPackageConstraints plan) where newIndex = Graph.fromDistinctList $ diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs index ea8cb85cbbb..ec1c66231a5 100644 --- a/cabal-install/src/Distribution/Client/Targets.hs +++ b/cabal-install/src/Distribution/Client/Targets.hs @@ -45,6 +45,7 @@ module Distribution.Client.Targets , userConstraintPackageName , readUserConstraint , userToPackageConstraint + , toUserConstraintScope ) where import Distribution.Client.Compat.Prelude @@ -647,6 +648,18 @@ fromUserConstraintScope (UserQualified q pn) = fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn +toUserQualifier :: Qualifier -> Maybe UserQualifier +toUserQualifier QualToplevel = pure $ UserQualToplevel +toUserQualifier (QualSetup name) = pure $ UserQualSetup name +toUserQualifier (QualExe name1 name2) = pure $ UserQualExe name1 name2 +toUserQualifier (QualBase _) = Nothing + +toUserConstraintScope :: ConstraintScope -> Maybe UserConstraintScope +toUserConstraintScope (ScopeQualified q pn) = UserQualified <$> toUserQualifier q <*> pure pn +toUserConstraintScope (ScopeAnySetupQualifier pn) = pure $ UserAnySetupQualifier pn +toUserConstraintScope (ScopeAnyQualifier pn) = pure $ UserAnyQualifier pn +toUserConstraintScope (ScopeTarget _) = Nothing + -- | Version of 'PackageConstraint' that the user can specify on -- the command line. data UserConstraint diff --git a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs index 39c719f2e1f..7fcb124a6b1 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -266,7 +266,7 @@ arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do ( map InstallPlan.PreExisting ipkgs ++ map InstallPlan.Configured srcpkgs ) - return $ InstallPlan.new (IndependentGoals False) index + return $ InstallPlan.new (IndependentGoals False) [] index -- | Generate a random directed acyclic graph, based on the algorithm presented -- here diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index 114db775f21..2910d22e331 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -621,7 +621,6 @@ 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 diff --git a/cabal-testsuite/PackageTests/Freeze/T9799a/cabal.test.hs b/cabal-testsuite/PackageTests/Freeze/T9799a/cabal.test.hs index 715a6e184ee..703e9322a81 100644 --- a/cabal-testsuite/PackageTests/Freeze/T9799a/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Freeze/T9799a/cabal.test.hs @@ -1,6 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ do - expectBroken 9799 $ withRepo "repo" $ do +main = cabalTest $ withRepo "repo" $ do cabal "v2-freeze" [] cwd <- fmap testCurrentDir getTestEnv -- Guarantee that freeze writes scope-qualified constraints, not 'any' diff --git a/cabal-testsuite/PackageTests/Freeze/T9799b/cabal.test.hs b/cabal-testsuite/PackageTests/Freeze/T9799b/cabal.test.hs index 5ddc212f688..e4b49ff7cea 100644 --- a/cabal-testsuite/PackageTests/Freeze/T9799b/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Freeze/T9799b/cabal.test.hs @@ -1,6 +1,5 @@ import Test.Cabal.Prelude -main = cabalTest $ do - expectBroken 9799 $ withRepo "repo" $ do +main = cabalTest $ withRepo "repo" $ do -- Show how using 'any' qualifiers always with relaxed bounds can violate that -- cabal freeze --constraint=... && cabal build diff --git a/changelog.d/issue-9799 b/changelog.d/issue-9799 new file mode 100644 index 00000000000..35696760206 --- /dev/null +++ b/changelog.d/issue-9799 @@ -0,0 +1,10 @@ +synopsis: Qualify packages in freeze file correctly +packages: cabal-install, cabal-install-solver +prs: #9811 +issues: #9799 + +description: { + +- Fixes the qualifiers in the freeze file from always using "any" to now using the proper qualifiers for each package that is included in each scope. + +}