feat(cabal-install, cabal-install-solver): track stage in SolverId

Author: andreabedini

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

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(..))
@@ -34,6 +37,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
@@ -44,8 +55,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 $ CD.flatDeps (resolverPackageLibDeps pkg) ++

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
+    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"]

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
@@ -285,9 +287,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 _ =

cabal-install/src/Distribution/Client/InstallPlan.hs

@@ -557,19 +557,20 @@ 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
     -- 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)
+    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)
 

cabal-install/src/Distribution/Client/ProjectPlanning.hs

@@ -2455,11 +2455,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 =