feat(cabal-install-solver): all of it, second part

Author: andreabedini

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

@@ -39,6 +39,8 @@ import Distribution.Solver.Modular.IndexConversion
          ( convPIs )
 import Distribution.Solver.Modular.Log
          ( SolverFailure(..), displayLogMessages )
+import Distribution.Solver.Modular.Message
+         ( renderSummarizedMessage )
 import Distribution.Solver.Modular.Package
          ( PN )
 import Distribution.Solver.Modular.RetryLog
@@ -65,25 +67,26 @@ import Distribution.Solver.Types.Progress
     ( Progress(..), foldProgress )
 import Distribution.Solver.Types.SummarizedMessage
     ( SummarizedMessage(StringMsg) )
-import Distribution.Solver.Types.Variable ( Variable(..) )
-import Distribution.System
-         ( Platform(..) )
+import Distribution.Solver.Types.Variable
+    ( Variable(..) )
+import Distribution.Solver.Types.Toolchain
+
 import Distribution.Simple.Setup
          ( BooleanFlag(..) )
 import Distribution.Simple.Utils
     ( ordNubBy )
 import Distribution.Verbosity ( normal, verbose )
-import Distribution.Solver.Modular.Message ( renderSummarizedMessage )
 
 -- | 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
@@ -133,21 +136,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 SummarizedMessage 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 SummarizedMessage 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 SummarizedMessage String (Assignment, RevDepMap)

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NamedFieldPuns #-}
 module Distribution.Solver.Modular.Builder (
     buildTree
   , splits -- for testing
@@ -35,6 +36,7 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W
 
 import Distribution.Solver.Types.ComponentDeps
 import Distribution.Solver.Types.PackagePath
+import qualified Distribution.Solver.Types.Stage as Stage
 
 -- | All state needed to build and link the search tree. It has a type variable
 -- because the linking phase doesn't need to know about the state used to build
@@ -138,40 +140,42 @@ addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals })
 
 -- If we have already picked a goal, then the choice depends on the kind
 -- of goal.
---
--- For a package, we look up the instances available in the global info,
--- and then handle each instance in turn.
-addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) =
-  case M.lookup pn idx of
-    Nothing  -> FailF
-                (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr)
-                UnknownPackage
-    Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) ->
-                                                       ([], POption i Nothing, bs { next = Instance qpn info }))
-                                                     (M.toList pis)))
-      -- TODO: data structure conversion is rather ugly here
-
--- For a flag, we create only two subtrees, and we create them in the order
--- that is indicated by the flag default.
-addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) =
-  FChoiceF qfn rdm gr weak m b (W.fromList
-    [([if b then 0 else 1], True,  (extendOpen qpn t bs) { next = Goals }),
-     ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })])
-  where
-    trivial = L.null t && L.null f
-    weak = WeakOrTrivial $ unWeakOrTrivial w || trivial
-
--- For a stanza, we also create only two subtrees. The order is initially
--- False, True. This can be changed later by constraints (force enabling
--- the stanza by replacing the False branch with failure) or preferences
--- (try enabling the stanza if possible by moving the True branch first).
-
-addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) =
-  SChoiceF qsn rdm gr trivial (W.fromList
-    [([0], False,                                                                  bs  { next = Goals }),
-     ([1], True,  (extendOpen qpn t bs) { next = Goals })])
-  where
-    trivial = WeakOrTrivial (L.null t)
+addChildren bs@(BS { rdeps, index, next = OneGoal goal }) = 
+  case goal of 
+    PkgGoal qpn@(Q (PackagePath s _) pn) gr ->
+      -- For a package goal, we look up the instances available in the global
+      -- info, and then handle each instance in turn.
+      case M.lookup pn index of
+        Nothing  -> FailF
+                    (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr)
+                    UnknownPackage
+        Just pis -> PChoiceF qpn rdeps gr $ W.fromList
+                      [ ([], POption i Nothing, bs { next = Instance qpn info })
+                      | (i@(I s' _ver _loc), info) <- M.toList pis
+                      -- Only instances belonging to the same stage are allowed.
+                      , s == s'
+                      ]
+    -- For a flag, we create only two subtrees, and we create them in the order
+    -- that is indicated by the flag default.
+    FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr ->
+        FChoiceF qfn rdeps gr weak m b $ W.fromList
+          [ ([if b then 0 else 1], True,  (extendOpen qpn t bs) { next = Goals })
+          , ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })
+          ]
+        where
+          trivial = L.null t && L.null f
+          weak = WeakOrTrivial $ unWeakOrTrivial w || trivial
+    -- For a stanza, we also create only two subtrees. The order is initially
+    -- False, True. This can be changed later by constraints (force enabling
+    -- the stanza by replacing the False branch with failure) or preferences
+    -- (try enabling the stanza if possible by moving the True branch first).
+    StanzaGoal qsn@(SN qpn _) t gr ->
+      SChoiceF qsn rdeps gr trivial $ W.fromList
+        [ ([0], False, bs { next = Goals })
+        , ([1], True,  (extendOpen qpn t bs) { next = Goals })
+        ]
+      where
+        trivial = WeakOrTrivial (L.null t)
 
 -- For a particular instance, we change the state: we update the scope,
 -- and furthermore we update the set of goals.
@@ -259,7 +263,7 @@ buildTree idx igs =
   where
     topLevelGoal qpn = PkgGoal qpn UserGoal
 
-    qpns = L.map (Q (PackagePath QualToplevel)) igs
+    qpns = L.map (Q (PackagePath Stage.Host QualToplevel)) igs
 
 {-------------------------------------------------------------------------------
   Goals

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,45 @@ 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,
+                    instSolverStage = s,
+                    instSolverQPN = qpn,
+                    instSolverPkgIPI =  fromMaybe (error "convCP: lookupUnitId failed") $ SI.lookupUnitId (getStage iidx s) 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 s v (InRepo _pn))) ->
+      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 _stage q) pn) (I _stage' v loc)) =
     case loc of
         Inst pi -> Left (PreExistingId sourceId pi)
         _otherwise

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

@@ -62,6 +62,7 @@ import Distribution.Solver.Types.PackagePath
 import Distribution.Types.LibraryName
 import Distribution.Types.PkgconfigVersionRange
 import Distribution.Types.UnqualComponentName
+import Distribution.Solver.Types.Stage
 
 {-------------------------------------------------------------------------------
   Constrained instances
@@ -97,6 +98,7 @@ data FlaggedDep qpn
     Stanza (SN qpn) (TrueFlaggedDeps qpn)
   | -- | Dependencies which are always enabled, for the component 'comp'.
     Simple (LDep qpn) Component
+  deriving Show
 
 -- | Conservatively flatten out flagged dependencies
 --
@@ -119,6 +121,7 @@ type FalseFlaggedDeps qpn = FlaggedDeps qpn
 -- depending; having a 'Functor' instance makes bugs where we don't distinguish
 -- these two far too likely. (By rights 'LDep' ought to have two type variables.)
 data LDep qpn = LDep (DependencyReason qpn) (Dep qpn)
+  deriving Show
 
 -- | A dependency (constraint) associates a package name with a constrained
 -- instance. It can also represent other types of dependencies, such as
@@ -132,7 +135,7 @@ data Dep qpn
     Lang Language
   | -- | dependency on a pkg-config package
     Pkg PkgconfigName PkgconfigVersionRange
-  deriving (Functor)
+  deriving (Functor, Show)
 
 -- | An exposed component within a package. This type is used to represent
 -- build-depends and build-tool-depends dependencies.
@@ -166,7 +169,7 @@ showDependencyReason (DependencyReason qpn flags stanzas) =
 -- NOTE: It's the _dependencies_ of a package that may or may not be independent
 -- from the package itself. Package flag choices must of course be consistent.
 qualifyDeps :: QPN -> FlaggedDeps PN -> FlaggedDeps QPN
-qualifyDeps (Q pp@(PackagePath q) pn) = go
+qualifyDeps (Q pp@(PackagePath s q) pn) = go
   where
     go :: FlaggedDeps PN -> FlaggedDeps QPN
     go = map go1
@@ -191,24 +194,17 @@ qualifyDeps (Q pp@(PackagePath q) pn) = go
     goD (Ext ext) _ = Ext ext
     goD (Lang lang) _ = Lang lang
     goD (Pkg pkn vr) _ = Pkg pkn vr
-    goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ =
-      Dep (Q (PackagePath (QualExe pn qpn)) <$> dep) ci
-    goD (Dep dep@(PkgComponent _qpn (ExposedLib _)) ci) comp
-      | comp == ComponentSetup = Dep (Q (PackagePath (QualSetup pn)) <$> dep) ci
-      | otherwise = Dep (Q (PackagePath inheritedQ) <$> dep) ci
-
-    -- If P has a setup dependency on Q, and Q has a regular dependency on R, then
-    -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup
-    -- dependency on R. We do not do this for the base qualifier however.
-    --
-    -- The inherited qualifier is only used for regular dependencies; for setup
-    -- and base dependencies we override the existing qualifier. See #3160 for
-    -- a detailed discussion.
-    inheritedQ :: Qualifier
-    inheritedQ = case q of
-      QualSetup _ -> q
-      QualExe _ _ -> q
-      QualToplevel -> q
+
+    -- In case of executable and setup dependencies, we need to qualify the dependency
+    -- with the previsous stage (e.g. Host -> Build).
+    goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _component =
+      Dep (Q (PackagePath (prevStage s) (QualExe pn qpn)) <$> dep) ci
+
+    goD (Dep dep@(PkgComponent _qpn (ExposedLib _)) ci) ComponentSetup =
+      Dep (Q (PackagePath (prevStage s) (QualSetup pn)) <$> dep) ci
+
+    goD (Dep dep@(PkgComponent _qpn _) ci) _component =
+      Dep (Q (PackagePath s q) <$> dep) ci
 
 -- | Remove qualifiers from set of dependencies
 --

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 _stage v _) _) conflicts =
       let (PInfo deps _ _ _) = idx M.! pn M.! i
           qdeps = qualifyDeps currentQPN deps