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..405be7b7ee6 100644 --- a/cabal-install/src/Distribution/Client/CmdFreeze.hs +++ b/cabal-install/src/Distribution/Client/CmdFreeze.hs @@ -31,12 +31,15 @@ import Distribution.Client.Targets ( UserConstraint (..) , UserConstraintScope (..) , UserQualifier (..) + , toUserConstraintScope ) import Distribution.Solver.Types.ConstraintSource ( ConstraintSource (..) ) import Distribution.Solver.Types.PackageConstraint ( PackageProperty (..) + , ConstraintScope (..) + , scopeToPackageName ) import Distribution.Client.Setup @@ -212,25 +215,35 @@ projectFreezeConstraints plan = where versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] versionConstraints = + Map.mapKeys fst $ Map.mapWithKey - ( \p v -> - [ - ( UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v) - , ConstraintSourceFreeze - ) - ] + ( \(_,cs) v -> + case toUserConstraintScope cs of + Just ucs -> + [ + ( UserConstraint ucs (PackagePropertyVersion v) + , ConstraintSourceFreeze + ) + ] + Nothing -> + -- This constraint scope is not a valid user constraint, so we omit it. + [] ) versionRanges - versionRanges :: Map PackageName VersionRange + versionRanges :: Map (PackageName, ConstraintScope) VersionRange versionRanges = Map.map simplifyVersionRange $ Map.fromListWith unionVersionRanges $ - [ (packageName pkg, thisVersion (packageVersion pkg)) + [ ((packageName pkg, constraint), thisVersion (packageVersion pkg)) | InstallPlan.PreExisting pkg <- InstallPlan.toList plan + , constraint <- InstallPlan.planPackageConstraints plan + , scopeToPackageName constraint == packageName pkg ] - ++ [ (packageName pkg, thisVersion (packageVersion pkg)) + ++ [ ((packageName pkg, constraint), thisVersion (packageVersion pkg)) | InstallPlan.Configured pkg <- InstallPlan.toList plan + , constraint <- InstallPlan.planPackageConstraints plan + , scopeToPackageName constraint == packageName pkg ] flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 37e0cbdf1ee..42a09a0976c 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- @@ -768,7 +769,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 +824,9 @@ resolveDependencies platform comp pkgConfigDB params = then params else dontInstallNonReinstallablePackages params + pkgConstraints :: [ConstraintScope] + pkgConstraints = map (\case LabeledPackageConstraint (PackageConstraint pkgc _) _ -> pkgc) constraints + preferences :: PackageName -> PackagePreferences preferences = interpretPackagesPreference targets defpref prefs @@ -891,11 +895,12 @@ validateSolverResult :: Platform -> CompilerInfo -> IndependentGoals + -> [ConstraintScope] -> [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..7f5c8e76425 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} @@ -36,6 +37,7 @@ module Distribution.Client.InstallPlan , keys , keysSet , planIndepGoals + , planPackageConstraints , depends , fromSolverInstallPlan , fromSolverInstallPlanWithProgress @@ -98,6 +100,7 @@ import Distribution.Solver.Types.SolverPackage import Text.PrettyPrint import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.InstSolverPackage 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 + -- | The package constraints from the solved plan that generated this + -- install plan. There may be more package constraints than packages in the + -- plan. + , planPackageConstraints :: ![ConstraintScope] } deriving (Typeable) @@ -272,13 +279,15 @@ mkInstallPlan => String -> Graph (GenericPlanPackage ipkg srcpkg) -> IndependentGoals + -> [ConstraintScope] -> 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 + -> [ConstraintScope] -> 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,16 +410,16 @@ 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 $ - filter (not . shouldRemove) (toList plan) + newGraph = Graph.fromDistinctList $ + filter (not . shouldRemove) (toList plan) + -- | Change a number of packages in the 'Configured' state to the 'Installed' -- state. @@ -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..12dd184692d 100644 --- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs +++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs @@ -77,6 +77,7 @@ import Distribution.Solver.Types.ResolverPackage import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.PackageConstraint import Data.Array ((!)) import qualified Data.Foldable as Foldable @@ -92,6 +93,9 @@ type SolverPlanIndex = Graph SolverPlanPackage data SolverInstallPlan = SolverInstallPlan { planIndex :: !SolverPlanIndex , planIndepGoals :: !IndependentGoals + -- | The solved package constraints. There may be more package constraints + -- than packages in the index. + , planPackageConstraints :: ![ConstraintScope] } deriving (Typeable, Generic) @@ -145,10 +149,11 @@ showPlanPackage (Configured spkg) = new :: IndependentGoals -> SolverPlanIndex + -> [ConstraintScope] -> 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-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