From b20ea537f7eee5058a50204e2e16856233052613 Mon Sep 17 00:00:00 2001
From: Yvan Sraka <yvan@sraka.xyz>
Date: Mon, 16 Oct 2023 18:28:53 +0200
Subject: [PATCH 1/3] Refactor cabal-install solver config log output

---
 .../src/Distribution/Solver/Modular.hs        |  46 +++---
 .../src/Distribution/Solver/Modular/Log.hs    |   4 +-
 .../Distribution/Solver/Modular/Message.hs    | 148 +++++++++++++-----
 .../Solver/Types/DependencyResolver.hs        |   3 +-
 .../src/Distribution/Client/Dependency.hs     |  57 ++++---
 5 files changed, 171 insertions(+), 87 deletions(-)

diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs
index 2aac240318f..9e949358ae7 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs
@@ -54,7 +54,7 @@ import Distribution.Simple.Setup
 import Distribution.Simple.Utils
          ( ordNubBy )
 import Distribution.Verbosity
-
+import Distribution.Solver.Modular.Message (SolverTrace (..))
 
 -- | Ties the two worlds together: classic cabal-install vs. the modular
 -- solver. Performs the necessary translations before and after.
@@ -120,25 +120,25 @@ solve' :: SolverConfig
        -> (PN -> PackagePreferences)
        -> Map PN [LabeledPackageConstraint]
        -> Set PN
-       -> Progress String String (Assignment, RevDepMap)
+       -> Progress SolverTrace String (Assignment, RevDepMap)
 solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
-    toProgress $ retry (runSolver printFullLog sc) createErrorMsg
+    toProgress $ retry (runSolver printFullLog sc) handleFailure
   where
     runSolver :: Bool -> SolverConfig
-              -> RetryLog String SolverFailure (Assignment, RevDepMap)
+              -> RetryLog SolverTrace SolverFailure (Assignment, RevDepMap)
     runSolver keepLog sc' =
         displayLogMessages keepLog $
         solve sc' cinfo idx pkgConfigDB pprefs gcs pns
 
-    createErrorMsg :: SolverFailure
-                   -> RetryLog String String (Assignment, RevDepMap)
-    createErrorMsg failure@(ExhaustiveSearch cs cm) =
+    handleFailure :: SolverFailure
+                   -> RetryLog SolverTrace String (Assignment, RevDepMap)
+    handleFailure failure@(ExhaustiveSearch cs _cm) =
       if asBool $ minimizeConflictSet sc
-      then continueWith ("Found no solution after exhaustively searching the "
+      then continueWith (mkErrorMsg ("Found no solution after exhaustively searching the "
                           ++ "dependency tree. Rerunning the dependency solver "
                           ++ "to minimize the conflict set ({"
-                          ++ showConflictSet cs ++ "}).") $
-           retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) $
+                          ++ showConflictSet cs ++ "}).")) $
+           retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs _cm) $
                \case
                   ExhaustiveSearch cs' cm' ->
                       fromProgress $ Fail $
@@ -151,13 +151,13 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
                        ++ "Original error message:\n"
                        ++ rerunSolverForErrorMsg cs
                        ++ finalErrorMsg sc failure
-      else fromProgress $ Fail $
-           rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure
-    createErrorMsg failure@BackjumpLimitReached     =
+      else
+        fromProgress $ Fail $ rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure
+    handleFailure failure@BackjumpLimitReached     =
         continueWith
-             ("Backjump limit reached. Rerunning dependency solver to generate "
+             (mkErrorMsg ("Backjump limit reached. Rerunning dependency solver to generate "
               ++ "a final conflict set for the search tree containing the "
-              ++ "first backjump.") $
+              ++ "first backjump.")) $
         retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $
             \case
                ExhaustiveSearch cs _ ->
@@ -181,13 +181,16 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
           -- 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 show (messages (toProgress (runSolver True sc'))))
 
     printFullLog = solverVerbosity sc >= verbose
 
     messages :: Progress step fail done -> [step]
     messages = foldProgress (:) (const []) (const [])
 
+mkErrorMsg :: String -> SolverTrace
+mkErrorMsg msg = ErrorMsg msg
+
 -- | Try to remove variables from the given conflict set to create a minimal
 -- conflict set.
 --
@@ -219,13 +222,13 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
 --    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 SolverTrace SolverFailure a)
                          -> SolverConfig
                          -> ConflictSet
                          -> ConflictMap
-                         -> RetryLog String SolverFailure a
+                         -> RetryLog SolverTrace SolverFailure a
 tryToMinimizeConflictSet runSolver sc cs cm =
-    foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v)
+    foldl (\r v -> retryMap mkErrorMsg $ retryNoSolution (retryMap show r) $ tryToRemoveOneVar v)
           (fromProgress $ Fail $ ExhaustiveSearch cs cm)
           (CS.toList cs)
   where
@@ -258,7 +261,7 @@ tryToMinimizeConflictSet runSolver sc cs cm =
       | otherwise =
         continueWith ("Trying to remove variable " ++ varStr ++ " from the "
                       ++ "conflict set.") $
-        retry (runSolver sc') $ \case
+        retry (retryMap show $ runSolver sc') $ \case
             err@(ExhaustiveSearch cs' _)
               | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS ->
                   let msg = if not $ CS.member v cs'
@@ -297,6 +300,9 @@ tryToMinimizeConflictSet runSolver sc cs cm =
         ExhaustiveSearch cs' cm' -> f cs' cm'
         BackjumpLimitReached     -> fromProgress (Fail BackjumpLimitReached)
 
+    retryMap :: (t -> step) -> RetryLog t fail done -> RetryLog step fail done
+    retryMap f l = fromProgress $ (\p -> foldProgress (\x xs -> Step (f x) xs) Fail Done p) $ toProgress l
+
 -- | Goal ordering that chooses goals contained in the conflict set before
 -- other goals.
 preferGoalsFromConflictSet :: ConflictSet
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs
index 321a051070b..ccb3448c741 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs
@@ -22,10 +22,10 @@ data SolverFailure =
 -- 'keepLog'), for efficiency.
 displayLogMessages :: Bool
                    -> RetryLog Message SolverFailure a
-                   -> RetryLog String SolverFailure a
+                   -> RetryLog SolverTrace SolverFailure a
 displayLogMessages keepLog lg = fromProgress $
     if keepLog
-    then showMessages progress
+    then groupMessages progress
     else foldProgress (const id) Fail Done progress
   where
     progress = toProgress lg
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
index 73580aff3e6..620ac09d008 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
@@ -2,7 +2,8 @@
 
 module Distribution.Solver.Modular.Message (
     Message(..),
-    showMessages
+    SolverTrace(..),
+    groupMessages,
   ) where
 
 import qualified Data.List as L
@@ -41,51 +42,130 @@ data Message =
   | Success
   | Failure ConflictSet FailReason
 
+data Log
+  = PackageGoal QPN QGoalReason
+  | RejectF QFN Bool ConflictSet FailReason
+  | RejectS QSN Bool ConflictSet FailReason
+  | Skipping' (Set CS.Conflict)
+  | TryingF QFN Bool
+  | TryingP QPN POption (Maybe (GoalReason QPN))
+  | TryingS QSN Bool
+  | RejectMany QPN [POption] ConflictSet FailReason
+  | SkipMany QPN [POption] (Set CS.Conflict)
+  | UnknownPackage' QPN (GoalReason QPN)
+  | SuccessMsg
+  | FailureMsg ConflictSet FailReason
+
+data AtLevel a = AtLevel Int a
+
+type Trace = AtLevel Log
+
+data SolverTrace = SolverTrace Trace | ErrorMsg String
+
+instance Show SolverTrace where
+    show (SolverTrace i) = displayMessageAtLevel i
+    show (ErrorMsg s) = show s
+
+instance Show Log where
+    show = displayMessage
+
+displayMessageAtLevel :: Trace -> String
+displayMessageAtLevel (AtLevel l msg) =
+  let s = show l
+  in  "[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ displayMessage msg
+
+displayMessage :: Log -> String
+displayMessage (PackageGoal qpn gr) = "next goal: " ++ showQPN qpn ++ showGR gr
+displayMessage (RejectF qfn b c fr) = "rejecting: " ++ showQFNBool qfn b ++ showFR c fr
+displayMessage (RejectS qsn b c fr) = "rejecting: " ++ showQSNBool qsn b ++ showFR c fr
+displayMessage (Skipping' cs) = showConflicts cs
+displayMessage (TryingF qfn b) = "trying: " ++ showQFNBool qfn b
+displayMessage (TryingP qpn i mgr) = "trying: " ++ showQPNPOpt qpn i ++ maybe "" showGR mgr
+displayMessage (TryingS qsn b) = "trying: " ++ showQSNBool qsn b
+displayMessage (UnknownPackage' qpn gr) = "unknown package" ++ showQPN qpn ++ showGR gr
+displayMessage SuccessMsg = "done"
+displayMessage (FailureMsg c fr) = "fail: " ++ showFR c fr
+displayMessage (SkipMany _ _ cs) = "skipping: " ++ showConflicts cs
+-- TODO: Instead of displaying `aeson-1.0.2.1, aeson-1.0.2.0, aeson-1.0.1.0, ...`,
+-- the following line aim to display `aeson: 1.0.2.1, 1.0.2.0, 1.0.1.0, ...`.
+--
+-- displayMessage (RejectMany qpn is c fr) = "rejecting: " ++ fmtPkgsGroupedByName (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr
+displayMessage (RejectMany qpn is c fr) = "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr
+
+-- TODO: This function should take as input the Index? So even without calling the solver, We can say things as
+-- "There is no version in the Hackage index that match the given constraints".
+--
+-- Alternatively, by passing this to the solver, we could get a more semantic output like:
+-- `all versions of aeson available are in conflict with ...`. Isn't already what `tryToMinimizeConflictSet` is doing?
+-- fmtPkgsGroupedByName :: [String] -> String
+-- fmtPkgsGroupedByName pkgs = L.intercalate " " $ fmtPkgGroup (groupByName pkgs)
+--   where
+--     groupByName :: [String] -> Map.Map String [String]
+--     groupByName = foldr f Map.empty
+--       where
+--         f versionString m = let (pkg, ver) = splitOnLastHyphen versionString
+--                             in Map.insertWith (++) pkg [ver] m
+--         -- FIXME: This is not a very robust way to split the package name and version.
+--         -- I should rather retrieve the package name and version from the QPN ...
+--         splitOnLastHyphen :: String -> (String, String)
+--         splitOnLastHyphen s =
+--             case reverse (L.elemIndices '-' s) of
+--                 (x:_)  -> (take x s, drop (x + 1) s)
+--                 _ -> error "splitOnLastHyphen: no hyphen found"
+
+--     fmtPkgGroup :: Map.Map String [String] -> [String]
+--     fmtPkgGroup = map formatEntry . Map.toList
+--       where
+--         formatEntry (pkg, versions) = pkg ++ ": " ++ L.intercalate ", " versions
+
 -- | Transforms the structured message type to actual messages (strings).
 --
 -- 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
+groupMessages :: Progress Message a b -> Progress SolverTrace a b
+groupMessages = 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 SolverTrace 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 $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms)
+        Step (SolverTrace $ AtLevel l $ (RejectF qfn b c fr)) (go l ms)
+
     go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
-        (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms)
+        Step (SolverTrace $ AtLevel l $ (RejectS 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 $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms)
+        Step (SolverTrace $ AtLevel l $ (TryingP qpn' i (Just 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 (SolverTrace $ AtLevel l $ (UnknownPackage' 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 $ "trying: " ++ showQPNPOpt qpn i) (go l ms)
-    go !l (Step (TryF qfn b)             ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms)
-    go !l (Step (TryS qsn b)             ms) = (atLevel l $ "trying: " ++ showQSNBool 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 $ "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
-
-    showFailure :: ConflictSet -> FailReason -> String
-    showFailure c fr = "fail" ++ showFR c fr
+
+    go !l (Step (TryP qpn i)             ms) = Step (SolverTrace $ AtLevel l $ (TryingP qpn i Nothing)) (go l ms)
+    go !l (Step (TryF qfn b)             ms) = Step (SolverTrace $ AtLevel l $ (TryingF qfn b)) (go l ms)
+    go !l (Step (TryS qsn b)             ms) = Step (SolverTrace $ AtLevel l $ (TryingS qsn b)) (go l ms)
+    go !l (Step (Next (Goal (P qpn) gr)) ms) = Step (SolverTrace $ AtLevel l $ (PackageGoal qpn gr)) (go l ms)
+    go !l (Step (Next _)                 ms) = go l ms -- ignore flag goals in the log
+
+    -- 'Skip' should always be handled by 'goPSkip' in the case above.
+    go !l (Step (Skip conflicts)         ms) = Step (SolverTrace $ AtLevel l $ (Skipping' conflicts)) (go l ms)
+    go !l (Step (Success)                ms) = Step (SolverTrace $ AtLevel l $ SuccessMsg) (go l ms)
+    go !l (Step (Failure c fr)           ms) = Step (SolverTrace $ AtLevel l $ (FailureMsg c fr)) (go l ms)
 
     -- special handler for many subsequent package rejections
     goPReject :: Int
@@ -94,11 +174,12 @@ showMessages = go 0
               -> ConflictSet
               -> FailReason
               -> Progress Message a b
-              -> Progress String a b
+              -> Progress SolverTrace a b
     goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))
-      | qpn == qpn' && fr == fr' = goPReject l qpn (i : is) c fr ms
+      | qpn == qpn' && fr == fr' =
+        goPReject l qpn (i : is) c fr ms
     goPReject l qpn is c fr ms =
-        (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms)
+        Step (SolverTrace $ AtLevel l $ (RejectMany qpn is c fr)) (go l ms)
 
     -- Handle many subsequent skipped package instances.
     goPSkip :: Int
@@ -106,20 +187,11 @@ showMessages = go 0
             -> [POption]
             -> Set CS.Conflict
             -> Progress Message a b
-            -> Progress String a b
+            -> Progress SolverTrace a b
     goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms))))
       | qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms
     goPSkip l qpn is conflicts ms =
-      let msg = "skipping: "
-                 ++ L.intercalate ", " (map (showQPNPOpt 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 (SolverTrace $ AtLevel l $ (SkipMany qpn is conflicts)) (go l ms)
 
 -- | Display the set of 'Conflicts' for a skipped package version.
 showConflicts :: Set CS.Conflict -> String
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs
index e773492ae74..954df49e3cc 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs
@@ -17,6 +17,7 @@ import Distribution.Simple.PackageIndex ( InstalledPackageIndex )
 import Distribution.Package ( PackageName )
 import Distribution.Compiler ( CompilerInfo )
 import Distribution.System ( Platform )
+import Distribution.Solver.Modular.Message ( SolverTrace )
 
 -- | A dependency resolver is a function that works out an installation plan
 -- given the set of installed and available packages and a set of deps to
@@ -34,4 +35,4 @@ type DependencyResolver loc = Platform
                            -> (PackageName -> PackagePreferences)
                            -> [LabeledPackageConstraint]
                            -> Set PackageName
-                           -> Progress String String [ResolverPackage loc]
+                           -> Progress SolverTrace String [ResolverPackage loc]
diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs
index 37e0cbdf1ee..f7eab87f7a3 100644
--- a/cabal-install/src/Distribution/Client/Dependency.hs
+++ b/cabal-install/src/Distribution/Client/Dependency.hs
@@ -159,6 +159,7 @@ import Data.List
   )
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import Distribution.Solver.Modular.Message (SolverTrace)
 
 -- ------------------------------------------------------------
 
@@ -769,32 +770,33 @@ resolveDependencies
 resolveDependencies platform comp pkgConfigDB params =
   Step (showDepResolverParams finalparams) $
     fmap (validateSolverResult platform comp indGoals) $
-      runSolver
-        ( SolverConfig
-            reordGoals
-            cntConflicts
-            fineGrained
-            minimize
-            indGoals
-            noReinstalls
-            shadowing
-            strFlags
-            onlyConstrained_
-            maxBkjumps
-            enableBj
-            solveExes
-            order
-            verbosity
-            (PruneAfterFirstSuccess False)
-        )
-        platform
-        comp
-        installedPkgIndex
-        sourcePkgIndex
-        pkgConfigDB
-        preferences
-        constraints
-        targets
+      formatProgress $
+        runSolver
+          ( SolverConfig
+              reordGoals
+              cntConflicts
+              fineGrained
+              minimize
+              indGoals
+              noReinstalls
+              shadowing
+              strFlags
+              onlyConstrained_
+              maxBkjumps
+              enableBj
+              solveExes
+              order
+              verbosity
+              (PruneAfterFirstSuccess False)
+          )
+          platform
+          comp
+          installedPkgIndex
+          sourcePkgIndex
+          pkgConfigDB
+          preferences
+          constraints
+          targets
   where
     finalparams@( DepResolverParams
                     targets
@@ -823,6 +825,9 @@ resolveDependencies platform comp pkgConfigDB params =
           then params
           else dontInstallNonReinstallablePackages params
 
+    formatProgress :: Progress SolverTrace String a -> Progress String String a
+    formatProgress p = foldProgress (\x xs -> Step (show x) xs) Fail Done p
+
     preferences :: PackageName -> PackagePreferences
     preferences = interpretPackagesPreference targets defpref prefs
 

From f10dbcf7872927622250f25b463bb608882737a9 Mon Sep 17 00:00:00 2001
From: Yvan Sraka <yvan@sraka.xyz>
Date: Tue, 5 Dec 2023 22:38:54 +0100
Subject: [PATCH 2/3] Apply some of @grayjay and @mpickering comments

---
 .../src/Distribution/Solver/Modular.hs        |  79 ++++----
 .../src/Distribution/Solver/Modular/Log.hs    |  12 +-
 .../Distribution/Solver/Modular/Message.hs    | 173 +++++++-----------
 .../Solver/Types/DependencyResolver.hs        |  11 +-
 .../src/Distribution/Solver/Types/Progress.hs |  41 +++++
 .../src/Distribution/Client/Dependency.hs     | 120 +++++++++---
 6 files changed, 263 insertions(+), 173 deletions(-)

diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs
index 9e949358ae7..2837d683386 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs
@@ -18,43 +18,60 @@ import Distribution.Solver.Compat.Prelude
 import qualified Data.Map as M
 import Data.Set (isSubsetOf)
 import Distribution.Compat.Graph
-         ( IsNode(..) )
+    ( IsNode(..) )
 import Distribution.Compiler
-         ( CompilerInfo )
+    ( CompilerInfo )
 import Distribution.Solver.Modular.Assignment
-         ( Assignment, toCPs )
+    ( Assignment, toCPs )
 import Distribution.Solver.Modular.ConfiguredConversion
-         ( convCP )
+    ( 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 )
+    ( convPIs )
 import Distribution.Solver.Modular.Log
-         ( SolverFailure(..), displayLogMessages )
+    ( SolverFailure(..), displayLogMessages )
 import Distribution.Solver.Modular.Package
-         ( PN )
+    ( PN )
 import Distribution.Solver.Modular.RetryLog
+    ( RetryLog,
+      toProgress,
+      fromProgress,
+      retry,
+      failWith,
+      continueWith )
 import Distribution.Solver.Modular.Solver
-         ( SolverConfig(..), PruneAfterFirstSuccess(..), solve )
+    ( 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 )
+    ( PkgConfigDb )
 import Distribution.Solver.Types.Progress
-import Distribution.Solver.Types.Variable
+    ( Progress(..), foldProgress, SummarizedMessage(ErrorMsg) )
+import Distribution.Solver.Types.Variable ( Variable(..) )
 import Distribution.System
-         ( Platform(..) )
+    ( Platform(..) )
 import Distribution.Simple.Setup
-         ( BooleanFlag(..) )
+    ( BooleanFlag(..) )
 import Distribution.Simple.Utils
-         ( ordNubBy )
-import Distribution.Verbosity
-import Distribution.Solver.Modular.Message (SolverTrace (..))
+    ( 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.
@@ -120,19 +137,19 @@ solve' :: SolverConfig
        -> (PN -> PackagePreferences)
        -> Map PN [LabeledPackageConstraint]
        -> Set PN
-       -> Progress SolverTrace String (Assignment, RevDepMap)
+       -> Progress SummarizedMessage String (Assignment, RevDepMap)
 solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
-    toProgress $ retry (runSolver printFullLog sc) handleFailure
+    toProgress $ retry (runSolver printFullLog sc) createErrorMsg
   where
     runSolver :: Bool -> SolverConfig
-              -> RetryLog SolverTrace SolverFailure (Assignment, RevDepMap)
+              -> RetryLog SummarizedMessage SolverFailure (Assignment, RevDepMap)
     runSolver keepLog sc' =
         displayLogMessages keepLog $
         solve sc' cinfo idx pkgConfigDB pprefs gcs pns
 
-    handleFailure :: SolverFailure
-                   -> RetryLog SolverTrace String (Assignment, RevDepMap)
-    handleFailure failure@(ExhaustiveSearch cs _cm) =
+    createErrorMsg :: SolverFailure
+                   -> RetryLog SummarizedMessage String (Assignment, RevDepMap)
+    createErrorMsg failure@(ExhaustiveSearch cs _cm) =
       if asBool $ minimizeConflictSet sc
       then continueWith (mkErrorMsg ("Found no solution after exhaustively searching the "
                           ++ "dependency tree. Rerunning the dependency solver "
@@ -153,7 +170,7 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
                        ++ finalErrorMsg sc failure
       else
         fromProgress $ Fail $ rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure
-    handleFailure failure@BackjumpLimitReached     =
+    createErrorMsg failure@BackjumpLimitReached     =
         continueWith
              (mkErrorMsg ("Backjump limit reached. Rerunning dependency solver to generate "
               ++ "a final conflict set for the search tree containing the "
@@ -181,14 +198,14 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
           -- original goal order.
           goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc)
 
-      in unlines ("Could not resolve dependencies:" : map show (messages (toProgress (runSolver True sc'))))
+      in unlines ("Could not resolve dependencies:" : map renderSummarizedMessage (messages (toProgress (runSolver True sc'))))
 
     printFullLog = solverVerbosity sc >= verbose
 
     messages :: Progress step fail done -> [step]
     messages = foldProgress (:) (const []) (const [])
 
-mkErrorMsg :: String -> SolverTrace
+mkErrorMsg :: String -> SummarizedMessage
 mkErrorMsg msg = ErrorMsg msg
 
 -- | Try to remove variables from the given conflict set to create a minimal
@@ -222,13 +239,13 @@ mkErrorMsg msg = ErrorMsg msg
 --    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 SolverTrace SolverFailure a)
+tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog SummarizedMessage SolverFailure a)
                          -> SolverConfig
                          -> ConflictSet
                          -> ConflictMap
-                         -> RetryLog SolverTrace SolverFailure a
+                         -> RetryLog SummarizedMessage SolverFailure a
 tryToMinimizeConflictSet runSolver sc cs cm =
-    foldl (\r v -> retryMap mkErrorMsg $ retryNoSolution (retryMap show r) $ tryToRemoveOneVar v)
+    foldl (\r v -> retryMap mkErrorMsg $ retryNoSolution (retryMap renderSummarizedMessage r) $ tryToRemoveOneVar v)
           (fromProgress $ Fail $ ExhaustiveSearch cs cm)
           (CS.toList cs)
   where
@@ -261,7 +278,7 @@ tryToMinimizeConflictSet runSolver sc cs cm =
       | otherwise =
         continueWith ("Trying to remove variable " ++ varStr ++ " from the "
                       ++ "conflict set.") $
-        retry (retryMap show $ runSolver sc') $ \case
+        retry (retryMap renderSummarizedMessage $ runSolver sc') $ \case
             err@(ExhaustiveSearch cs' _)
               | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS ->
                   let msg = if not $ CS.member v cs'
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs
index ccb3448c741..64365d8ffc0 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs
@@ -7,10 +7,12 @@ import Prelude ()
 import Distribution.Solver.Compat.Prelude
 
 import Distribution.Solver.Types.Progress
-
-import Distribution.Solver.Modular.Dependency
-import Distribution.Solver.Modular.Message
+    ( Progress(Done, Fail), foldProgress, SummarizedMessage, Message )
+import Distribution.Solver.Modular.ConflictSet
+    ( ConflictMap, ConflictSet )
 import Distribution.Solver.Modular.RetryLog
+    ( RetryLog, toProgress, fromProgress )
+import Distribution.Solver.Modular.Message (summarizeMessages)
 
 -- | Information about a dependency solver failure.
 data SolverFailure =
@@ -22,10 +24,10 @@ data SolverFailure =
 -- 'keepLog'), for efficiency.
 displayLogMessages :: Bool
                    -> RetryLog Message SolverFailure a
-                   -> RetryLog SolverTrace SolverFailure a
+                   -> RetryLog SummarizedMessage SolverFailure a
 displayLogMessages keepLog lg = fromProgress $
     if keepLog
-    then groupMessages progress
+    then summarizeMessages progress
     else foldProgress (const id) Fail Done progress
   where
     progress = toProgress lg
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
index 620ac09d008..def4b0915c1 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
@@ -1,9 +1,11 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE InstanceSigs #-}
 
 module Distribution.Solver.Modular.Message (
     Message(..),
-    SolverTrace(..),
-    groupMessages,
+    SummarizedMessage(..),
+    summarizeMessages,
+    renderSummarizedMessage,
   ) where
 
 import qualified Data.List as L
@@ -14,121 +16,80 @@ import qualified Data.Set as S
 import Data.Maybe (catMaybes, mapMaybe)
 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
+    ( Var(P),
+      ConflictSet,
+      showConflictSet,
+      QGoalReason,
+      GoalReason(DependencyGoal, UserGoal),
+      Goal(Goal),
+      DependencyReason(DependencyReason),
+      ExposedComponent(..),
+      PkgComponent(PkgComponent),
+      CI(Constrained, Fixed),
+      showDependencyReason )
 import Distribution.Solver.Modular.Flag
+    ( 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
+    ( Progress(..),
+      SummarizedMessage(..),
+      EntryMsg(..),
+      Entry(..),
+      Message(..) )
 import Distribution.Types.LibraryName
+    ( LibraryName(LSubLibName, LMainLibName) )
 import Distribution.Types.UnqualComponentName
+    ( unUnqualComponentName )
 
-data Message =
-    Enter           -- ^ increase indentation level
-  | Leave           -- ^ decrease indentation level
-  | TryP QPN POption
-  | TryF QFN Bool
-  | TryS QSN Bool
-  | Next (Goal QPN)
-  | Skip (Set CS.Conflict)
-  | Success
-  | Failure ConflictSet FailReason
+renderSummarizedMessage :: SummarizedMessage -> String
+renderSummarizedMessage (SummarizedMsg i) = displayMessageAtLevel i
+renderSummarizedMessage (ErrorMsg s) = s
 
-data Log
-  = PackageGoal QPN QGoalReason
-  | RejectF QFN Bool ConflictSet FailReason
-  | RejectS QSN Bool ConflictSet FailReason
-  | Skipping' (Set CS.Conflict)
-  | TryingF QFN Bool
-  | TryingP QPN POption (Maybe (GoalReason QPN))
-  | TryingS QSN Bool
-  | RejectMany QPN [POption] ConflictSet FailReason
-  | SkipMany QPN [POption] (Set CS.Conflict)
-  | UnknownPackage' QPN (GoalReason QPN)
-  | SuccessMsg
-  | FailureMsg ConflictSet FailReason
-
-data AtLevel a = AtLevel Int a
-
-type Trace = AtLevel Log
-
-data SolverTrace = SolverTrace Trace | ErrorMsg String
-
-instance Show SolverTrace where
-    show (SolverTrace i) = displayMessageAtLevel i
-    show (ErrorMsg s) = show s
-
-instance Show Log where
-    show = displayMessage
-
-displayMessageAtLevel :: Trace -> String
+displayMessageAtLevel :: EntryMsg -> String
 displayMessageAtLevel (AtLevel l msg) =
   let s = show l
   in  "[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ displayMessage msg
 
-displayMessage :: Log -> String
-displayMessage (PackageGoal qpn gr) = "next goal: " ++ showQPN qpn ++ showGR gr
-displayMessage (RejectF qfn b c fr) = "rejecting: " ++ showQFNBool qfn b ++ showFR c fr
-displayMessage (RejectS qsn b c fr) = "rejecting: " ++ showQSNBool qsn b ++ showFR c fr
-displayMessage (Skipping' cs) = showConflicts cs
-displayMessage (TryingF qfn b) = "trying: " ++ showQFNBool qfn b
-displayMessage (TryingP qpn i mgr) = "trying: " ++ showQPNPOpt qpn i ++ maybe "" showGR mgr
-displayMessage (TryingS qsn b) = "trying: " ++ showQSNBool qsn b
-displayMessage (UnknownPackage' qpn gr) = "unknown package" ++ showQPN qpn ++ showGR gr
-displayMessage SuccessMsg = "done"
-displayMessage (FailureMsg c fr) = "fail: " ++ showFR c fr
-displayMessage (SkipMany _ _ cs) = "skipping: " ++ showConflicts cs
--- TODO: Instead of displaying `aeson-1.0.2.1, aeson-1.0.2.0, aeson-1.0.1.0, ...`,
--- the following line aim to display `aeson: 1.0.2.1, 1.0.2.0, 1.0.1.0, ...`.
---
--- displayMessage (RejectMany qpn is c fr) = "rejecting: " ++ fmtPkgsGroupedByName (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr
-displayMessage (RejectMany qpn is c fr) = "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr
-
--- TODO: This function should take as input the Index? So even without calling the solver, We can say things as
--- "There is no version in the Hackage index that match the given constraints".
---
--- Alternatively, by passing this to the solver, we could get a more semantic output like:
--- `all versions of aeson available are in conflict with ...`. Isn't already what `tryToMinimizeConflictSet` is doing?
--- fmtPkgsGroupedByName :: [String] -> String
--- fmtPkgsGroupedByName pkgs = L.intercalate " " $ fmtPkgGroup (groupByName pkgs)
---   where
---     groupByName :: [String] -> Map.Map String [String]
---     groupByName = foldr f Map.empty
---       where
---         f versionString m = let (pkg, ver) = splitOnLastHyphen versionString
---                             in Map.insertWith (++) pkg [ver] m
---         -- FIXME: This is not a very robust way to split the package name and version.
---         -- I should rather retrieve the package name and version from the QPN ...
---         splitOnLastHyphen :: String -> (String, String)
---         splitOnLastHyphen s =
---             case reverse (L.elemIndices '-' s) of
---                 (x:_)  -> (take x s, drop (x + 1) s)
---                 _ -> error "splitOnLastHyphen: no hyphen found"
-
---     fmtPkgGroup :: Map.Map String [String] -> [String]
---     fmtPkgGroup = map formatEntry . Map.toList
---       where
---         formatEntry (pkg, versions) = pkg ++ ": " ++ L.intercalate ", " versions
-
--- | Transforms the structured message type to actual messages (strings).
+displayMessage :: Entry -> String
+displayMessage (LogPackageGoal qpn gr) = "next goal: " ++ showQPN qpn ++ showGR gr
+displayMessage (LogRejectF qfn b c fr) = "rejecting: " ++ showQFNBool qfn b ++ showFR c fr
+displayMessage (LogRejectS qsn b c fr) = "rejecting: " ++ showQSNBool qsn b ++ showFR c fr
+displayMessage (LogSkipping cs) = "skipping: " ++ showConflicts cs
+displayMessage (LogTryingF qfn b) = "trying: " ++ showQFNBool qfn b
+displayMessage (LogTryingP qpn i mgr) = "trying: " ++ showQPNPOpt qpn i ++ maybe "" showGR mgr
+displayMessage (LogTryingS qsn b) = "trying: " ++ showQSNBool qsn b
+displayMessage (LogUnknownPackage qpn gr) = "unknown package" ++ showQPN qpn ++ showGR gr
+displayMessage LogSuccessMsg = "done"
+displayMessage (LogFailureMsg c fr) = "fail: " ++ showFR c fr
+displayMessage (LogSkipMany _ _ cs) = "skipping: " ++ showConflicts cs
+displayMessage (LogRejectMany qpn is c fr) = "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr
+
+-- | Transforms the structured message type to actual messages (SummarizedMsg 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.
-groupMessages :: Progress Message a b -> Progress SolverTrace a b
-groupMessages = 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 SolverTrace a b
+    go :: Int -> Progress Message a b -> Progress SummarizedMessage a b
     go !_ (Done x)                           = Done x
     go !_ (Fail x)                           = Fail x
 
@@ -140,32 +101,32 @@ groupMessages = go 0
         goPSkip l qpn [i] conflicts ms
 
     go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
-        Step (SolverTrace $ AtLevel l $ (RejectF qfn b c fr)) (go l ms)
+        Step (SummarizedMsg $ AtLevel l $ (LogRejectF qfn b c fr)) (go l ms)
 
     go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
-        Step (SolverTrace $ AtLevel l $ (RejectS qsn b c fr)) (go l ms)
+        Step (SummarizedMsg $ AtLevel l $ (LogRejectS 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 _) _)))) =
-        Step (SolverTrace $ AtLevel l $ (TryingP qpn' i (Just gr))) (go l ms)
+        Step (SummarizedMsg $ AtLevel l $ (LogTryingP qpn' i (Just gr))) (go l ms)
 
     go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) =
-        Step (SolverTrace $ AtLevel l $ (UnknownPackage' qpn gr)) (go l ms)
+        Step (SummarizedMsg $ AtLevel l $ (LogUnknownPackage 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) = Step (SolverTrace $ AtLevel l $ (TryingP qpn i Nothing)) (go l ms)
-    go !l (Step (TryF qfn b)             ms) = Step (SolverTrace $ AtLevel l $ (TryingF qfn b)) (go l ms)
-    go !l (Step (TryS qsn b)             ms) = Step (SolverTrace $ AtLevel l $ (TryingS qsn b)) (go l ms)
-    go !l (Step (Next (Goal (P qpn) gr)) ms) = Step (SolverTrace $ AtLevel l $ (PackageGoal qpn gr)) (go l ms)
+    go !l (Step (TryP qpn i)             ms) = Step (SummarizedMsg $ AtLevel l $ (LogTryingP qpn i Nothing)) (go l ms)
+    go !l (Step (TryF qfn b)             ms) = Step (SummarizedMsg $ AtLevel l $ (LogTryingF qfn b)) (go l ms)
+    go !l (Step (TryS qsn b)             ms) = Step (SummarizedMsg $ AtLevel l $ (LogTryingS qsn b)) (go l ms)
+    go !l (Step (Next (Goal (P qpn) gr)) ms) = Step (SummarizedMsg $ AtLevel l $ (LogPackageGoal qpn gr)) (go l ms)
     go !l (Step (Next _)                 ms) = go l ms -- ignore flag goals in the log
 
     -- 'Skip' should always be handled by 'goPSkip' in the case above.
-    go !l (Step (Skip conflicts)         ms) = Step (SolverTrace $ AtLevel l $ (Skipping' conflicts)) (go l ms)
-    go !l (Step (Success)                ms) = Step (SolverTrace $ AtLevel l $ SuccessMsg) (go l ms)
-    go !l (Step (Failure c fr)           ms) = Step (SolverTrace $ AtLevel l $ (FailureMsg c fr)) (go l ms)
+    go !l (Step (Skip conflicts)         ms) = Step (SummarizedMsg $ AtLevel l $ (LogSkipping conflicts)) (go l ms)
+    go !l (Step (Success)                ms) = Step (SummarizedMsg $ AtLevel l $ LogSuccessMsg) (go l ms)
+    go !l (Step (Failure c fr)           ms) = Step (SummarizedMsg $ AtLevel l $ (LogFailureMsg c fr)) (go l ms)
 
     -- special handler for many subsequent package rejections
     goPReject :: Int
@@ -174,12 +135,12 @@ groupMessages = go 0
               -> ConflictSet
               -> FailReason
               -> Progress Message a b
-              -> Progress SolverTrace 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' =
         goPReject l qpn (i : is) c fr ms
     goPReject l qpn is c fr ms =
-        Step (SolverTrace $ AtLevel l $ (RejectMany qpn is c fr)) (go l ms)
+        Step (SummarizedMsg $ AtLevel l $ (LogRejectMany qpn is c fr)) (go l ms)
 
     -- Handle many subsequent skipped package instances.
     goPSkip :: Int
@@ -187,11 +148,11 @@ groupMessages = go 0
             -> [POption]
             -> Set CS.Conflict
             -> Progress Message a b
-            -> Progress SolverTrace 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' = goPSkip l qpn (i : is) conflicts ms
     goPSkip l qpn is conflicts ms =
-       Step (SolverTrace $ AtLevel l $ (SkipMany qpn is conflicts)) (go l ms)
+       Step (SummarizedMsg $ AtLevel l $ (LogSkipMany qpn is conflicts)) (go l ms)
 
 -- | Display the set of 'Conflicts' for a skipped package version.
 showConflicts :: Set CS.Conflict -> String
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs
index 954df49e3cc..82742821ecb 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs
@@ -2,22 +2,25 @@ module Distribution.Solver.Types.DependencyResolver
     ( DependencyResolver
     ) where
 
-import Distribution.Solver.Compat.Prelude
+import Distribution.Solver.Compat.Prelude ( 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, SummarizedMessage )
 import Distribution.Solver.Types.ResolverPackage
-import Distribution.Solver.Types.SourcePackage
+    ( ResolverPackage )
+import Distribution.Solver.Types.SourcePackage ( SourcePackage )
 
 import Distribution.Simple.PackageIndex ( InstalledPackageIndex )
 import Distribution.Package ( PackageName )
 import Distribution.Compiler ( CompilerInfo )
 import Distribution.System ( Platform )
-import Distribution.Solver.Modular.Message ( SolverTrace )
 
 -- | A dependency resolver is a function that works out an installation plan
 -- given the set of installed and available packages and a set of deps to
@@ -35,4 +38,4 @@ type DependencyResolver loc = Platform
                            -> (PackageName -> PackagePreferences)
                            -> [LabeledPackageConstraint]
                            -> Set PackageName
-                           -> Progress SolverTrace String [ResolverPackage loc]
+                           -> Progress SummarizedMessage String [ResolverPackage loc]
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs b/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs
index a47e651d1c4..3cfe82e258f 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs
@@ -1,11 +1,23 @@
 module Distribution.Solver.Types.Progress
     ( Progress(..)
     , foldProgress
+    , Message(..)
+    , Entry(..)
+    , EntryMsg(..)
+    , 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, Goal )
+import qualified Distribution.Solver.Modular.ConflictSet as CS
+
 -- | A type to represent the unfolding of an expensive long running
 -- calculation that may fail. We may get intermediate steps before the final
 -- result which may be used to indicate progress and\/or logging messages.
@@ -47,3 +59,32 @@ instance Applicative (Progress step fail) where
 instance Monoid fail => Alternative (Progress step fail) where
   empty   = Fail mempty
   p <|> q = foldProgress Step (const q) Done p
+
+data Message =
+    Enter           -- ^ increase indentation level
+  | Leave           -- ^ decrease indentation level
+  | TryP QPN POption
+  | TryF QFN Bool
+  | TryS QSN Bool
+  | Next (Goal QPN)
+  | Skip (Set CS.Conflict)
+  | Success
+  | Failure ConflictSet FailReason
+
+data Entry
+  = LogPackageGoal QPN QGoalReason
+  | LogRejectF QFN Bool ConflictSet FailReason
+  | LogRejectS QSN Bool ConflictSet FailReason
+  | LogSkipping (Set CS.Conflict)
+  | LogTryingF QFN Bool
+  | LogTryingP QPN POption (Maybe (GoalReason QPN))
+  | LogTryingS QSN Bool
+  | LogRejectMany QPN [POption] ConflictSet FailReason
+  | LogSkipMany QPN [POption] (Set CS.Conflict)
+  | LogUnknownPackage QPN (GoalReason QPN)
+  | LogSuccessMsg
+  | LogFailureMsg ConflictSet FailReason
+
+data EntryMsg = AtLevel Int Entry
+
+data SummarizedMessage = SummarizedMsg EntryMsg | ErrorMsg String
diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs
index f7eab87f7a3..98b822b0f80 100644
--- a/cabal-install/src/Distribution/Client/Dependency.hs
+++ b/cabal-install/src/Distribution/Client/Dependency.hs
@@ -68,27 +68,41 @@ module Distribution.Client.Dependency
 
 import Distribution.Client.Compat.Prelude
 
+import Control.Exception
+  ( assert
+  )
+import Data.List
+  ( maximumBy
+  )
+import qualified Data.Map as Map
+import qualified Data.Set as Set
 import Distribution.Client.Dependency.Types
   ( PackagesPreferenceDefault (..)
   )
 import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
 import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
-import Distribution.Client.Types
+import Distribution.Client.Types.AllowNewer
   ( AllowNewer (..)
   , AllowOlder (..)
-  , PackageSpecifier (..)
   , RelaxDepMod (..)
   , RelaxDepScope (..)
   , RelaxDepSubject (..)
   , RelaxDeps (..)
   , RelaxedDep (..)
-  , SourcePackageDb (SourcePackageDb)
-  , UnresolvedPkgLoc
-  , UnresolvedSourcePackage
   , isRelaxDeps
+  )
+import Distribution.Client.Types.PackageLocation
+  ( UnresolvedPkgLoc
+  , UnresolvedSourcePackage
+  )
+import Distribution.Client.Types.PackageSpecifier
+  ( PackageSpecifier (..)
   , pkgSpecifierConstraints
   , pkgSpecifierTarget
   )
+import Distribution.Client.Types.SourcePackageDb
+  ( SourcePackageDb (SourcePackageDb)
+  )
 import Distribution.Client.Utils
   ( MergeResult (..)
   , duplicatesBy
@@ -122,44 +136,96 @@ import Distribution.Solver.Modular
   , SolverConfig (..)
   , modularResolver
   )
-import Distribution.System
-  ( Platform
-  )
-import Distribution.Types.Dependency
-import Distribution.Verbosity
-  ( normal
-  )
-import Distribution.Version
-
+import Distribution.Solver.Modular.Message (renderSummarizedMessage)
 import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
 import qualified Distribution.Solver.Types.ComponentDeps as CD
 import Distribution.Solver.Types.ConstraintSource
+  ( ConstraintSource
+      ( ConstraintSetupCabalMaxVersion
+      , ConstraintSetupCabalMinVersion
+      , ConstraintSourceNonReinstallablePackage
+      )
+  , showConstraintSource
+  )
 import Distribution.Solver.Types.DependencyResolver
+  ( DependencyResolver
+  )
 import Distribution.Solver.Types.InstalledPreference as Preference
+  ( InstalledPreference (..)
+  )
 import Distribution.Solver.Types.LabeledPackageConstraint
+  ( LabeledPackageConstraint (..)
+  , unlabelPackageConstraint
+  )
 import Distribution.Solver.Types.OptionalStanza
+  ( OptionalStanza
+  , enableStanzas
+  )
 import Distribution.Solver.Types.PackageConstraint
+  ( ConstraintScope (ScopeAnyQualifier, ScopeAnySetupQualifier)
+  , PackageConstraint (..)
+  , PackageProperty (..)
+  , scopeToPackageName
+  , scopeToplevel
+  , showPackageConstraint
+  )
 import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
-import Distribution.Solver.Types.PackagePath
+import Distribution.Solver.Types.PackagePath (QPN)
 import Distribution.Solver.Types.PackagePreferences
+  ( PackagePreferences (..)
+  )
 import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
 import Distribution.Solver.Types.Progress
+  ( Progress (..)
+  , SummarizedMessage
+  , foldProgress
+  )
 import Distribution.Solver.Types.ResolverPackage
+  ( ResolverPackage (Configured)
+  )
 import Distribution.Solver.Types.Settings
-import Distribution.Solver.Types.SolverId
+  ( AllowBootLibInstalls (..)
+  , AvoidReinstalls (..)
+  , CountConflicts (..)
+  , EnableBackjumping (..)
+  , FineGrainedConflicts (..)
+  , IndependentGoals (..)
+  , MinimizeConflictSet (..)
+  , OnlyConstrained (OnlyConstrainedNone)
+  , ReorderGoals (..)
+  , ShadowPkgs (..)
+  , SolveExecutables (..)
+  , StrongFlags (..)
+  )
+import Distribution.Solver.Types.SolverId (SolverId (solverSrcId))
 import Distribution.Solver.Types.SolverPackage
+  ( SolverPackage (SolverPackage)
+  )
 import Distribution.Solver.Types.SourcePackage
-import Distribution.Solver.Types.Variable
-
-import Control.Exception
-  ( assert
+  ( SourcePackage (srcpkgDescription)
   )
-import Data.List
-  ( maximumBy
+import Distribution.Solver.Types.Variable (Variable)
+import Distribution.System
+  ( Platform
+  )
+import Distribution.Types.Dependency (Dependency (..), mainLibSet)
+import Distribution.Verbosity
+  ( normal
+  )
+import Distribution.Version
+  ( Version
+  , VersionRange
+  , anyVersion
+  , earlierVersion
+  , mkVersion
+  , orLaterVersion
+  , removeLowerBound
+  , removeUpperBound
+  , simplifyVersionRange
+  , transformCaretLower
+  , transformCaretUpper
+  , withinRange
   )
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import Distribution.Solver.Modular.Message (SolverTrace)
 
 -- ------------------------------------------------------------
 
@@ -825,8 +891,8 @@ resolveDependencies platform comp pkgConfigDB params =
           then params
           else dontInstallNonReinstallablePackages params
 
-    formatProgress :: Progress SolverTrace String a -> Progress String String a
-    formatProgress p = foldProgress (\x xs -> Step (show x) xs) Fail Done p
+    formatProgress :: Progress SummarizedMessage String a -> Progress String String a
+    formatProgress p = foldProgress (\x xs -> Step (renderSummarizedMessage x) xs) Fail Done p
 
     preferences :: PackageName -> PackagePreferences
     preferences = interpretPackagesPreference targets defpref prefs

From e4775b426c8aac4229509b51f98cc0f024c60478 Mon Sep 17 00:00:00 2001
From: Yvan Sraka <yvan@sraka.xyz>
Date: Tue, 5 Dec 2023 22:38:54 +0100
Subject: [PATCH 3/3] Fix #4251

---
 .../Distribution/Solver/Modular/Message.hs    | 31 ++++++++++++++++++-
 1 file changed, 30 insertions(+), 1 deletion(-)

diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
index def4b0915c1..7481ef93513 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
@@ -77,7 +77,36 @@ displayMessage (LogUnknownPackage qpn gr) = "unknown package" ++ showQPN qpn ++
 displayMessage LogSuccessMsg = "done"
 displayMessage (LogFailureMsg c fr) = "fail: " ++ showFR c fr
 displayMessage (LogSkipMany _ _ cs) = "skipping: " ++ showConflicts cs
-displayMessage (LogRejectMany qpn is c fr) = "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr
+-- Instead of displaying `aeson-1.0.2.1, aeson-1.0.2.0, aeson-1.0.1.0, ...`,
+-- the following line aim to display `aeson: 1.0.2.1, 1.0.2.0, 1.0.1.0, ...`.
+--
+displayMessage (LogRejectMany qpn is c fr) = "rejecting: " ++ fmtPkgsGroupedByName (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr
+
+-- TODO: This function should take as input the Index? So even without calling the solver, We can say things as
+-- "There is no version in the Hackage index that match the given constraints".
+--
+-- Alternatively, by passing this to the solver, we could get a more semantic output like:
+-- `all versions of aeson available are in conflict with ...`. Isn't already what `tryToMinimizeConflictSet` is doing?
+fmtPkgsGroupedByName :: [String] -> String
+fmtPkgsGroupedByName pkgs = L.intercalate " " $ fmtPkgGroup (groupByName pkgs)
+  where
+    groupByName :: [String] -> M.Map String [String]
+    groupByName = foldr f M.empty
+      where
+        f versionString m = let (pkg, ver) = splitOnLastHyphen versionString
+                            in M.insertWith (++) pkg [ver] m
+        -- FIXME: This is not a very robust way to split the package name and version.
+        -- I should rather retrieve the package name and version from the QPN ...
+        splitOnLastHyphen :: String -> (String, String)
+        splitOnLastHyphen s =
+            case reverse (L.elemIndices '-' s) of
+                (x:_)  -> (take x s, drop (x + 1) s)
+                _ -> error "splitOnLastHyphen: no hyphen found"
+
+    fmtPkgGroup :: M.Map String [String] -> [String]
+    fmtPkgGroup = map formatEntry . M.toList
+      where
+        formatEntry (pkg, versions) = pkg ++ ": " ++ L.intercalate ", " versions
 
 -- | Transforms the structured message type to actual messages (SummarizedMsg s).
 --