feat: all of it, cabal-install-solver part

Author: andreabedini

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

@@ -47,24 +47,25 @@ import Distribution.Solver.Types.PkgConfigDb
          ( PkgConfigDb )
 import Distribution.Solver.Types.Progress
 import Distribution.Solver.Types.Variable
-import Distribution.System
-         ( Platform(..) )
+
 import Distribution.Simple.Setup
          ( BooleanFlag(..) )
 import Distribution.Simple.Utils
          ( ordNubBy )
 import Distribution.Verbosity
+import Distribution.Solver.Types.Toolchain
 
 
 -- | Ties the two worlds together: classic cabal-install vs. the modular
 -- solver. Performs the necessary translations before and after.
 modularResolver :: SolverConfig -> DependencyResolver loc
-modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =
-  uncurry postprocess <$> -- convert install plan
-  solve' sc cinfo idx pkgConfigDB pprefs gcs pns
-    where
+modularResolver sc toolchains pkgConfigDbs iidx sidx pprefs pcs pns = do
+    uncurry postprocess <$> solve' sc cinfo pkgConfigDbs idx pprefs gcs pns
+  where
+      cinfo = fst <$> toolchains
+
       -- Indices have to be converted into solver-specific uniform index.
-      idx    = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx
+      idx    = convPIs toolchains gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx
       -- Constraints have to be converted into a finite map indexed by PN.
       gcs    = M.fromListWith (++) (map pair pcs)
         where
@@ -114,21 +115,21 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns
 -- complete, i.e., it shows the whole chain of dependencies from the user
 -- targets to the conflicting packages.
 solve' :: SolverConfig
-       -> CompilerInfo
+       -> Staged CompilerInfo
+       -> Staged (Maybe PkgConfigDb)
        -> Index
-       -> Maybe PkgConfigDb
        -> (PN -> PackagePreferences)
        -> Map PN [LabeledPackageConstraint]
        -> Set PN
        -> Progress String String (Assignment, RevDepMap)
-solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
+solve' sc cinfo pkgConfigDb idx pprefs gcs pns =
     toProgress $ retry (runSolver printFullLog sc) createErrorMsg
   where
     runSolver :: Bool -> SolverConfig
               -> RetryLog String SolverFailure (Assignment, RevDepMap)
     runSolver keepLog sc' =
         displayLogMessages keepLog $
-        solve sc' cinfo idx pkgConfigDB pprefs gcs pns
+        solve sc' cinfo pkgConfigDb idx pprefs gcs pns
 
     createErrorMsg :: SolverFailure
                    -> RetryLog String String (Assignment, RevDepMap)

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
@@ -21,41 +19,48 @@ import           Distribution.Solver.Types.SolverId
 import           Distribution.Solver.Types.SolverPackage
 import           Distribution.Solver.Types.InstSolverPackage
 import           Distribution.Solver.Types.SourcePackage
+import           Distribution.Solver.Types.Stage (Staged (..))
 
 -- | Converts from the solver specific result @CP QPN@ into
 -- a 'ResolverPackage', which can then be converted into
 -- the install plan.
-convCP :: SI.InstalledPackageIndex ->
+convCP :: Staged 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 s _ (Inst pi)))  ->
+      PreExisting $
                   InstSolverPackage {
-                    instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi,
+                    instSolverPkgIPI = ipkg,
+                    instSolverStage = s,
+                    instSolverQPN = qpn,
                     instSolverPkgLibDeps = fmap fst ds',
                     instSolverPkgExeDeps = fmap snd ds'
                   }
-    Right pi -> Configured $
+      where
+        ipkg = fromMaybe (error "convCP: lookupUnitId failed") $
+          SI.lookupUnitId (getStage iidx s) pi
+    -- "In repo" i.e. a source package
+    (PI qpn@(Q _path pn) (I s v InRepo)) ->
+      let pi = PackageIdentifier pn v in
+      Configured $
                   SolverPackage {
-                      solverPkgSource = srcpkg,
+                      solverPkgStage = s,
+                      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)) =
+convConfId (PI (Q (PackagePath q) pn) (I _ v loc)) =
     case loc of
         Inst pi -> Left (PreExistingId sourceId pi)
         _otherwise

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

@@ -268,7 +268,7 @@ exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx
     -- Skipping it is an optimization. If false, it returns a new conflict set
     -- to be merged with the previous one.
     couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet
-    couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts =
+    couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I _ v _) _) conflicts =
       let (PInfo deps _ _ _) = idx M.! pn M.! i
           qdeps = qualifyDeps currentQPN deps
 

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

@@ -34,6 +34,8 @@ import           Distribution.Solver.Types.PackageConstraint
 import qualified Distribution.Solver.Types.PackageIndex as CI
 import           Distribution.Solver.Types.Settings
 import           Distribution.Solver.Types.SourcePackage
+import           Distribution.Solver.Types.Stage (Stage(..), Staged(..))
+import qualified Distribution.Solver.Types.Stage as Stage
 
 import Distribution.Solver.Modular.Dependency as D
 import Distribution.Solver.Modular.Flag as F
@@ -53,21 +55,27 @@ import Distribution.Solver.Modular.Version
 -- resolving these situations. However, the right thing to do is to
 -- fix the problem there, so for now, shadowing is only activated if
 -- explicitly requested.
-convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
-        -> ShadowPkgs -> StrongFlags -> SolveExecutables
-        -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc)
-        -> Index
-convPIs os arch comp constraints sip strfl solveExes iidx sidx =
+convPIs
+  :: Staged (CompilerInfo, Platform)
+  -> Map PN [LabeledPackageConstraint]
+  -> ShadowPkgs
+  -> StrongFlags
+  -> SolveExecutables
+  -> Staged SI.InstalledPackageIndex
+  -> CI.PackageIndex (SourcePackage loc)
+  -> Index
+convPIs toolchains' constraints sip strfl solveExes iidx sidx =
   mkIndex $
-  convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx
+  convIPI' sip iidx ++ convSPI' toolchains' constraints strfl solveExes sidx
 
 -- | Convert a Cabal installed package index to the simpler,
 -- more uniform index format of the solver.
-convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)]
-convIPI' (ShadowPkgs sip) idx =
+convIPI' :: ShadowPkgs -> Staged SI.InstalledPackageIndex -> [(PN, I, PInfo)]
+convIPI' (ShadowPkgs sip) =
+  Stage.foldMapWithKey $ \stage idx -> 
     -- apply shadowing whenever there are multiple installed packages with
     -- the same version
-    [ maybeShadow (convIP idx pkg)
+    [ maybeShadow (convIP stage idx pkg)
     -- IMPORTANT to get internal libraries. See
     -- Note [Index conversion with internal libraries]
     | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx
@@ -80,16 +88,16 @@ convIPI' (ShadowPkgs sip) idx =
     shadow x                                     = x
 
 -- | Extract/recover the package ID from an installed package info, and convert it to a solver's I.
-convId :: IPI.InstalledPackageInfo -> (PN, I)
-convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi)
+convId :: Stage -> IPI.InstalledPackageInfo -> (PN, I)
+convId stage ipi = (pn, I stage ver $ Inst $ IPI.installedUnitId ipi)
   where MungedPackageId mpn ver = mungedId ipi
         -- HACK. See Note [Index conversion with internal libraries]
         pn = encodeCompatPackageName mpn
 
 -- | Convert a single installed package into the solver-specific format.
-convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo)
-convIP idx ipi =
-  case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of
+convIP :: Stage -> SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo)
+convIP stage idx ipi =
+  case traverse (convIPId stage (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of
         Left u    -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u)))
         Right fds -> (pn, i, PInfo fds components M.empty Nothing)
  where
@@ -101,7 +109,7 @@ convIP idx ipi =
                     , compIsBuildable = IsBuildable True
                     }
 
-  (pn, i) = convId ipi
+  (pn, i) = convId stage ipi
 
   -- 'sourceLibName' is unreliable, but for now we only really use this for
   -- primary libs anyways
@@ -141,29 +149,48 @@ convIP idx ipi =
 -- May return Nothing if the package can't be found in the index. That
 -- indicates that the original package having this dependency is broken
 -- and should be ignored.
-convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN)
-convIPId dr comp idx ipid =
+convIPId :: Stage -> DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN)
+convIPId stage dr comp idx ipid =
   case SI.lookupUnitId idx ipid of
     Nothing  -> Left ipid
-    Just ipi -> let (pn, i) = convId ipi
-                    name = ExposedLib LMainLibName  -- TODO: Handle sub-libraries.
+    Just ipi -> let (pn, i) = convId stage ipi
+                    name = ExposedLib LMainLibName -- TODO: Handle sub-libraries.
                 in  Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp)
                 -- NB: something we pick up from the
                 -- InstalledPackageIndex is NEVER an executable
 
 -- | Convert a cabal-install source package index to the simpler,
 -- more uniform index format of the solver.
-convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
-         -> StrongFlags -> SolveExecutables
-         -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)]
-convSPI' os arch cinfo constraints strfl solveExes =
-    L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages
+-- NOTE: The package description of source package can depent on the platform
+-- and compiler version. Here we decide to convert a single source package
+-- into multiple index entries, one for each stage, where the conditionals are
+-- resolved. This choice might incour in high memory consumption and it might
+-- be worth looking for a different approach.
+convSPI'
+  :: Staged (CompilerInfo, Platform)
+  -> Map PN [LabeledPackageConstraint]
+  -> StrongFlags
+  -> SolveExecutables
+  -> CI.PackageIndex (SourcePackage loc)
+  -> [(PN, I, PInfo)]
+convSPI' toolchains constraints strfl solveExes sidx =
+  Stage.foldMapWithKey (\stage (cinfo, Platform arch os) ->
+    L.map (convSP stage os arch cinfo constraints strfl solveExes) (CI.allPackages sidx)
+  ) toolchains
 
 -- | Convert a single source package into the solver-specific format.
-convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
-       -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo)
-convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
-  let i = I pv InRepo
+convSP
+  :: Stage
+  -> OS
+  -> Arch
+  -> CompilerInfo
+  -> Map PN [LabeledPackageConstraint]
+  -> StrongFlags
+  -> SolveExecutables
+  -> SourcePackage loc
+  -> (PN, I, PInfo)
+convSP stage os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
+  let i = I stage pv InRepo
       pkgConstraints = fromMaybe [] $ M.lookup pn constraints
   in  (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd)
 

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

@@ -23,6 +23,7 @@ import Distribution.Pretty (prettyShow)
 
 import Distribution.Solver.Modular.Version
 import Distribution.Solver.Types.PackagePath
+import Distribution.Solver.Types.Stage (Stage, showStage)
 
 -- | A package name.
 type PN = PackageName
@@ -49,13 +50,13 @@ data Loc = Inst PId | InRepo
   deriving (Eq, Ord, Show)
 
 -- | Instance. A version number and a location.
-data I = I Ver Loc
+data I = I Stage Ver Loc
   deriving (Eq, Ord, Show)
 
 -- | String representation of an instance.
 showI :: I -> String
-showI (I v InRepo)   = showVer v
-showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid
+showI (I s v InRepo)     = showVer v ++ " (" ++ showStage s ++ ")"
+showI (I s v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid ++ " (" ++ showStage s ++ ")"
   where
     extractPackageAbiHash xs =
       case first reverse $ break (=='-') $ reverse (prettyShow xs) of
@@ -71,5 +72,5 @@ showPI :: PI QPN -> String
 showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i
 
 instI :: I -> Bool
-instI (I _ (Inst _)) = True
+instI (I _ _ (Inst _)) = True
 instI _              = False

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

@@ -72,7 +72,7 @@ addWeight :: (PN -> [Ver] -> POption -> Weight) -> EndoTreeTrav d c
 addWeight f = addWeights [f]
 
 version :: POption -> Ver
-version (POption (I v _) _) = v
+version (POption (I _ v _) _) = v
 
 -- | Prefer to link packages whenever possible.
 preferLinked :: EndoTreeTrav d c
@@ -139,7 +139,7 @@ preferPackagePreferences pcs =
 
     -- Prefer installed packages over non-installed packages.
     installed :: POption -> Weight
-    installed (POption (I _ (Inst _)) _) = 0
+    installed (POption (I _ _ (Inst _)) _) = 0
     installed _                          = 1
 
 -- | Traversal that tries to establish package stanza enable\/disable
@@ -184,7 +184,7 @@ processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint s
     else r
   where
     go :: I -> PackageProperty -> Tree d c
-    go (I v _) (PackagePropertyVersion vr)
+    go (I _ v _) (PackagePropertyVersion vr)
         | checkVR vr v  = r
         | otherwise     = Fail c (GlobalConstraintVersion vr src)
     go _       PackagePropertyInstalled
@@ -338,10 +338,10 @@ avoidReinstalls p = go
       | otherwise = PChoiceF qpn rdm gr cs
       where
         disableReinstalls =
-          let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ]
+          let installed = [ v | (_, POption (I _ v (Inst _)) _, _) <- W.toList cs ]
           in  W.mapWithKey (notReinstall installed) cs
 
-        notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs =
+        notReinstall vs (POption (I _ v InRepo) _) _ | v `elem` vs =
           Fail (varToConflictSet (P qpn)) CannotReinstall
         notReinstall _ _ x =
           x

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

@@ -44,11 +44,12 @@ import Distribution.Solver.Modular.Tree
 import qualified Distribution.Solver.Modular.PSQ as PSQ
 
 import Distribution.Simple.Setup (BooleanFlag(..))
+import Distribution.Solver.Types.Stage (Staged)
 
 #ifdef DEBUG_TRACETREE
 import qualified Distribution.Solver.Modular.ConflictSet as CS
 import qualified Distribution.Solver.Modular.WeightedPSQ as W
-import qualified Distribution.Deprecated.Text as T
+import           Distribution.Solver.Modular.Version (showVer)
 
 import Debug.Trace.Tree (gtraceJson)
 import Debug.Trace.Tree.Simple
@@ -88,14 +89,14 @@ newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool
 -- before exploration.
 --
 solve :: SolverConfig                         -- ^ solver parameters
-      -> CompilerInfo
+      -> Staged CompilerInfo
+      -> Staged (Maybe PkgConfigDb)
       -> Index                                -- ^ all available packages as an index
-      -> Maybe PkgConfigDb                    -- ^ available pkg-config pkgs
       -> (PN -> PackagePreferences)           -- ^ preferences
       -> M.Map PN [LabeledPackageConstraint]  -- ^ global constraints
       -> S.Set PN                             -- ^ global goals
       -> RetryLog Message SolverFailure (Assignment, RevDepMap)
-solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
+solve sc cinfo pkgConfigDB idx userPrefs userConstraints userGoals =
   explorePhase      .
   traceTree "cycles.json" id .
   detectCycles      .
@@ -136,7 +137,7 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
                        P.enforceManualFlags userConstraints
     validationCata   = P.enforceSingleInstanceRestriction .
                        validateLinking idx .
-                       validateTree cinfo idx pkgConfigDB
+                       validateTree cinfo pkgConfigDB idx
     prunePhase       = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) .
                        (case onlyConstrained sc of
                           OnlyConstrainedAll ->
@@ -203,7 +204,7 @@ instance GSimpleTree (Tree d c) where
 
       -- Show package choice
       goP :: QPN -> POption -> Tree d c -> (String, SimpleTree)
-      goP _        (POption (I ver _loc) Nothing)  subtree = (T.display ver, go subtree)
+      goP _        (POption (I _stage ver _loc) Nothing)  subtree = (showVer ver, go subtree)
       goP (Q _ pn) (POption _           (Just pp)) subtree = (showQPN (Q pp pn), go subtree)
 
       -- Show flag or stanza choice