small changes mostly to understand the code

andreabedini · andreabedini · commit 9ea5b418b2d5 · 2025-03-18T12:29:22.000+08:00
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs
@@ -19,10 +19,10 @@ import qualified Data.Map as M
 import Data.Set (isSubsetOf)
 import Distribution.Compat.Graph
          ( IsNode(..) )
-import Distribution.Compiler
-         ( CompilerInfo )
 import Distribution.Solver.Modular.Assignment
          ( Assignment, toCPs )
+import Distribution.Solver.Modular.Configured
+         ( CP (..) )
 import Distribution.Solver.Modular.ConfiguredConversion
          ( convCP )
 import qualified Distribution.Solver.Modular.ConflictSet as CS
@@ -40,29 +40,28 @@ import Distribution.Solver.Modular.Solver
          ( SolverConfig(..), PruneAfterFirstSuccess(..), solve )
 import Distribution.Solver.Types.DependencyResolver
 import Distribution.Solver.Types.LabeledPackageConstraint
+import Distribution.Solver.Types.OptionalStanza (showStanzas, optStanzaSetNull)
 import Distribution.Solver.Types.PackageConstraint
 import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.PackagePreferences
 import Distribution.Solver.Types.PkgConfigDb
          ( PkgConfigDb )
 import Distribution.Solver.Types.Progress
 import Distribution.Solver.Types.Variable
-import Distribution.System
-         ( Platform(..) )
+import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps
+
+import Distribution.Simple.Compiler
+         ( CompilerInfo, compilerInfo )
 import Distribution.Simple.Setup
          ( BooleanFlag(..) )
 import Distribution.Simple.Utils
          ( ordNubBy )
 import Distribution.Verbosity
-import Distribution.Solver.Modular.Configured (CP (..))
-import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps
+
 import Distribution.Pretty (Pretty (..))
 import Text.PrettyPrint (text, vcat, Doc, nest, ($+$)) 
-import Distribution.Solver.Types.OptionalStanza (showStanzas, optStanzaSetNull)
 import Distribution.Types.Flag (nullFlagAssignment)
-import Distribution.Solver.Types.Toolchain (Toolchain(..), Staged)
-import Distribution.Simple.Compiler (compilerInfo)
-import Distribution.Simple.PackageIndex (InstalledPackageIndex)
+import Distribution.Solver.Types.Toolchain (Staged, Toolchain (..))
 
 
 showCP :: CP QPN -> Doc
@@ -83,11 +82,13 @@ showCP (CP qpi fa es ds) =
 -- solver. Performs the necessary translations before and after.
 modularResolver :: SolverConfig -> DependencyResolver loc
 modularResolver sc toolchains pkgConfigDbs iidx sidx pprefs pcs pns = do
-    (assignment, revdepmap) <- solve' sc toolchains pkgConfigDbs idx pprefs gcs pns
+    (assignment, revdepmap) <- solve' sc cinfo pkgConfigDbs idx pprefs gcs pns
     let cp = toCPs assignment revdepmap
     Step (show (vcat (map showCP cp))) $
         return $ postprocess assignment revdepmap
   where
+      cinfo = compilerInfo . toolchainCompiler <$> toolchains
+      
       -- Indices have to be converted into solver-specific uniform index.
       idx    = convPIs toolchains gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx
 
@@ -140,21 +141,21 @@ modularResolver sc toolchains pkgConfigDbs iidx sidx pprefs pcs pns = do
 -- complete, i.e., it shows the whole chain of dependencies from the user
 -- targets to the conflicting packages.
 solve' :: SolverConfig
-       -> Staged Toolchain
+       -> Staged CompilerInfo
        -> Staged (Maybe PkgConfigDb)
        -> Index
        -> (PN -> PackagePreferences)
        -> Map PN [LabeledPackageConstraint]
        -> Set PN
        -> Progress String String (Assignment, RevDepMap)
-solve' sc toolchains pkgConfigDb idx 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' toolchains pkgConfigDb idx pprefs gcs pns
+        solve sc' cinfo pkgConfigDb idx pprefs gcs pns
 
     createErrorMsg :: SolverFailure
                    -> RetryLog String String (Assignment, RevDepMap)
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs
@@ -66,15 +66,6 @@ convPIs
   -> Index
 convPIs toolchains' constraints sip strfl solveExes iidx sidx =
   mkIndex $ convIPI' sip iidx ++ convSPI' toolchains' constraints strfl solveExes sidx
-    -- [ foldMap
-    --     (\(stage, idx) -> convIPI' stage sip idx)
-    --     (tabulate iidx)
-    -- , foldMap
-    --     (\(stage, Toolchain{toolchainCompiler = comp, toolchainPlatform = Platform arch os}) ->
-    --       convSPI' stage os arch comp constraints strfl solveExes sidx
-    --     )
-    --     toolchains'
-    -- ]
 
 -- | Convert a Cabal installed package index to the simpler,
 -- more uniform index format of the solver.
@@ -173,6 +164,11 @@ convIPId stage dr comp idx ipid =
 
 -- | Convert a cabal-install source package index to the simpler,
 -- more uniform index format of the solver.
+-- 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 Toolchain
   -> Map PN [LabeledPackageConstraint]
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs
@@ -49,7 +49,7 @@ 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
@@ -211,7 +211,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
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs
@@ -35,7 +35,7 @@ import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)
 import Distribution.Types.LibraryName
 import Distribution.Types.PkgconfigVersionRange
-import Distribution.Solver.Types.Stage (Staged (..), Stage)
+import Distribution.Solver.Types.Stage (Staged (..), Stage (..))
 
 -- In practice, most constraints are implication constraints (IF we have made
 -- a number of choices, THEN we also have to ensure that). We call constraints
@@ -91,7 +91,7 @@ import Distribution.Solver.Types.Stage (Staged (..), Stage)
 data ValidateState = VS {
   supportedExt        :: Stage -> Extension -> Bool,
   supportedLang       :: Stage -> Language  -> Bool,
-  presentPkgs         :: Maybe (PkgconfigName -> PkgconfigVersionRange  -> Bool),
+  presentPkgs         :: Stage -> Maybe (PkgconfigName -> PkgconfigVersionRange  -> Bool),
   index               :: Index,
 
   -- Saved, scoped, dependencies. Every time 'validate' makes a package choice,
@@ -157,31 +157,48 @@ validate = go
   where
     go :: Tree d c -> Validate (Tree d c)
 
-    go (PChoice qpn rdm gr       ts) = PChoice qpn rdm gr <$> W.traverseWithKey (\k -> goP qpn k . go) ts
-    go (FChoice qfn rdm gr b m d ts) =
-      do
-        -- Flag choices may occur repeatedly (because they can introduce new constraints
-        -- in various places). However, subsequent choices must be consistent. We thereby
-        -- collapse repeated flag choice nodes.
-        PA _ pfa _ <- asks pa -- obtain current flag-preassignment
-        case M.lookup qfn pfa of
-          Just rb -> -- flag has already been assigned; collapse choice to the correct branch
-                     case W.lookup rb ts of
-                       Just t  -> goF qfn rb (go t)
-                       Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn)
-          Nothing -> -- flag choice is new, follow both branches
-                     FChoice qfn rdm gr b m d <$> W.traverseWithKey (\k -> goF qfn k . go) ts
-    go (SChoice qsn rdm gr b   ts) =
-      do
-        -- Optional stanza choices are very similar to flag choices.
-        PA _ _ psa <- asks pa -- obtain current stanza-preassignment
-        case M.lookup qsn psa of
-          Just rb -> -- stanza choice has already been made; collapse choice to the correct branch
-                     case W.lookup rb ts of
-                       Just t  -> goS qsn rb (go t)
-                       Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn)
-          Nothing -> -- stanza choice is new, follow both branches
-                     SChoice qsn rdm gr b <$> W.traverseWithKey (\k -> goS qsn k . go) ts
+    -- A package version node
+    go (PChoice qpn rdm gr       ts) =
+      PChoice qpn rdm gr <$> W.traverseWithKey g ts
+        where
+          g :: POption -> Tree d c -> Validate (Tree d c)
+          g popt = goP qpn popt . go
+
+    -- A package flag node
+    go (FChoice qfn rdm gr b m d ts) = do
+      -- Flag choices may occur repeatedly (because they can introduce new
+      -- constraints in various places). However, subsequent choices must be
+      -- consistent. We thereby collapse repeated flag choice nodes.
+      PA _ pfa _ <- asks pa -- obtain current flag-preassignment
+      case M.lookup qfn pfa of
+        Just rb ->
+          -- flag has already been assigned; collapse choice to the correct branch
+          case W.lookup rb ts of
+            Just t  -> goF qfn rb (go t)
+            Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn)
+        Nothing ->
+          -- flag choice is new, follow both branches
+          FChoice qfn rdm gr b m d <$> W.traverseWithKey g ts
+            where
+              g :: Bool -> Tree d c -> Validate (Tree d c)
+              g k = goF qfn k . go
+
+    -- A package stanza node
+    go (SChoice qsn rdm gr b   ts) = do
+      -- Optional stanza choices are very similar to flag choices.
+      PA _ _ psa <- asks pa -- obtain current stanza-preassignment
+      case M.lookup qsn psa of
+        Just rb ->
+          -- stanza choice has already been made; collapse choice to the correct branch
+          case W.lookup rb ts of
+            Just t  -> goS qsn rb (go t)
+            Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn)
+        Nothing ->
+          -- stanza choice is new, follow both branches
+          SChoice qsn rdm gr b <$> W.traverseWithKey g ts
+          where
+            g :: Bool -> Tree d c -> Validate (Tree d c)
+            g k = goS qsn k . go
 
     -- We don't need to do anything for goal choices or failure nodes.
     go (GoalChoice rdm           ts) = GoalChoice rdm <$> traverse go ts
@@ -190,7 +207,7 @@ validate = go
 
     -- What to do for package nodes ...
     goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
-    goP qpn@(Q _pp pn) (POption i _) r = do
+    goP qpn@(Q _pp pn) (POption i _mpp) r = do
       PA ppa pfa psa <- asks pa    -- obtain current preassignment
       extSupported   <- asks supportedExt  -- obtain the supported extensions
       langSupported  <- asks supportedLang -- obtain the supported languages
@@ -207,7 +224,7 @@ validate = go
       -- plus the dependency information we have for that instance
       let newactives = extractAllDeps pfa psa qdeps
       -- We now try to extend the partial assignment with the new active constraints.
-      let mnppa = extend extSupported langSupported pkgPresent newactives
+      let mnppa = extend ({- FIXME -} extSupported Host) ({- FIXME -} langSupported Host) ({- FIXME -} pkgPresent Host) newactives
                    =<< extendWithPackageChoice (PI qpn i) ppa
       -- In case we continue, we save the scoped dependencies
       let nsvd = M.insert qpn qdeps svd
@@ -233,7 +250,7 @@ validate = go
 
     -- What to do for flag nodes ...
     goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
-    goF qfn@(FN qpn _f) b r = do
+    goF qfn@(FN qpn _f) flagValue r = do
       PA ppa pfa psa <- asks pa -- obtain current preassignment
       extSupported   <- asks supportedExt  -- obtain the supported extensions
       langSupported  <- asks supportedLang -- obtain the supported languages
@@ -249,13 +266,13 @@ validate = go
       -- correct scope.
       --
       -- Extend the flag assignment
-      let npfa = M.insert qfn b pfa
+      let npfa = M.insert qfn flagValue pfa
       -- We now try to get the new active dependencies we might learn about because
       -- we have chosen a new flag.
-      let newactives = extractNewDeps (F qfn) b npfa psa qdeps
+      let newactives = extractNewDeps (F qfn) flagValue npfa psa qdeps
           mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives
       -- As in the package case, we try to extend the partial assignment.
-      let mnppa = extend extSupported langSupported pkgPresent newactives ppa
+      let mnppa = extend ({- FIXME -} extSupported Host) ({- FIXME -} langSupported Host) ({- FIXME -} pkgPresent Host) newactives ppa
       case liftM2 (,) mnppa mNewRequiredComps of
         Left (c, fr)         -> return (Fail c fr) -- inconsistency found
         Right (nppa, rComps') ->
@@ -285,7 +302,7 @@ validate = go
       let newactives = extractNewDeps (S qsn) b pfa npsa qdeps
           mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives
       -- As in the package case, we try to extend the partial assignment.
-      let mnppa = extend extSupported langSupported pkgPresent newactives ppa
+      let mnppa = extend ({- FIXME -} extSupported Host) ({- FIXME -} langSupported Host) ({- FIXME -} pkgPresent Host) newactives ppa
       case liftM2 (,) mnppa mNewRequiredComps of
         Left (c, fr)         -> return (Fail c fr) -- inconsistency found
         Right (nppa, rComps') ->
@@ -329,7 +346,14 @@ checkComponentsInNewPackage required qpn providedComps =
 -- | We try to extract as many concrete dependencies from the given flagged
 -- dependencies as possible. We make use of all the flag knowledge we have
 -- already acquired.
-extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]
+extractAllDeps
+  :: FAssignment
+  -- ^ current flag assignments
+  -> SAssignment
+  -- ^ current stanza assignments
+  -> FlaggedDeps QPN
+  -- ^ conditional dependencies
+  -> [LDep QPN]
 extractAllDeps fa sa deps = do
   d <- deps
   case d of
@@ -346,22 +370,38 @@ extractAllDeps fa sa deps = do
 -- | We try to find new dependencies that become available due to the given
 -- flag or stanza choice. We therefore look for the choice in question, and then call
 -- 'extractAllDeps' for everything underneath.
-extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]
+extractNewDeps
+  :: Var QPN
+  -- ^ the variable (package, flag or stanza)
+  -> Bool
+  -- ^ the variable value
+  -> FAssignment
+  -- ^ current flag assignments
+  -> SAssignment
+  -- ^ current stanza assignments
+  -> FlaggedDeps QPN
+  -- ^ conditional dependencies
+  -> [LDep QPN]
+  -- ^ dependencies with a reason
 extractNewDeps v b fa sa = go
   where
     go :: FlaggedDeps QPN -> [LDep QPN]
     go deps = do
       d <- deps
       case d of
         Simple _ _           -> mzero
-        Flagged qfn' _ td fd
-          | v == F qfn'      -> if b then extractAllDeps fa sa td else extractAllDeps fa sa fd
+        Flagged qfn' _finfo td fd
+          | v == F qfn'      -> if b
+                                then extractAllDeps fa sa td
+                                else extractAllDeps fa sa fd
           | otherwise        -> case M.lookup qfn' fa of
                                   Nothing    -> mzero
                                   Just True  -> go td
                                   Just False -> go fd
         Stanza qsn' td
-          | v == S qsn'      -> if b then extractAllDeps fa sa td else []
+          | v == S qsn'      -> if b
+                                then extractAllDeps fa sa td
+                                else []
           | otherwise        -> case M.lookup qsn' sa of
                                   Nothing    -> mzero
                                   Just True  -> go td
@@ -565,17 +605,27 @@ extendRequiredComponents eqpn available = foldM extendSingle
 
 
 -- | Interface.
-validateTree :: Staged CompilerInfo -> Maybe PkgConfigDb -> Index -> Tree d c -> Tree d c
-validateTree cinfo pkgConfigDb idx t = runValidate (validate t) VS {
-    supportedExt        = -- if compiler has no list of extensions, we assume everything is supported
-                          let extSet = fmap (fmap S.fromList . compilerInfoExtensions) cinfo
-                          in  maybe (const True) (flip S.member) . getStage extSet
-  , supportedLang       = let langSet = fmap (fmap S.fromList . compilerInfoLanguages) cinfo
-                          in  maybe (const True) (flip S.member) . getStage langSet
-  , presentPkgs         = pkgConfigPkgIsPresent <$> pkgConfigDb
+validateTree
+  :: Staged CompilerInfo
+  -> Staged (Maybe PkgConfigDb)
+  -> Index
+  -> Tree d c
+  -> Tree d c
+validateTree cinfo pkgConfigDb idx t = runValidate (validate t) VS
+  { -- if compiler has no list of extensions, we assume everything is supported
+    supportedExt        =  maybe (const True) (flip S.member) . getStage extSet
+  , -- if compiler has no list of extensions, we assume everything is supported
+    supportedLang       = maybe (const True) (flip S.member) . getStage langSet
+  , presentPkgs         = fmap pkgConfigPkgIsPresent . getStage pkgConfigDb
   , index               = idx
   , saved               = M.empty
   , pa                  = PA M.empty M.empty M.empty
   , availableComponents = M.empty
   , requiredComponents  = M.empty
   }
+  where
+    extSet :: Staged (Maybe (S.Set Extension))
+    extSet = fmap (fmap S.fromList . compilerInfoExtensions) cinfo
+
+    langSet :: Staged (Maybe (S.Set Language))
+    langSet = fmap (fmap S.fromList . compilerInfoLanguages) cinfo
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs b/cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs
@@ -66,13 +66,15 @@ mapWeightsWithKey :: Ord w2
                   => (k -> w1 -> w2)
                   -> WeightedPSQ w1 k v
                   -> WeightedPSQ w2 k v
-mapWeightsWithKey f (WeightedPSQ xs) = fromList $
-                                       L.map (\ (w, k, v) -> (f k w, k, v)) xs
+mapWeightsWithKey f (WeightedPSQ xs) =
+  fromList $ L.map (\ (w, k, v) -> (f k w, k, v)) xs
 
 -- | /O(N)/. Update the values.
-mapWithKey :: (k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2
-mapWithKey f (WeightedPSQ xs) = WeightedPSQ $
-                                L.map (\ (w, k, v) -> (w, k, f k v)) xs
+mapWithKey :: (k -> v1 -> v2)
+           -> WeightedPSQ w k v1
+           -> WeightedPSQ w k v2
+mapWithKey f (WeightedPSQ xs) =
+  WeightedPSQ $ L.map (\ (w, k, v) -> (w, k, f k v)) xs
 
 -- | /O(N)/. Traverse and update values in some applicative functor.
 traverseWithKey
diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs
diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
