SolverId changes

add solverId function

Author: andreabedini

cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs

@@ -60,9 +60,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 _ q) pn) (I _ v loc)) =
+convConfId (PI (Q (PackagePath _ 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
@@ -71,7 +71,7 @@ convConfId (PI (Q (PackagePath _ q) pn) (I _ 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
     , dumpResolverPackage
@@ -13,6 +15,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(..))
@@ -36,6 +39,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
@@ -46,8 +57,7 @@ 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/InstallPlan.hs

@@ -557,19 +557,19 @@ fromSolverInstallPlanWithProgress f plan = do
       let (pidMap', ipiMap') =
             case nodeKey pkg of
               -- FIXME: stage is ignored
-              PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)
-              PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap)
+              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

@@ -95,7 +95,7 @@ module Distribution.Client.ProjectPlanning
   , binDirectories
   , storePackageInstallDirs
   , storePackageInstallDirs'
-  
+
     -- * Re-exports for backward compatibility
   , programDbSignature
 
@@ -2380,11 +2380,12 @@ elaborateInstallPlan
 
       pkgsToBuildInplaceOnly :: Set PackageId
       pkgsToBuildInplaceOnly =
-        Set.fromList $
-          map packageId $
-            SolverInstallPlan.reverseDependencyClosure
-              solverPlan
-              (map PlannedId (Set.toList pkgsLocalToProject))
+        Set.fromList [
+          packageId pkg
+        | stage <- Stage.stages
+        , let solverIds = [PlannedId stage pkgId | pkgId <- Set.toList pkgsLocalToProject]
+        , pkg <- SolverInstallPlan.reverseDependencyClosure solverPlan solverIds
+        ]
 
       isLocalToProject :: Package pkg => pkg -> Bool
       isLocalToProject pkg =