cabal-install-solver 3.16.1.0 → 3.18.1.0

raw patch · 31 files changed

+451/−270 lines, 31 filesdep ~Cabaldep ~Cabal-syntaxdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: Cabal, Cabal-syntax, base, filepath

API changes (from Hackage documentation)

Files

• ChangeLog.md +1/−1
• LICENSE +1/−1
• cabal-install-solver.cabal +8/−7
• src/Distribution/Solver/Modular.hs +43/−21
• src/Distribution/Solver/Modular/Assignment.hs +5/−5
• src/Distribution/Solver/Modular/Builder.hs +5/−3
• src/Distribution/Solver/Modular/Cycles.hs +3/−3
• src/Distribution/Solver/Modular/Dependency.hs +2/−2
• src/Distribution/Solver/Modular/Explore.hs +1/−1
• src/Distribution/Solver/Modular/IndexConversion.hs +9/−6
• src/Distribution/Solver/Modular/LabeledGraph.hs +1/−1
• src/Distribution/Solver/Modular/Linking.hs +1/−1
• src/Distribution/Solver/Modular/Log.hs +9/−6
• src/Distribution/Solver/Modular/Message.hs +97/−71
• src/Distribution/Solver/Modular/Package.hs +5/−0
• src/Distribution/Solver/Modular/Preference.hs +4/−1
• src/Distribution/Solver/Modular/Solver.hs +1/−1
• src/Distribution/Solver/Modular/Tree.hs +5/−4
• src/Distribution/Solver/Modular/Validate.hs +1/−1
• src/Distribution/Solver/Types/ComponentDeps.hs +9/−16
• src/Distribution/Solver/Types/ConstraintSource.hs +1/−0
• src/Distribution/Solver/Types/DependencyResolver.hs +9/−4
• src/Distribution/Solver/Types/OptionalStanza.hs +1/−0
• src/Distribution/Solver/Types/PackageConstraint.hs +7/−3
• src/Distribution/Solver/Types/PackageIndex.hs +27/−3
• src/Distribution/Solver/Types/PkgConfigDb.hs +7/−8
• src/Distribution/Solver/Types/Progress.hs +15/−13
• src/Distribution/Solver/Types/ProjectConfigPath.hs +87/−85
• src/Distribution/Solver/Types/ResolverPackage.hs +3/−2
• src/Distribution/Solver/Types/Settings.hs +35/−0
• src/Distribution/Solver/Types/SummarizedMessage.hs +48/−0

@@ -1,1 +1,1 @@-Please see https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.16.1.0.md+Please see https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.18.1.0.md

@@ -1,4 +1,4 @@-Copyright (c) 2003-2025, Cabal Development Team.+Copyright (c) 2003-2026, Cabal Development Team. See the AUTHORS file for the full list of copyright holders.  See */LICENSE for the copyright holders of the subcomponents.

@@ -1,6 +1,6 @@ cabal-version: 3.6 name:          cabal-install-solver-version:       3.16.1.0+version:       3.18.1.0 synopsis:      The solver component of cabal-install description:   The solver component used in the cabal-install command-line program.@@ -11,7 +11,7 @@ license-file:  LICENSE author:        Cabal Development Team (see AUTHORS file) maintainer:    Cabal Development Team <cabal-devel@haskell.org>-copyright:     2003-2025, Cabal Development Team+copyright:     2003-2026, Cabal Development Team category:      Distribution build-type:    Simple extra-doc-files:@@ -95,18 +95,19 @@     Distribution.Solver.Types.SolverId     Distribution.Solver.Types.SolverPackage     Distribution.Solver.Types.SourcePackage+    Distribution.Solver.Types.SummarizedMessage     Distribution.Solver.Types.Variable    build-depends:     , array         >=0.4      && <0.6-    , base          >=4.13     && <4.22+    , base          >=4.17     && <4.24     , bytestring    >=0.10.6.0 && <0.13-    , Cabal         ^>=3.16.1.0-    , Cabal-syntax  ^>=3.16.1.0+    , Cabal         ^>=3.18+    , Cabal-syntax  ^>=3.18     , containers    >=0.5.6.2  && <0.9     , edit-distance ^>= 0.2.2     , directory     >= 1.3.7.0  && < 1.4-    , filepath      ^>=1.4.0.0 || ^>=1.5.0.0+    , filepath      >= 1.3.0.1  && < 1.6     , mtl           >=2.0      && <2.4     , network-uri   >= 2.6.0.2 && < 2.7     , pretty        ^>=1.1@@ -132,7 +133,7 @@      UnitTests.Distribution.Solver.Modular.MessageUtils     build-depends:-     , base        >= 4.13  && <4.22+     , base        >= 4.17  && <4.24      , Cabal-syntax      , cabal-install-solver      , tasty       >= 1.2.3 && <1.6

@@ -27,8 +27,14 @@          ( convCP ) import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Index+    ( Var(..),+      showVar,+      ConflictMap,+      ConflictSet,+      showConflictSet,+      RevDepMap )+import Distribution.Solver.Modular.Flag ( SN(SN), FN(FN) )+import Distribution.Solver.Modular.Index ( Index ) import Distribution.Solver.Modular.IndexConversion          ( convPIs ) import Distribution.Solver.Modular.Log@@ -36,25 +42,38 @@ import Distribution.Solver.Modular.Package          ( PN ) import Distribution.Solver.Modular.RetryLog+    ( RetryLog,+      toProgress,+      fromProgress,+      retry,+      failWith,+      continueWith ) import Distribution.Solver.Modular.Solver          ( SolverConfig(..), PruneAfterFirstSuccess(..), solve ) import Distribution.Solver.Types.DependencyResolver+    ( DependencyResolver ) import Distribution.Solver.Types.LabeledPackageConstraint+    ( LabeledPackageConstraint, unlabelPackageConstraint ) import Distribution.Solver.Types.PackageConstraint-import Distribution.Solver.Types.PackagePath+    ( PackageConstraint(..), scopeToPackageName )+import Distribution.Solver.Types.PackagePath ( QPN ) import Distribution.Solver.Types.PackagePreferences+    ( PackagePreferences ) import Distribution.Solver.Types.PkgConfigDb          ( PkgConfigDb ) import Distribution.Solver.Types.Progress-import Distribution.Solver.Types.Variable+    ( Progress(..), foldProgress )+import Distribution.Solver.Types.SummarizedMessage+    ( SummarizedMessage(StringMsg) )+import Distribution.Solver.Types.Variable ( Variable(..) ) import Distribution.System          ( Platform(..) ) import Distribution.Simple.Setup          ( BooleanFlag(..) ) import Distribution.Simple.Utils-         ( ordNubBy )+    ( ordNubBy ) import Distribution.Verbosity-+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.@@ -120,21 +139,21 @@        -> (PN -> PackagePreferences)        -> Map PN [LabeledPackageConstraint]        -> Set PN-       -> Progress String String (Assignment, RevDepMap)+       -> Progress SummarizedMessage String (Assignment, RevDepMap) solve' sc cinfo idx pkgConfigDB pprefs gcs pns =     toProgress $ retry (runSolver printFullLog sc) createErrorMsg   where     runSolver :: Bool -> SolverConfig-              -> RetryLog String SolverFailure (Assignment, RevDepMap)+              -> RetryLog SummarizedMessage SolverFailure (Assignment, RevDepMap)     runSolver keepLog sc' =         displayLogMessages keepLog $         solve sc' cinfo idx pkgConfigDB pprefs gcs pns      createErrorMsg :: SolverFailure-                   -> RetryLog String String (Assignment, RevDepMap)+                   -> RetryLog SummarizedMessage String (Assignment, RevDepMap)     createErrorMsg failure@(ExhaustiveSearch cs cm) =       if asBool $ minimizeConflictSet sc-      then continueWith ("Found no solution after exhaustively searching the "+      then continueWith (mkStringMsg $ "Found no solution after exhaustively searching the "                           ++ "dependency tree. Rerunning the dependency solver "                           ++ "to minimize the conflict set ({"                           ++ showConflictSet cs ++ "}).") $@@ -155,7 +174,7 @@            rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure     createErrorMsg failure@BackjumpLimitReached     =         continueWith-             ("Backjump limit reached. Rerunning dependency solver to generate "+             (mkStringMsg $ "Backjump limit reached. Rerunning dependency solver to generate "               ++ "a final conflict set for the search tree containing the "               ++ "first backjump.") $         retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $@@ -181,13 +200,16 @@           -- original goal order.           goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc) -      in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc')))+      in unlines ("Could not resolve dependencies:" : map renderSummarizedMessage (messages (toProgress (runSolver True sc')))) -    printFullLog = solverVerbosity sc >= verbose+    printFullLog = solverVerbosity sc >= Verbose      messages :: Progress step fail done -> [step]     messages = foldProgress (:) (const []) (const []) +mkStringMsg :: String -> SummarizedMessage+mkStringMsg msg = StringMsg msg+ -- | Try to remove variables from the given conflict set to create a minimal -- conflict set. --@@ -219,11 +241,11 @@ --    solver to add new unnecessary variables to the conflict set. This function --    discards the result from any run that adds new variables to the conflict --    set, but the end result may not be completely minimized.-tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a)+tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog SummarizedMessage SolverFailure a)                          -> SolverConfig                          -> ConflictSet                          -> ConflictMap-                         -> RetryLog String SolverFailure a+                         -> RetryLog SummarizedMessage SolverFailure a tryToMinimizeConflictSet runSolver sc cs cm =     foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v)           (fromProgress $ Fail $ ExhaustiveSearch cs cm)@@ -249,14 +271,14 @@     tryToRemoveOneVar :: Var QPN                       -> ConflictSet                       -> ConflictMap-                      -> RetryLog String SolverFailure a+                      -> RetryLog SummarizedMessage SolverFailure a     tryToRemoveOneVar v smallestKnownCS smallestKnownCM         -- Check whether v is still present, because it may have already been         -- removed in a previous solver rerun.       | not (v `CS.member` smallestKnownCS) =           fromProgress $ Fail $ ExhaustiveSearch smallestKnownCS smallestKnownCM       | otherwise =-        continueWith ("Trying to remove variable " ++ varStr ++ " from the "+        continueWith (mkStringMsg $ "Trying to remove variable " ++ varStr ++ " from the "                       ++ "conflict set.") $         retry (runSolver sc') $ \case             err@(ExhaustiveSearch cs' _)@@ -268,14 +290,14 @@                                   ++ "conflict set."                   in -- Use the new conflict set, even if v wasn't removed,                      -- because other variables may have been removed.-                     failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err+                     failWith (mkStringMsg $ msg ++ " Continuing with " ++ showCS cs' ++ ".") err               | otherwise ->-                  failWith ("Failed to find a smaller conflict set. The new "+                  failWith (mkStringMsg $ "Failed to find a smaller conflict set. The new "                              ++ "conflict set is not a subset of the previous "                              ++ "conflict set: " ++ showCS cs') $                   ExhaustiveSearch smallestKnownCS smallestKnownCM             BackjumpLimitReached ->-                failWith "Reached backjump limit while minimizing conflict set."+                failWith (mkStringMsg "Reached backjump limit while minimizing conflict set.")                          BackjumpLimitReached       where         varStr = "\"" ++ showVar v ++ "\""@@ -321,7 +343,7 @@           ++ showCS cm cs           ++ flagSuggestion         where-          showCS = if solverVerbosity sc > normal+          showCS = if solverVerbosity sc > Normal                    then CS.showCSWithFrequency                    else CS.showCSSortedByFrequency           flagSuggestion =

@@ -27,6 +27,7 @@ import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.LabeledGraph import Distribution.Solver.Modular.Package+import Distribution.Simple.Utils (ordNub)  -- | A (partial) package assignment. Qualified package names -- are associated with instances.@@ -53,7 +54,7 @@     vm  :: Vertex -> ((), QPN, [(Component, QPN)])     cvm :: QPN -> Maybe Vertex     -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub.-    (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs))+    (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, ordNub xs))                                   (M.toList rdm))     tg :: Graph Component     tg = transposeG g@@ -68,13 +69,12 @@     -- complete flag assignment by package.     fapp :: Map QPN FlagAssignment     fapp = M.fromListWith mappend $-           L.map (\ ((FN qpn fn), b) -> (qpn, mkFlagAssignment [(fn, b)])) $-           M.toList $-           fa+           L.map (\ (FN qpn fn, b) -> (qpn, mkFlagAssignment [(fn, b)])) $+           M.toList fa     -- Stanzas per package.     sapp :: Map QPN OptionalStanzaSet     sapp = M.fromListWith mappend-         $ L.map (\ ((SN qpn sn), b) -> (qpn, if b then optStanzaSetSingleton sn else mempty))+         $ L.map (\ (SN qpn sn, b) -> (qpn, if b then optStanzaSetSingleton sn else mempty))          $ M.toList sa     -- Dependencies per package.     depp :: QPN -> [(Component, PI QPN)]

@@ -1,4 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+ module Distribution.Solver.Modular.Builder (     buildTree   , splits -- for testing@@ -215,7 +217,7 @@ addLinking :: LinkingState -> TreeF () c a -> TreeF () c (Linker a) -- The only nodes of interest are package nodes addLinking ls (PChoiceF qpn@(Q pp pn) rdm gr cs) =-  let linkedCs = fmap (\bs -> Linker bs ls) $+  let linkedCs = fmap (`Linker` ls) $                  W.fromList $ concatMap (linkChoices ls qpn) (W.toList cs)       unlinkedCs = W.mapWithKey goP cs       allCs = unlinkedCs `W.union` linkedCs@@ -226,7 +228,7 @@       goP (POption i Nothing) bs = Linker bs $ M.insertWith (++) (pn, i) [pp] ls       goP _                   _  = alreadyLinked   in PChoiceF qpn rdm gr allCs-addLinking ls t = fmap (\bs -> Linker bs ls) t+addLinking ls t = fmap (`Linker` ls) t  linkChoices :: forall a w . LinkingState             -> QPN@@ -252,7 +254,7 @@     build Linker {         buildState = BS {             index = idx-          , rdeps = M.fromList (L.map (\ qpn -> (qpn, []))              qpns)+          , rdeps = M.fromList (L.map (, []) qpns)           , open  = L.map topLevelGoal qpns           , next  = Goals           , qualifyOptions = defaultQualifyOptions idx

@@ -23,11 +23,11 @@     -- Only check children of choice nodes.     go :: Tree d c -> Tree d c     go (PChoice qpn rdm gr                         cs) =-        PChoice qpn rdm gr     $ fmap (checkChild qpn)   (fmap go cs)+        PChoice qpn rdm gr     $ fmap (checkChild qpn . go) cs     go (FChoice qfn@(FN qpn _) rdm gr w m d cs) =-        FChoice qfn rdm gr w m d $ fmap (checkChild qpn) (fmap go cs)+        FChoice qfn rdm gr w m d $ fmap (checkChild qpn . go) cs     go (SChoice qsn@(SN qpn _) rdm gr w     cs) =-        SChoice qsn rdm gr w   $ fmap (checkChild qpn)   (fmap go cs)+        SChoice qsn rdm gr w   $ fmap (checkChild qpn . go) cs     go (GoalChoice rdm cs) = GoalChoice rdm (fmap go cs)     go x@(Fail _ _) = x     go x@(Done _ _) = x

@@ -147,10 +147,10 @@ -- | Print the reason that a dependency was introduced. showDependencyReason :: DependencyReason QPN -> String showDependencyReason (DependencyReason qpn flags stanzas) =-    intercalate " " $+    unwords $         showQPN qpn       : map (uncurry showFlagValue) (M.toList flags)-     ++ map (\s -> showSBool s True) (S.toList stanzas)+     ++ map (`showSBool` True) (S.toList stanzas)  -- | Options for goal qualification (used in 'qualifyDeps') --

@@ -194,7 +194,7 @@         where f k             r = r (A pa (M.insert qfn k fa) sa)     go (SChoice qsn rdm y t     ts) (A pa fa sa) = SChoice qsn rdm y t     $ W.mapWithKey f (fmap go ts)         where f k             r = r (A pa fa (M.insert qsn k sa))-    go (GoalChoice  rdm         ts) a            = GoalChoice  rdm         $ fmap ($ a) (fmap go ts)+    go (GoalChoice  rdm         ts) a            = GoalChoice  rdm         $ fmap (`go` a) ts  -- | A tree traversal that simultaneously propagates conflict sets up -- the tree from the leaves and creates a log.

@@ -42,6 +42,9 @@ import Distribution.Solver.Modular.Tree import Distribution.Solver.Modular.Version +import qualified Distribution.Compat.Lens as L+import qualified Distribution.Types.BuildInfo.Lens as L+ -- | Convert both the installed package index and the source package -- index into one uniform solver index. --@@ -182,7 +185,7 @@       conv :: Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN ->-            CondTree ConfVar [Dependency] a -> FlaggedDeps PN+            CondTree ConfVar a -> FlaggedDeps PN     conv comp getInfo dr =         convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo solveExes .         addBuildableCondition getInfo@@ -251,7 +254,7 @@                           -> CompilerInfo                           -> [LabeledPackageConstraint]                           -> (a -> Bool)-                          -> CondTree ConfVar [Dependency] a+                          -> CondTree ConfVar a                           -> Maybe Bool testConditionForComponent os arch cinfo constraints p tree =     case go $ extractCondition p tree of@@ -329,8 +332,8 @@                 Component ->                 (a -> BuildInfo) ->                 SolveExecutables ->-                CondTree ConfVar [Dependency] a -> FlaggedDeps PN-convCondTree flags dr pkg os arch cinfo pn fds comp getInfo solveExes@(SolveExecutables solveExes') (CondNode info ds branches) =+                CondTree ConfVar a -> FlaggedDeps PN+convCondTree flags dr pkg os arch cinfo pn fds comp getInfo solveExes@(SolveExecutables solveExes') (CondNode info branches) =              -- Merge all library and build-tool dependencies at every level in              -- the tree of flagged dependencies. Otherwise 'extractCommon'              -- could create duplicate dependencies, and the number of@@ -338,7 +341,7 @@              -- of the tree.              mergeSimpleDeps $                  [ D.Simple singleDep comp-                 | dep <- ds+                 | dep <- L.view L.targetBuildDepends (getInfo info)                  , singleDep <- convLibDeps dr dep ]  -- unconditional package dependencies                ++ L.map (\e -> D.Simple (LDep dr (Ext  e)) comp) (allExtensions bi) -- unconditional extension dependencies@@ -461,7 +464,7 @@            -> Component            -> (a -> BuildInfo)            -> SolveExecutables-           -> CondBranch ConfVar [Dependency] a+           -> CondBranch ConfVar a            -> FlaggedDeps PN convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes (CondBranch c' t' mf') =     go c'

@@ -52,7 +52,7 @@     sorted_edges = sortBy lt edges0     edges1       = zip [0..] sorted_edges -    graph        = array bounds0 [(v, (mapMaybe mk_edge ks))+    graph        = array bounds0 [(v, mapMaybe mk_edge ks)                                  | (v, (_, _, ks)) <- edges1]     key_map      = array bounds0 [(v, k                    )                                  | (v, (_, k, _ )) <- edges1]

@@ -145,7 +145,7 @@   deriving (Functor, Applicative, Monad)  instance MonadState ValidateState UpdateState where-  get    = UpdateState $ get+  get    = UpdateState get   put st = UpdateState $ do              expensiveAssert (lgInvariant $ vsLinks st) $ return ()              put st

@@ -7,11 +7,14 @@ import Distribution.Solver.Compat.Prelude  import Distribution.Solver.Types.Progress--import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Message+    ( Progress(Done, Fail), foldProgress )+import Distribution.Solver.Modular.ConflictSet+    ( ConflictMap, ConflictSet ) import Distribution.Solver.Modular.RetryLog-+    ( RetryLog, toProgress, fromProgress )+import Distribution.Solver.Modular.Message (Message, summarizeMessages)+import Distribution.Solver.Types.SummarizedMessage+    ( SummarizedMessage(..) ) -- | Information about a dependency solver failure. data SolverFailure =     ExhaustiveSearch ConflictSet ConflictMap@@ -22,10 +25,10 @@ -- 'keepLog'), for efficiency. displayLogMessages :: Bool                    -> RetryLog Message SolverFailure a-                   -> RetryLog String SolverFailure a+                   -> RetryLog SummarizedMessage SolverFailure a displayLogMessages keepLog lg = fromProgress $     if keepLog-    then showMessages progress+    then summarizeMessages progress     else foldProgress (const id) Fail Done progress   where     progress = toProgress lg

@@ -1,9 +1,9 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-}  module Distribution.Solver.Modular.Message (     Message(..),-    showMessages+    summarizeMessages,+    renderSummarizedMessage,   ) where  import qualified Data.List as L@@ -14,26 +14,50 @@ import Data.Maybe (catMaybes, mapMaybe, isJust) import Prelude hiding (pi) -import Distribution.Pretty (prettyShow) -- from Cabal+import Distribution.Pretty ( prettyShow ) -- from Cabal  import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag ( QFN, QSN )-import qualified Distribution.Solver.Modular.Flag as Flag ( showQFN, showQFNBool, showQSN, showQSNBool )+    ( Var(P),+      ConflictSet,+      showConflictSet,+      QGoalReason,+      GoalReason(DependencyGoal, UserGoal),+      Goal(Goal),+      DependencyReason(DependencyReason),+      ExposedComponent(..),+      PkgComponent(PkgComponent),+      CI(Constrained, Fixed),+      showDependencyReason )+import Distribution.Solver.Modular.Flag+    ( QSN, QFN, showQFNBool, showQSNBool, showQFN, showQSN ) import Distribution.Solver.Modular.MessageUtils-         (showUnsupportedExtension, showUnsupportedLanguage)+    ( showUnsupportedExtension, showUnsupportedLanguage ) import Distribution.Solver.Modular.Package+    ( PI(PI), showI, showPI ) import Distribution.Solver.Modular.Tree-         ( FailReason(..), POption(..), ConflictingDep(..) )+    ( FailReason(..), POption(..), ConflictingDep(..) ) import Distribution.Solver.Modular.Version+    ( VR, Ver, showVer, showVR, (.||.) )+ import Distribution.Solver.Types.ConstraintSource+    ( ConstraintSource (..), showConstraintSource ) import Distribution.Solver.Types.PackagePath+    ( QPN, Qualified(Q), showQPN ) import Distribution.Solver.Types.Progress-import Distribution.Solver.Types.ProjectConfigPath (docProjectConfigPathFailReason)+    ( Progress(..) )+import Distribution.Solver.Types.ProjectConfigPath+    ( docProjectConfigPathFailReason)+import Distribution.Solver.Types.SummarizedMessage+    ( Entry(..), EntryAtLevel(..), SummarizedMessage(..) ) import Distribution.Types.LibraryName+    ( LibraryName(LSubLibName, LMainLibName) ) import Distribution.Types.UnqualComponentName-import Text.PrettyPrint (nest, render)+    ( unUnqualComponentName ) +import Text.PrettyPrint ( nest, render )++-- A data type to hold log information from the modular solver. data Message =     Enter           -- ^ increase indentation level   | Leave           -- ^ decrease indentation level@@ -45,51 +69,81 @@   | Success   | Failure ConflictSet FailReason --- | Transforms the structured message type to actual messages (strings).+renderSummarizedMessage :: SummarizedMessage -> String+renderSummarizedMessage (SummarizedMsg i) = displayMessageAtLevel i+renderSummarizedMessage (StringMsg s) = s++displayMessageAtLevel :: EntryAtLevel -> String+displayMessageAtLevel (AtLevel l msg) =+  let s = show l+  in  "[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ displayMessage msg++displayMessage :: Entry -> String+displayMessage (EntryPackageGoal qpn gr) = "next goal: " ++ showQPN qpn ++ showGR gr+displayMessage (EntryRejectF qfn b c fr) = "rejecting: " ++ showQFNBool qfn b ++ showFR c fr+displayMessage (EntryRejectS qsn b c fr) = "rejecting: " ++ showQSNBool qsn b ++ showFR c fr+displayMessage (EntrySkipping cs) = "skipping: " ++ showConflicts cs+displayMessage (EntryTryingF qfn b) = "trying: " ++ showQFNBool qfn b+displayMessage (EntryTryingP qpn i) = "trying: " ++ showOption qpn i+displayMessage (EntryTryingNewP qpn i gr) = "trying: " ++ showOption qpn i ++ showGR gr+displayMessage (EntryTryingS qsn b) = "trying: " ++ showQSNBool qsn b+displayMessage (EntryUnknownPackage qpn gr) = "unknown package: " ++ showQPN qpn ++ showGR gr+displayMessage EntrySuccess = "done"+displayMessage (EntryFailure c fr) = "fail" ++ showFR c fr+displayMessage (EntrySkipMany qsn b cs) = "skipping: " ++ showOptions qsn b ++ " " ++ showConflicts cs+-- Instead of displaying `aeson-1.0.2.1, aeson-1.0.2.0, aeson-1.0.1.0, ...`,+-- the following line aims to display `aeson: 1.0.2.1, 1.0.2.0, 1.0.1.0, ...`. --+displayMessage (EntryRejectMany qpn is c fr) = "rejecting: " ++ showOptions qpn is ++ showFR c fr++-- | Transforms the structured message type to actual messages (SummarizedMessage s).+-- -- The log contains level numbers, which are useful for any trace that involves -- backtracking, because only the level numbers will allow to keep track of -- backjumps.-showMessages :: Progress Message a b -> Progress String a b-showMessages = go 0+summarizeMessages :: Progress Message a b -> Progress SummarizedMessage a b+summarizeMessages = go 0   where     -- 'go' increments the level for a recursive call when it encounters     -- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'.-    go :: Int -> Progress Message a b -> Progress String a b+    go :: Int -> Progress Message a b -> Progress SummarizedMessage a b     go !_ (Done x)                           = Done x     go !_ (Fail x)                           = Fail x+     -- complex patterns     go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =         goPReject l qpn [i] c fr ms+     go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) =         goPSkip l qpn [i] conflicts ms+     go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        (atLevel l $ blurbQFNBool Rejecting qfn b ++ showFR c fr) (go l ms)+        Step (SummarizedMsg $ AtLevel l (EntryRejectF qfn b c fr)) (go l ms)+     go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        (atLevel l $ blurbQSNBool Rejecting qsn b ++ showFR c fr) (go l ms)+        Step (SummarizedMsg $ AtLevel l (EntryRejectS qsn b c fr)) (go l ms)++    -- "Trying ..." message when a new goal is started     go !l (Step (Next (Goal (P _  ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =-        (atLevel l $ blurbOption Trying qpn' i ++ showGR gr) (go l ms)+        Step (SummarizedMsg $ AtLevel l (EntryTryingNewP qpn' i gr)) (go l ms)+     go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) =-        atLevel l ("unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms+        Step (SummarizedMsg $ AtLevel l (EntryUnknownPackage qpn gr)) (go l ms)+     -- standard display     go !l (Step Enter                    ms) = go (l+1) ms     go !l (Step Leave                    ms) = go (l-1) ms-    go !l (Step (TryP qpn i)             ms) = (atLevel l $ blurbOption Trying qpn i) (go l ms)-    go !l (Step (TryF qfn b)             ms) = (atLevel l $ blurbQFNBool Trying qfn b) (go l ms)-    go !l (Step (TryS qsn b)             ms) = (atLevel l $ blurbQSNBool Trying qsn b) (go l ms)-    go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms)-    go !l (Step (Next _)                 ms) = go l     ms -- ignore flag goals in the log-    go !l (Step (Skip conflicts)         ms) =-        -- 'Skip' should always be handled by 'goPSkip' in the case above.-        (atLevel l $ blurb Skipping ++ showConflicts conflicts) (go l ms)-    go !l (Step (Success)                ms) = (atLevel l $ "done") (go l ms)-    go !l (Step (Failure c fr)           ms) = (atLevel l $ showFailure c fr) (go l ms) -    showPackageGoal :: QPN -> QGoalReason -> String-    showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr+    go !l (Step (TryP qpn i)             ms) = Step (SummarizedMsg $ AtLevel l (EntryTryingP qpn i)) (go l ms)+    go !l (Step (TryF qfn b)             ms) = Step (SummarizedMsg $ AtLevel l (EntryTryingF qfn b)) (go l ms)+    go !l (Step (TryS qsn b)             ms) = Step (SummarizedMsg $ AtLevel l (EntryTryingS qsn b)) (go l ms)+    go !l (Step (Next (Goal (P qpn) gr)) ms) = Step (SummarizedMsg $ AtLevel l (EntryPackageGoal qpn gr)) (go l ms)+    go !l (Step (Next _)                 ms) = go l ms -- ignore flag goals in the log -    showFailure :: ConflictSet -> FailReason -> String-    showFailure c fr = "fail" ++ showFR c fr+    -- 'Skip' should always be handled by 'goPSkip' in the case above.+    go !l (Step (Skip conflicts)         ms) = Step (SummarizedMsg $ AtLevel l (EntrySkipping conflicts)) (go l ms)+    go !l (Step Success                  ms) = Step (SummarizedMsg $ AtLevel l EntrySuccess) (go l ms)+    go !l (Step (Failure c fr)           ms) = Step (SummarizedMsg $ AtLevel l (EntryFailure c fr)) (go l ms)      -- special handler for many subsequent package rejections     goPReject :: Int@@ -98,14 +152,13 @@               -> ConflictSet               -> FailReason               -> Progress Message a b-              -> Progress String a b+              -> Progress SummarizedMessage a b     goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))       | qpn == qpn' && fr == fr' =         -- By prepending (i : is) we reverse the order of the instances.         goPReject l qpn (i : is) c fr ms     goPReject l qpn is c fr ms =-        (atLevel l $ blurbOptions Rejecting qpn (reverse is) ++ showFR c fr)-        (go l ms)+        Step (SummarizedMsg $ AtLevel l (EntryRejectMany qpn (reverse is) c fr)) (go l ms)      -- Handle many subsequent skipped package instances.     goPSkip :: Int@@ -113,25 +166,18 @@             -> [POption]             -> Set CS.Conflict             -> Progress Message a b-            -> Progress String a b+            -> Progress SummarizedMessage a b     goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms))))       | qpn == qpn' && conflicts == conflicts' =         -- By prepending (i : is) we reverse the order of the instances.         goPSkip l qpn (i : is) conflicts ms     goPSkip l qpn is conflicts ms =-      let msg = blurbOptions Skipping qpn (reverse is) ++ showConflicts conflicts-      in atLevel l msg (go l ms)--    -- write a message with the current level number-    atLevel :: Int -> String -> Progress String a b -> Progress String a b-    atLevel l x xs =-      let s = show l-      in  Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs+       Step (SummarizedMsg $ AtLevel l (EntrySkipMany qpn (reverse is) conflicts)) (go l ms)  -- | Display the set of 'Conflicts' for a skipped package version. showConflicts :: Set CS.Conflict -> String showConflicts conflicts =-    " (has the same characteristics that caused the previous version to fail: "+    "(has the same characteristics that caused the previous version to fail: "      ++ conflictMsg ++ ")"   where     conflictMsg :: String@@ -213,29 +259,6 @@   , versionConflict :: Maybe VR   } -data ProgressAction =-    Trying-  | Skipping-  | Rejecting--blurb :: ProgressAction -> String-blurb = \case-  Trying -> "trying: "-  Skipping -> "skipping: "-  Rejecting -> "rejecting: "--blurbQFNBool :: ProgressAction -> QFN -> Bool -> String-blurbQFNBool a q b = blurb a ++ Flag.showQFNBool q b--blurbQSNBool :: ProgressAction -> QSN -> Bool -> String-blurbQSNBool a q b = blurb a ++ Flag.showQSNBool q b--blurbOption :: ProgressAction -> QPN -> POption -> String-blurbOption a q p = blurb a ++ showOption q p--blurbOptions :: ProgressAction -> QPN -> [POption] -> String-blurbOptions a q ps = blurb a ++ showOptions q ps- showOption :: QPN -> POption -> String showOption qpn@(Q _pp pn) (POption i linkedTo) =   case linkedTo of@@ -263,12 +286,12 @@ showOptions :: QPN -> [POption] -> String showOptions _ [] = "unexpected empty list of versions" showOptions q [x] = showOption q x-showOptions q xs = showQPN q ++ "; " ++ (L.intercalate ", "+showOptions q xs = showQPN q ++ "; " ++ L.intercalate ", "   [if isJust linkedTo     then showOption q x     else showI i -- Don't show the package, just the version   | x@(POption i linkedTo) <- xs-  ])+  ]  showGR :: QGoalReason -> String showGR UserGoal            = " (user goal)"@@ -295,6 +318,7 @@ showFR _ (GlobalConstraintVersion vr (ConstraintSourceProjectConfig pc)) = '\n' : (render . nest 6 $ docProjectConfigPathFailReason vr pc) showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")" showFR _ (GlobalConstraintInstalled src)  = " (" ++ constraintSource src ++ " requires installed instance)"+showFR _ (GlobalConstraintInstalledSpecificUnitId unitId src)  = " (" ++ constraintSource src ++ " requires installed instance with unit id " ++ prettyShow unitId ++ ")" showFR _ (GlobalConstraintSource src)     = " (" ++ constraintSource src ++ " requires source instance)" showFR _ (GlobalConstraintFlag src)       = " (" ++ constraintSource src ++ " requires opposite flag selection)" showFR _ ManualFlag                       = " (manual flag can only be changed explicitly)"@@ -306,8 +330,8 @@ -- The following are internal failures. They should not occur. In the -- interest of not crashing unnecessarily, we still just print an error -- message though.-showFR _ (MalformedFlagChoice qfn)        = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ Flag.showQFN qfn ++ ")"-showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ Flag.showQSN qsn ++ ")"+showFR _ (MalformedFlagChoice qfn)        = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")"+showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")" showFR _ EmptyGoalChoice                  = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"  showExposedComponent :: ExposedComponent -> String@@ -332,7 +356,9 @@                          componentStr ++ showVR vr  -- $setup+-- >>> import Distribution.Solver.Modular.Package -- >>> import Distribution.Solver.Types.PackagePath+-- >>> import Distribution.Types.PackageName -- >>> import Distribution.Types.Version -- >>> import Distribution.Types.UnitId -- >>> let foobarPN = PackagePath DefaultNamespace QualToplevel

@@ -10,6 +10,7 @@   , PN   , QPV   , instI+  , instUid   , makeIndependent   , primaryPP   , setupPP@@ -76,6 +77,10 @@ instI :: I -> Bool instI (I _ (Inst _)) = True instI _              = False++instUid :: UnitId -> I -> Bool+instUid uid (I _ (Inst uid')) = uid == uid'+instUid _ _ = False  -- | Is the package in the primary group of packages.  This is used to -- determine (1) if we should try to establish stanza preferences

@@ -135,7 +135,7 @@     preferred pn opt =       let PackagePreferences vrs _ _ = pcs pn       in fromIntegral . negate . L.length $-         L.filter (flip checkVR (version opt)) vrs+         L.filter (`checkVR` version opt) vrs      -- Prefer installed packages over non-installed packages.     installed :: POption -> Weight@@ -190,6 +190,9 @@     go _       PackagePropertyInstalled         | instI i       = r         | otherwise     = Fail c (GlobalConstraintInstalled src)+    go _       (PackagePropertyInstalledSpecificUnitId unitId)+        | instUid unitId i       = r+        | otherwise     = Fail c (GlobalConstraintInstalledSpecificUnitId unitId src)     go _       PackagePropertySource         | not (instI i) = r         | otherwise     = Fail c (GlobalConstraintSource src)

@@ -71,7 +71,7 @@   enableBackjumping      :: EnableBackjumping,   solveExecutables       :: SolveExecutables,   goalOrder              :: Maybe (Variable QPN -> Variable QPN -> Ordering),-  solverVerbosity        :: Verbosity,+  solverVerbosity        :: VerbosityLevel,   pruneAfterFirstSuccess :: PruneAfterFirstSuccess } 

@@ -118,6 +118,7 @@                 | UnknownPackage                 | GlobalConstraintVersion VR ConstraintSource                 | GlobalConstraintInstalled ConstraintSource+                | GlobalConstraintInstalledSpecificUnitId UnitId ConstraintSource                 | GlobalConstraintSource ConstraintSource                 | GlobalConstraintFlag ConstraintSource                 | ManualFlag@@ -163,10 +164,10 @@ inn (FailF       c x           ) = Fail       c x  innM :: Monad m => TreeF d c (m (Tree d c)) -> m (Tree d c)-innM (PChoiceF    p s i       ts) = liftM (PChoice    p s i      ) (sequence ts)-innM (FChoiceF    p s i b m d ts) = liftM (FChoice    p s i b m d) (sequence ts)-innM (SChoiceF    p s i b     ts) = liftM (SChoice    p s i b    ) (sequence ts)-innM (GoalChoiceF   s         ts) = liftM (GoalChoice   s        ) (sequence ts)+innM (PChoiceF    p s i       ts) = PChoice    p s i       <$> sequence ts+innM (FChoiceF    p s i b m d ts) = FChoice    p s i b m d <$> sequence ts+innM (SChoiceF    p s i b     ts) = SChoice    p s i b     <$> sequence ts+innM (GoalChoiceF   s         ts) = GoalChoice   s         <$> sequence ts innM (DoneF       x s           ) = return $ Done     x s innM (FailF       c x           ) = return $ Fail     c x 

@@ -566,7 +566,7 @@ validateTree :: CompilerInfo -> Index -> Maybe PkgConfigDb -> Tree d c -> Tree d c validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS {     supportedExt        = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported-                                (\ es -> let s = S.fromList es in \ x -> S.member x s)+                                (\ es -> let s = S.fromList es in (`S.member` s))                                 (compilerInfoExtensions cinfo)   , supportedLang       = maybe (const True)                                 (flip L.elem) -- use list lookup because language list is small and no Ord instance

@@ -1,5 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}  -- | Fine-grained package dependencies --@@ -30,7 +32,6 @@   , fromInstalled     -- ** Deconstructing ComponentDeps   , toList-  , flatDeps   , nonSetupDeps   , libraryDeps   , setupDeps@@ -43,7 +44,6 @@ import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip)  import qualified Data.Map as Map-import Data.Foldable (fold)  import Distribution.Pretty (Pretty (..)) import qualified Distribution.Types.ComponentName as CN@@ -119,7 +119,7 @@ -------------------------------------------------------------------------------}  empty :: ComponentDeps a-empty = ComponentDeps $ Map.empty+empty = ComponentDeps Map.empty  fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a fromList = ComponentDeps . Map.fromListWith mappend@@ -142,8 +142,8 @@     ComponentDeps $       Map.mergeWithKey         (\_ a b -> Just (a,b))-        (fmap (\a -> (a, mempty)))-        (fmap (\b -> (mempty, b)))+        (fmap (, mempty))+        (fmap (mempty, ))         d1 d2  -- | Keep only selected components (and their associated deps info).@@ -175,14 +175,6 @@ toList :: ComponentDeps a -> [ComponentDep a] toList = Map.toList . unComponentDeps --- | All dependencies of a package.------ This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more--- obvious than a use of 'fold', and moreover this avoids introducing lots of--- @#ifdef@s for 7.10 just for the use of 'fold'.-flatDeps :: Monoid a => ComponentDeps a -> a-flatDeps = fold- -- | All dependencies except the setup dependencies. -- -- Prior to the introduction of setup dependencies in version 1.24 this@@ -193,9 +185,10 @@ -- | Library dependencies proper only.  (Includes dependencies -- of internal libraries.) libraryDeps :: Monoid a => ComponentDeps a -> a-libraryDeps = select (\c -> case c of ComponentSubLib _ -> True-                                      ComponentLib -> True-                                      _ -> False)+libraryDeps = select (\case+  ComponentSubLib _ -> True+  ComponentLib -> True+  _ -> False)  -- | List components components :: ComponentDeps a -> Set Component

@@ -63,6 +63,7 @@   deriving (Show, Eq, Generic)  instance Binary ConstraintSource+instance NFData ConstraintSource instance Structured ConstraintSource  -- | Description of a 'ConstraintSource'.

@@ -2,17 +2,22 @@     ( DependencyResolver     ) where -import Distribution.Solver.Compat.Prelude+import Distribution.Solver.Compat.Prelude ( Maybe, String, Set ) import Prelude ()  import Distribution.Solver.Types.LabeledPackageConstraint+    ( LabeledPackageConstraint ) import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb ) import Distribution.Solver.Types.PackagePreferences+    ( PackagePreferences ) import Distribution.Solver.Types.PackageIndex ( PackageIndex ) import Distribution.Solver.Types.Progress+    ( Progress ) import Distribution.Solver.Types.ResolverPackage-import Distribution.Solver.Types.SourcePackage-+    ( ResolverPackage )+import Distribution.Solver.Types.SourcePackage ( SourcePackage )+import Distribution.Solver.Types.SummarizedMessage+    ( SummarizedMessage(..) ) import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) import Distribution.Package ( PackageName ) import Distribution.Compiler ( CompilerInfo )@@ -34,4 +39,4 @@                            -> (PackageName -> PackagePreferences)                            -> [LabeledPackageConstraint]                            -> Set PackageName-                           -> Progress String String [ResolverPackage loc]+                           -> Progress SummarizedMessage String [ResolverPackage loc]

@@ -57,6 +57,7 @@     }  instance Binary OptionalStanza+instance NFData OptionalStanza instance Structured OptionalStanza  -------------------------------------------------------------------------------

@@ -19,7 +19,7 @@ import Distribution.Solver.Compat.Prelude import Prelude () -import Distribution.Package                        (PackageName)+import Distribution.Package                        (PackageName, UnitId) import Distribution.PackageDescription             (FlagAssignment, dispFlagAssignment) import Distribution.Pretty                         (flatStyle, Pretty(pretty)) import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..))@@ -90,17 +90,20 @@ data PackageProperty    = PackagePropertyVersion   VersionRange    | PackagePropertyInstalled+   | PackagePropertyInstalledSpecificUnitId UnitId    | PackagePropertySource    | PackagePropertyFlags     FlagAssignment    | PackagePropertyStanzas   [OptionalStanza]   deriving (Eq, Show, Generic)  instance Binary PackageProperty+instance NFData PackageProperty instance Structured PackageProperty  instance Pretty PackageProperty where   pretty (PackagePropertyVersion verrange) = pretty verrange   pretty PackagePropertyInstalled          = Disp.text "installed"+  pretty (PackagePropertyInstalledSpecificUnitId unitId) = Disp.text "installed(" <> pretty unitId <> Disp.text ")"   pretty PackagePropertySource             = Disp.text "source"   pretty (PackagePropertyFlags flags)      = dispFlagAssignment flags   pretty (PackagePropertyStanzas stanzas)  =@@ -137,7 +140,8 @@ packageConstraintToDependency (PackageConstraint scope prop) = toDep prop   where     toDep (PackagePropertyVersion vr) = Just $ PackageVersionConstraint (scopeToPackageName scope) vr-    toDep (PackagePropertyInstalled)  = Nothing-    toDep (PackagePropertySource)     = Nothing+    toDep PackagePropertyInstalled  = Nothing+    toDep (PackagePropertyInstalledSpecificUnitId {}) = Nothing+    toDep PackagePropertySource       = Nothing     toDep (PackagePropertyFlags _)    = Nothing     toDep (PackagePropertyStanzas _)  = Nothing

@@ -22,6 +22,8 @@   -- * Updates   merge,   override,+  OverrideOrMerge(..),+  overrideOrMerge,   insert,   deletePackageName,   deletePackageId,@@ -120,7 +122,7 @@ -- case-sensitively. -- lookup :: PackageIndex pkg -> PackageName -> [pkg]-lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m+lookup (PackageIndex m) name = Map.findWithDefault [] name m  -- -- * Construction@@ -181,6 +183,28 @@   expensiveAssert (invariant i1 && invariant i2) $     mkPackageIndex (Map.unionWith (\_l r -> r) m1 m2) +data OverrideOrMerge = Override | Merge+  deriving (Eq, Show)++-- | Combined override-or-merge of two indexes.+--+-- For any package, either 'override' or 'merge' the packages from the second+-- index into the first based on the supplied predicate.+--+overrideOrMerge ::+     Package pkg+  => (PackageName -> OverrideOrMerge)+  -> PackageIndex pkg+  -> PackageIndex pkg+  -> PackageIndex pkg+overrideOrMerge strategy i1@(PackageIndex m1) i2@(PackageIndex m2) =+  expensiveAssert (invariant i1 && invariant i2) $+    mkPackageIndex (Map.unionWithKey overridePkg m1 m2)+  where+    overridePkg name l r = case strategy name of+      Override -> r+      Merge -> mergeBuckets l r+ -- | Inserts a single package into the index. -- -- This is equivalent to (but slightly quicker than) using 'mappend' or@@ -227,8 +251,8 @@ deleteDependency :: Package pkg                  => PackageName -> VersionRange -> PackageIndex pkg                  -> PackageIndex pkg-deleteDependency name verstionRange =-  delete name (\pkg -> packageVersion pkg `withinRange` verstionRange)+deleteDependency name versionRange =+  delete name (\pkg -> packageVersion pkg `withinRange` versionRange)  -- -- * Bulk queries

@@ -82,19 +82,18 @@               . filter (either (const True) (not . null))               -- Try decoding strictly; if it fails, put the lenient               -- decoding in a Left for later reporting.-              . map (\bsname ->-                       let sbsname = LBS.toStrict bsname-                       in case T.decodeUtf8' sbsname of-                            Left _ -> Left (T.unpack (decodeUtf8LenientCompat sbsname))-                            Right name -> Right (T.unpack name))               -- The output of @pkg-config --list-all@ also includes a               -- description for each package, which we do not need.               -- We don't use Data.Char.isSpace because that would also               -- include 0xA0, the non-breaking space, which can occur               -- in multi-byte UTF-8 sequences.-              . map (LBS.takeWhile (not . isAsciiSpace))+              . map ((\bsname ->+                       let sbsname = LBS.toStrict bsname+                       in case T.decodeUtf8' sbsname of+                            Left _ -> Left (T.unpack (decodeUtf8LenientCompat sbsname))+                            Right name -> Right (T.unpack name)) . LBS.takeWhile (not . isAsciiSpace))               $ pkgList-        when (not (null failedPkgNames)) $+        unless (null failedPkgNames) $           info verbosity ("Some pkg-config packages have names containing invalid unicode: " ++ intercalate ", " failedPkgNames)         (outs, _errs, exitCode) <-                      getProgramInvocationOutputAndErrors verbosity@@ -110,7 +109,7 @@           -- one package version, so if the returned list is shorter than the           -- requested one, we fall back to querying one by one.           do-            info verbosity ("call to pkg-config --modversion on all packages failed. Falling back to querying pkg-config individually on each package")+            info verbosity "call to pkg-config --modversion on all packages failed. Falling back to querying pkg-config individually on each package"             Just . pkgConfigDbFromList . catMaybes <$> mapM (getIndividualVersion pkgConfig) pkgNames   where     -- For when pkg-config invocation fails (possibly because of a

@@ -1,10 +1,13 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-} module Distribution.Solver.Types.Progress     ( Progress(..)     , foldProgress+    , step     ) where  import Prelude ()-import Distribution.Solver.Compat.Prelude hiding (fail)+import Distribution.Solver.Compat.Prelude  -- | A type to represent the unfolding of an expensive long running -- calculation that may fail. We may get intermediate steps before the final@@ -13,14 +16,10 @@ data Progress step fail done = Step step (Progress step fail done)                              | Fail fail                              | Done done+  deriving (Functor) --- This Functor instance works around a bug in GHC 7.6.3.--- See https://gitlab.haskell.org/ghc/ghc/-/issues/7436#note_66637.--- The derived functor instance caused a space leak in the solver.-instance Functor (Progress step fail) where-  fmap f (Step s p) = Step s (fmap f p)-  fmap _ (Fail x)   = Fail x-  fmap f (Done r)   = Done (f r)+step :: step -> Progress step fail ()+step s = Step s (Done ())  -- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two -- base cases, one for a final result and one for failure.@@ -31,18 +30,21 @@ -- foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)              -> Progress step fail done -> a-foldProgress step fail done = fold-  where fold (Step s p) = step s (fold p)-        fold (Fail f)   = fail f-        fold (Done r)   = done r+foldProgress step' fail' done' = fold+  where fold (Step s p) = step' s (fold p)+        fold (Fail f)   = fail' f+        fold (Done r)   = done' r  instance Monad (Progress step fail) where   return   = pure   p >>= f  = foldProgress Step Fail f p +instance MonadFail (Progress step String) where+  fail = Fail+ instance Applicative (Progress step fail) where   pure a  = Done a-  p <*> x = foldProgress Step Fail (flip fmap x) p+  p <*> x = foldProgress Step Fail (`fmap` x) p  instance Monoid fail => Alternative (Progress step fail) where   empty   = Fail mempty

@@ -5,16 +5,17 @@     (     -- * Project Config Path Manipulation       ProjectConfigPath(..)+    , compareLexicographically+    , compareSegmentally     , projectConfigPathRoot     , nullProjectConfigPath     , consProjectConfigPath     , unconsProjectConfigPath+    , currentProjectConfigPath      -- * Messages     , docProjectConfigPath-    , docProjectConfigFiles-    , cyclicalImportMsg-    , untrimmedUriImportMsg+    , docProjectImportedBy     , docProjectConfigPathFailReason     , quoteUntrimmed @@ -42,7 +43,6 @@ import Distribution.Pretty (prettyShow, Pretty(..)) import Distribution.Utils.String (trim) import Text.PrettyPrint-import Distribution.Simple.Utils (ordNub) import Distribution.System (OS(Windows), buildOS)  -- | Path to a configuration file, either a singleton project root, or a longer@@ -57,10 +57,10 @@ -- List elements are relative to each other but once canonicalized, elements are -- relative to the directory of the project root. newtype ProjectConfigPath = ProjectConfigPath (NonEmpty FilePath)-    deriving (Eq, Show, Generic)+    deriving (Eq, Generic) -instance Pretty ProjectConfigPath where-  pretty = docProjectConfigPath+instance Pretty ProjectConfigPath where pretty = docProjectConfigPath+instance Show ProjectConfigPath where show = prettyShow  -- | Sorts URIs after local file paths and longer file paths after shorter ones -- as measured by the number of path segments. If still equal, then sorting is@@ -77,44 +77,93 @@ -- >>> let abBwd = ProjectConfigPath $ "a\\b.config" :| [] -- >>> compare abFwd abBwd -- EQ+--+-- >>> let abc = ProjectConfigPath $ "a/b/c.config" :| []+-- >>> let yz = ProjectConfigPath $ "y/z.config" :| []+-- >>> (compare abc yz, let xs = [abc, yz] in xs == sort xs)+-- (GT,False)+--+-- >>> let abc = ProjectConfigPath $ "C.config" :| ["B.config", "A.project"]+-- >>> let bcd = ProjectConfigPath $ "D.config" :| ["C.config", "B.project"]+-- >>> (compare abc bcd, let xs = [abc, bcd] in xs == sort xs)+-- (LT,True)+--+-- >>> let abc = ProjectConfigPath $ "C.config" :| ["B.config", "A.project"]+-- >>> let yz = ProjectConfigPath $ "Z.config" :| ["Y.project"]+-- >>> (compare abc yz, let xs = [abc, yz] in xs == sort xs)+-- (GT,False) instance Ord ProjectConfigPath where-    compare pa@(ProjectConfigPath (NE.toList -> as)) pb@(ProjectConfigPath (NE.toList -> bs)) =+    compare = compareSegmentally++-- | A comparison that puts projects first, URLs last and sorts the other paths+-- lexically.+compareLexicographically :: ProjectConfigPath -> ProjectConfigPath -> Ordering+compareLexicographically (ProjectConfigPath as) (ProjectConfigPath bs) =         case (as, bs) of+            -- Single element paths are projects, they should always sort first.+            (a :| [], b :| []) -> compare (splitPath a) (splitPath b)+            (_ :| [], _) -> LT+            (_, _ :| []) -> GT++            (a :| aImporters, b :| bImporters) -> case (parseAbsoluteURI a, parseAbsoluteURI b) of+                (Just ua, Just ub) -> compare ua ub P.<> compare aImporters bImporters+                (Just _, Nothing) -> GT+                (Nothing, Just _) -> LT+                (Nothing, Nothing) -> compare (splitPath a) (splitPath b) P.<> compare aImporters bImporters++-- | A comparison that puts projects first, URLs last and sorts the other paths+-- by putting longer paths after shorter ones as measured by the number of path+-- segments. If still equal, then sorting is lexical.+compareSegmentally:: ProjectConfigPath -> ProjectConfigPath -> Ordering+compareSegmentally pa@(ProjectConfigPath as) pb@(ProjectConfigPath bs) =+        case (as, bs) of             -- There should only ever be one root project path, only one path             -- with length 1. Comparing it to itself should be EQ. Don't assume             -- this though, do a comparison anyway when both sides have length             -- 1.  The root path, the project itself, should always be the first             -- path in a sorted listing.-            ([a], [b]) -> compare (splitPath a) (splitPath b)-            ([_], _) -> LT-            (_, [_]) -> GT+            (a :| [], b :| []) ->+                let aPaths = splitPath a+                    bPaths = splitPath b+                in+                    compare (length aPaths) (length bPaths)+                    P.<> compare aPaths bPaths -            (a:_, b:_) -> case (parseAbsoluteURI a, parseAbsoluteURI b) of+            (_ :| [], _) -> LT+            (_, _ :| []) -> GT++            (a :| _, b :| _) -> case (parseAbsoluteURI a, parseAbsoluteURI b) of                 (Just ua, Just ub) -> compare ua ub P.<> compare aImporters bImporters                 (Just _, Nothing) -> GT                 (Nothing, Just _) -> LT-                (Nothing, Nothing) -> compare (splitPath a) (splitPath b) P.<> compare aImporters bImporters-            _ ->-                compare (length as) (length bs)-                P.<> compare (length aPaths) (length bPaths)-                P.<> compare aPaths bPaths+                (Nothing, Nothing) ->+                    let aPaths = splitPath a+                        bPaths = splitPath b+                    in+                        compare (length as) (length bs)+                        P.<> compare asPaths bsPaths+                        P.<> compare (length aPaths) (length bPaths)+                        P.<> compare aPaths bPaths+                        P.<> compare aImporters bImporters         where-            splitPath = FP.splitPath . normSep where-                normSep p =-                    if buildOS == Windows-                        then-                            Windows.joinPath $ Windows.splitDirectories-                            [if Posix.isPathSeparator c then Windows.pathSeparator else c| c <- p]-                        else-                            Posix.joinPath $ Posix.splitDirectories-                            [if Windows.isPathSeparator c then Posix.pathSeparator else c| c <- p]--            aPaths = splitPath <$> as-            bPaths = splitPath <$> bs+            asPaths = splitPath <$> as+            bsPaths = splitPath <$> bs             aImporters = snd $ unconsProjectConfigPath pa             bImporters = snd $ unconsProjectConfigPath pb +splitPath :: FilePath -> [FilePath]+splitPath = FP.splitPath . normSep+    where+        normSep p =+            if buildOS == Windows then+                Windows.joinPath $ Windows.splitDirectories+                [if Posix.isPathSeparator c then Windows.pathSeparator else c| c <- p]+            else+                Posix.joinPath $ Posix.splitDirectories+                [if Windows.isPathSeparator c then Posix.pathSeparator else c| c <- p]+ instance Binary ProjectConfigPath+instance NFData ProjectConfigPath instance Structured ProjectConfigPath  -- | Renders the path like this;@@ -131,66 +180,16 @@ docProjectConfigPath (ProjectConfigPath (p :| ps)) = vcat $ quoteUntrimmed p :     [ text " " <+> text "imported by:" <+> quoteUntrimmed l | l <- ps ] +-- | Render the paths which imports this config.+docProjectImportedBy :: ProjectConfigPath -> Doc+docProjectImportedBy (ProjectConfigPath (_ :| [])) = text ""+docProjectImportedBy (ProjectConfigPath (_ :| ps)) = vcat $+    [ text " " <+> text "imported by:" <+> quoteUntrimmed l | l <- ps ]+ -- | If the path has leading or trailing spaces then show it quoted. quoteUntrimmed :: FilePath -> Doc quoteUntrimmed s = if trim s /= s then quotes (text s) else text s --- | Renders the paths as a list without showing which path imports another,--- like this;------ >- cabal.project--- >- project-cabal/constraints.config--- >- project-cabal/ghc-latest.config--- >- project-cabal/ghc-options.config--- >- project-cabal/pkgs.config--- >- project-cabal/pkgs/benchmarks.config--- >- project-cabal/pkgs/buildinfo.config--- >- project-cabal/pkgs/cabal.config--- >- project-cabal/pkgs/install.config--- >- project-cabal/pkgs/integration-tests.config--- >- project-cabal/pkgs/tests.config--------- >>> :{---   do---     let ps =---              [ ProjectConfigPath ("cabal.project" :| [])---              , ProjectConfigPath ("project-cabal/constraints.config" :| ["cabal.project"])---              , ProjectConfigPath ("project-cabal/ghc-latest.config" :| ["cabal.project"])---              , ProjectConfigPath ("project-cabal/ghc-options.config" :| ["cabal.project"])---              , ProjectConfigPath ("project-cabal/pkgs.config" :| ["cabal.project"])---              , ProjectConfigPath ("project-cabal/pkgs/benchmarks.config" :| ["project-cabal/pkgs.config","cabal.project"])---              , ProjectConfigPath ("project-cabal/pkgs/buildinfo.config" :| ["project-cabal/pkgs.config","cabal.project"])---              , ProjectConfigPath ("project-cabal/pkgs/cabal.config" :| ["project-cabal/pkgs.config","cabal.project"])---              , ProjectConfigPath ("project-cabal/pkgs/install.config" :| ["project-cabal/pkgs.config","cabal.project"])---              , ProjectConfigPath ("project-cabal/pkgs/integration-tests.config" :| ["project-cabal/pkgs.config","cabal.project"])---              , ProjectConfigPath ("project-cabal/pkgs/tests.config" :| ["project-cabal/pkgs.config","cabal.project"])---              ]---     return . render $ docProjectConfigFiles ps--- :}--- "- cabal.project\n- project-cabal/constraints.config\n- project-cabal/ghc-latest.config\n- project-cabal/ghc-options.config\n- project-cabal/pkgs.config\n- project-cabal/pkgs/benchmarks.config\n- project-cabal/pkgs/buildinfo.config\n- project-cabal/pkgs/cabal.config\n- project-cabal/pkgs/install.config\n- project-cabal/pkgs/integration-tests.config\n- project-cabal/pkgs/tests.config"-docProjectConfigFiles :: [ProjectConfigPath] -> Doc-docProjectConfigFiles ps = vcat-    [ text "-" <+> text p-    | p <- ordNub [ p | ProjectConfigPath (p :| _) <- ps ]-    ]---- | A message for a cyclical import, a "cyclical import of".-cyclicalImportMsg :: ProjectConfigPath -> Doc-cyclicalImportMsg path@(ProjectConfigPath (duplicate :| _)) =-    vcat-    [ text "cyclical import of" <+> text duplicate <> semi-    , nest 2 (docProjectConfigPath path)-    ]---- | A message for an import that has leading or trailing spaces.-untrimmedUriImportMsg :: Doc -> ProjectConfigPath -> Doc-untrimmedUriImportMsg intro path =-    vcat-    [ intro <+> text "import has leading or trailing whitespace" <> semi-    , nest 2 (docProjectConfigPath path)-    ]- docProjectConfigPathFailReason :: VR -> ProjectConfigPath -> Doc docProjectConfigPathFailReason vr pcp     | ProjectConfigPath (p :| []) <- pcp =@@ -236,6 +235,9 @@ -- | Split the path into the importee and the importer path. unconsProjectConfigPath :: ProjectConfigPath -> (FilePath, Maybe ProjectConfigPath) unconsProjectConfigPath ps = fmap ProjectConfigPath <$> NE.uncons (coerce ps)++currentProjectConfigPath :: ProjectConfigPath -> FilePath+currentProjectConfigPath (ProjectConfigPath (p :| _)) = p  -- | Make paths relative to the directory of the root of the project, not -- relative to the file they were imported from.

@@ -17,6 +17,7 @@ import Distribution.Compat.Graph (IsNode(..)) import Distribution.Package (Package(..), HasUnitId(..)) import Distribution.Simple.Utils (ordNub)+import Data.Foldable (fold)  -- | The dependency resolver picks either pre-existing installed packages -- or it picks source packages along with package configuration.@@ -48,5 +49,5 @@   nodeKey (Configured spkg) = PlannedId (packageId spkg)   -- Use dependencies for ALL components   nodeNeighbors pkg =-    ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) ++-             CD.flatDeps (resolverPackageExeDeps pkg)+    ordNub $ fold (resolverPackageLibDeps pkg) +++             fold (resolverPackageExeDeps pkg)

@@ -95,6 +95,18 @@ instance Structured OnlyConstrained instance Structured SolveExecutables +instance NFData ReorderGoals+instance NFData CountConflicts+instance NFData FineGrainedConflicts+instance NFData IndependentGoals+instance NFData PreferOldest+instance NFData MinimizeConflictSet+instance NFData AvoidReinstalls+instance NFData ShadowPkgs+instance NFData StrongFlags+instance NFData AllowBootLibInstalls+instance NFData OnlyConstrained+ instance Pretty OnlyConstrained where   pretty OnlyConstrainedAll  = PP.text "all"   pretty OnlyConstrainedNone = PP.text "none"@@ -105,3 +117,26 @@     , P.string "none" >> return OnlyConstrainedNone     ] +instance Parsec ReorderGoals where+  parsec = ReorderGoals <$> parsec++instance Parsec CountConflicts where+  parsec = CountConflicts <$> parsec++instance Parsec FineGrainedConflicts where+  parsec = FineGrainedConflicts <$> parsec++instance Parsec MinimizeConflictSet where+  parsec = MinimizeConflictSet <$> parsec++instance Parsec StrongFlags where+  parsec = StrongFlags <$> parsec++instance Parsec AllowBootLibInstalls where+  parsec = AllowBootLibInstalls <$> parsec++instance Parsec PreferOldest where+  parsec = PreferOldest <$> parsec++instance Parsec IndependentGoals where+  parsec = IndependentGoals <$> parsec

@@ -0,0 +1,48 @@+module Distribution.Solver.Types.SummarizedMessage+    ( Entry(..)+    , EntryAtLevel(..)+    , SummarizedMessage(..)+    ) where++import Prelude ()+import Distribution.Solver.Compat.Prelude hiding (fail)++import Distribution.Solver.Modular.Tree+    ( FailReason(..), POption(..) )+import Distribution.Solver.Types.PackagePath ( QPN )+import Distribution.Solver.Modular.Flag ( QSN, QFN )+import Distribution.Solver.Modular.Dependency+    ( ConflictSet, QGoalReason, GoalReason )+import qualified Distribution.Solver.Modular.ConflictSet as CS++-- The following types are used to encode log messages from the+-- dependency solver so they can be easily displayed in the module+-- `Distribution.Solver.Modular.Message`.+--+--  These types are an intermediate representation of the solver log.+-- The log is converted from a list of Message to a list of+-- SummarizedMessage to a list of String. Message is very similar to+-- the structure of the search tree but difficult to read, and+-- SummarizedMessage has the structure that is shown to users.++-- Encoding of solver messages.+data Entry+  = EntryPackageGoal QPN QGoalReason+  | EntryRejectF QFN Bool ConflictSet FailReason+  | EntryRejectS QSN Bool ConflictSet FailReason+  | EntrySkipping (Set CS.Conflict)+  | EntryTryingF QFN Bool+  | EntryTryingP QPN POption+  | EntryTryingNewP QPN POption (GoalReason QPN)+  | EntryTryingS QSN Bool+  | EntryRejectMany QPN [POption] ConflictSet FailReason+  | EntrySkipMany QPN [POption] (Set CS.Conflict)+  | EntryUnknownPackage QPN (GoalReason QPN)+  | EntrySuccess+  | EntryFailure ConflictSet FailReason++-- Encode the level at which the solver message occurred.+data EntryAtLevel = AtLevel Int Entry++-- Messages from the solver.+data SummarizedMessage = SummarizedMsg EntryAtLevel | StringMsg String