wip: pass qualified package name into the SolverInstallPlan

Author: andreabedini

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

@@ -6,8 +6,6 @@ import Data.Maybe
 import Prelude hiding (pi)
 import Data.Either (partitionEithers)
 
-import Distribution.Package (UnitId, packageId)
-
 import qualified Distribution.Simple.PackageIndex as SI
 
 import Distribution.Solver.Modular.Configured
@@ -29,36 +27,38 @@ convCP :: SI.InstalledPackageIndex ->
           CI.PackageIndex (SourcePackage loc) ->
           CP QPN -> ResolverPackage loc
 convCP iidx sidx (CP qpi fa es ds) =
-  case convPI qpi of
-    Left  pi -> PreExisting $
+  case qpi of
+    -- Installed
+    (PI qpn (I _ (Inst pi)))  ->
+      PreExisting $
                   InstSolverPackage {
-                    instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi,
+                    instSolverQPN = qpn,
+                    instSolverPkgIPI = fromMaybe (error "convCP: lookupUnitId failed") $ SI.lookupUnitId iidx pi,
                     instSolverPkgLibDeps = fmap fst ds',
                     instSolverPkgExeDeps = fmap snd ds'
                   }
-    Right pi -> Configured $
+    -- "In repo" i.e. a source package
+    (PI qpn@(Q _path pn) (I v InRepo)) ->
+      let pi = PackageIdentifier pn v in
+      Configured $
                   SolverPackage {
-                      solverPkgSource = srcpkg,
+                      solverPkgQPN = qpn,
+                      solverPkgSource = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi,
                       solverPkgFlags = fa,
                       solverPkgStanzas = es,
                       solverPkgLibDeps = fmap fst ds',
                       solverPkgExeDeps = fmap snd ds'
                     }
-      where
-        srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi
   where
     ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -})
     ds' = fmap (partitionEithers . map convConfId) ds
 
-convPI :: PI QPN -> Either UnitId PackageId
-convPI (PI _ (I _ (Inst pi))) = Left pi
-convPI pi                     = Right (packageId (either id id (convConfId pi)))
-
 convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -}
 convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) =
     case loc of
-        Inst pi -> Left (PreExistingId sourceId pi)
-        _otherwise
+        Inst pi ->
+          Left (PreExistingId sourceId pi)
+        InRepo
           | QualExe _ pn' <- q
           -- NB: the dependencies of the executable are also
           -- qualified.  So the way to tell if this is an executable
@@ -67,6 +67,6 @@ convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) =
           -- silly and didn't allow arbitrarily nested build-tools
           -- dependencies, so a shallow check works.
           , pn == pn' -> Right (PlannedId sourceId)
-          | otherwise    -> Left  (PlannedId sourceId)
+          | otherwise -> Left  (PlannedId sourceId)
   where
     sourceId    = PackageIdentifier pn v

cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs

@@ -8,6 +8,7 @@ import Prelude ()
 
 import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) )
 import Distribution.Solver.Types.ComponentDeps ( ComponentDeps )
+import Distribution.Solver.Types.PackagePath (QPN)
 import Distribution.Solver.Types.SolverId
 import Distribution.Types.MungedPackageId
 import Distribution.Types.PackageId
@@ -17,6 +18,7 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo)
 -- | An 'InstSolverPackage' is a pre-existing installed package
 -- specified by the dependency solver.
 data InstSolverPackage = InstSolverPackage {
+      instSolverQPN :: QPN,
       instSolverPkgIPI :: InstalledPackageInfo,
       instSolverPkgLibDeps :: ComponentDeps [SolverId],
       instSolverPkgExeDeps :: ComponentDeps [SolverId]

cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveGeneric #-}
 module Distribution.Solver.Types.PackagePath
     ( PackagePath(..)
     , Namespace(..)
@@ -18,7 +20,10 @@ import qualified Text.PrettyPrint as Disp
 -- | A package path consists of a namespace and a package path inside that
 -- namespace.
 data PackagePath = PackagePath Namespace Qualifier
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show, Generic)
+
+instance Binary PackagePath
+instance Structured PackagePath
 
 -- | Top-level namespace
 --
@@ -30,7 +35,10 @@ data Namespace =
 
     -- | A namespace for a specific build target
   | Independent PackageName
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show, Generic)
+
+instance Binary Namespace
+instance Structured Namespace
 
 -- | Pretty-prints a namespace. The result is either empty or
 -- ends in a period, so it can be prepended onto a qualifier.
@@ -68,7 +76,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.
@@ -87,11 +98,14 @@ dispQualifier (QualBase pn)  = pretty pn <<>> Disp.text "."
 
 -- | A qualified entity. Pairs a package path with the entity.
 data Qualified a = Q PackagePath a
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show, Generic)
 
 -- | Qualified package name.
 type QPN = Qualified PackageName
 
+instance Binary (Qualified PackageName)
+instance Structured (Qualified PackageName)
+
 -- | Pretty-prints a qualified package name.
 dispQPN :: QPN -> Disp.Doc
 dispQPN (Q (PackagePath ns qual) pn) =

cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs

@@ -10,6 +10,7 @@ import Distribution.Package ( Package(..) )
 import Distribution.PackageDescription ( FlagAssignment )
 import Distribution.Solver.Types.ComponentDeps ( ComponentDeps )
 import Distribution.Solver.Types.OptionalStanza
+import Distribution.Solver.Types.PackagePath (QPN)
 import Distribution.Solver.Types.SolverId
 import Distribution.Solver.Types.SourcePackage
 
@@ -21,6 +22,7 @@ import Distribution.Solver.Types.SourcePackage
 -- but for symmetry we have the parameter.  (Maybe it can be removed.)
 --
 data SolverPackage loc = SolverPackage {
+        solverPkgQPN     :: QPN,
         solverPkgSource  :: SourcePackage loc,
         solverPkgFlags   :: FlagAssignment,
         solverPkgStanzas :: OptionalStanzaSet,

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

@@ -1023,7 +1023,7 @@ configuredPackageProblems
 configuredPackageProblems
   platform
   cinfo
-  (SolverPackage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') =
+  (SolverPackage _qpn pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') =
     [ DuplicateFlag flag
     | flag <- PD.findDuplicateFlagAssignments specifiedFlags
     ]

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

@@ -1685,7 +1685,7 @@ elaborateInstallPlan
         :: (SolverId -> [ElaboratedPlanPackage])
         -> SolverPackage UnresolvedPkgLoc
         -> LogProgress [ElaboratedConfiguredPackage]
-      elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) =
+      elaborateSolverToComponents mapDep spkg@(SolverPackage qpn _ _ _ deps0 exe_deps0) =
         case mkComponentsGraph (elabEnabledSpec elab0) pd of
           Right g -> do
             let src_comps = componentsGraphToList g
@@ -2075,6 +2075,7 @@ elaborateInstallPlan
       elaborateSolverToPackage
         pkgWhyNotPerComponent
         pkg@( SolverPackage
+                qpn
                 (SourcePackage pkgid _gpd _srcloc _descOverride)
                 _flags
                 _stanzas
@@ -2178,6 +2179,7 @@ elaborateInstallPlan
         -> (ElaboratedConfiguredPackage, LogProgress ())
       elaborateSolverToCommon
         pkg@( SolverPackage
+                qpn
                 (SourcePackage pkgid gdesc srcloc descOverride)
                 flags
                 stanzas