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

@@ -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.

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)

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

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

@@ -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 $