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 haskell#9799

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

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.

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)]

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)

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

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)

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 $

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

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'

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