[WIP] Fix #4251: Solver "rejecting" message is too verbose

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

@@ -32,7 +32,9 @@ import Distribution.Solver.Modular.Index
 import Distribution.Solver.Modular.IndexConversion
          ( convPIs )
 import Distribution.Solver.Modular.Log
-         ( SolverFailure(..), displayLogMessages )
+         ( SolverFailure(..) )
+import Distribution.Solver.Modular.Message
+         ( showMessages )
 import Distribution.Solver.Modular.Package
          ( PN )
 import Distribution.Solver.Modular.RetryLog
@@ -127,8 +129,8 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
     runSolver :: Bool -> SolverConfig
               -> RetryLog String SolverFailure (Assignment, RevDepMap)
     runSolver keepLog sc' =
-        displayLogMessages keepLog $
-        solve sc' cinfo idx pkgConfigDB pprefs gcs pns
+      let progress = toProgress $ solve sc' cinfo idx pkgConfigDB pprefs gcs pns
+       in fromProgress $ if keepLog then showMessages progress else foldProgress (const id) Fail Done progress
 
     createErrorMsg :: SolverFailure
                    -> RetryLog String String (Assignment, RevDepMap)
@@ -170,23 +172,35 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
                     ++ "Failed to generate a summarized dependency solver "
                     ++ "log due to low backjump limit."
 
+    -- TODO: Show all backtracking by default. This is currently displayed only with `-v3' because it's too verbose and hard to decipher!
     rerunSolverForErrorMsg :: ConflictSet -> String
-    rerunSolverForErrorMsg cs =
-      let sc' = sc {
-                    goalOrder = Just goalOrder'
-                  , maxBackjumps = Just 0
-                  }
+    rerunSolverForErrorMsg cs = unlines $ "Could not resolve dependencies:" : messages ++ suggestV3 ++ suggestMinimizeCS
+      where
+        messages = toMessages $ toProgress $ runSolver True sc'
+          where
+            toMessages :: Progress step fail done -> [step]
+            toMessages = foldProgress (:) (const []) (const [])
 
-          -- Preferring goals from the conflict set takes precedence over the
-          -- original goal order.
-          goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc)
+            sc' = sc {goalOrder = Just goalOrder', maxBackjumps = Just 0}
+              where
+                -- Preferring goals from the conflict set takes precedence over the
+                -- original goal order.
+                goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc)
 
-      in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc')))
+        suggestV3 = if printFullLog
+                    then []
+                    else ["For detailed error messages, please rerun with the `-v3' flag."]
 
-    printFullLog = solverVerbosity sc >= verbose
+        suggestMinimizeCS = if asBool $ minimizeConflictSet sc
+                            then if not printFullLog
+                                 then ["Warning: you may want to use the `-v3' flag to display the `--minimize-conflict-set' output."]
+                                 else []
+                            else ["To improve the solver output, consider running with the `--minimize-conflict-set' option."]
 
-    messages :: Progress step fail done -> [step]
-    messages = foldProgress (:) (const []) (const [])
+        -- TODO: If index-state is outdated (Cabal might know, right?), then suggest running `cabal update`.
+        -- suggestCabalUpdate = ...
+
+    printFullLog = solverVerbosity sc >= verbose
 
 -- | Try to remove variables from the given conflict set to create a minimal
 -- conflict set.

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

@@ -29,6 +29,7 @@ import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.Progress
 import Distribution.Types.LibraryName
 import Distribution.Types.UnqualComponentName
+import qualified Data.Map as Map
 
 data Message =
     Enter           -- ^ increase indentation level
@@ -41,6 +42,66 @@ data Message =
   | Success
   | Failure ConflictSet FailReason
 
+data Message'
+  = 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)
+  | Success'
+  | Failure' ConflictSet FailReason
+
+-- TODO: This function should take as input the Index? So even without calling the solver, I con 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
+
+displayMessage' :: Message' -> 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' Success' = "done"
+displayMessage' (Failure' c fr) = "fail" ++ showFR c fr
+
+-- E.g. instead of displaying `aeson-1.0.2.1, aeson-1.0.2.0, aeson-1.0.1.0, ...`,
+-- aim to display `aeson: 1.0.2.1, 1.0.2.0, 1.0.1.0, ...`.
+displayMessage' (SkipMany _ _ cs) = "skipping: " ++ showConflicts cs -- Here, I'm not sure to see the point of displaying the list of packages since the constraint is already displayed (TODO: display it only in -v3 ...)
+displayMessage' (RejectMany qpn is c fr) = "rejecting: " ++ fmtPkgsGroupedByName (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr
+
+-- Optionnal: I have yet no clue of how to display the solver output as a "tree",
+-- as suggested in the proposal https://github.com/haskell/cabal/issues/8939
+
 -- | Transforms the structured message type to actual messages (strings).
 --
 -- The log contains level numbers, which are useful for any trace that involves
@@ -54,38 +115,41 @@ showMessages = go 0
     go :: Int -> Progress Message a b -> Progress String a b
     go !_ (Done x)                           = Done x
     go !_ (Fail x)                           = Fail x
+    -- TODO: I should use the the level of recursion to change the displayMessage' indentation level ...
+
     -- 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)
+        (atLevel l $ displayMessage' (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)
+        (atLevel l $ displayMessage' (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)
+        (atLevel l $ displayMessage' (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
+        (atLevel l $ displayMessage' (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) = (atLevel l $ displayMessage' (TryingP qpn i Nothing)) (go l ms)
+    go !l (Step (TryF qfn b)             ms) = (atLevel l $ displayMessage' (TryingF qfn b)) (go l ms)
+    go !l (Step (TryS qsn b)             ms) = (atLevel l $ displayMessage' (TryingS qsn b)) (go l ms)
+    go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ displayMessage' (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) = (atLevel l $ displayMessage' (Skipping' conflicts)) (go l ms)
+    go !l (Step (Success)                ms) = (atLevel l $ displayMessage' Success') (go l ms)
+    go !l (Step (Failure c fr)           ms) = (atLevel l $ displayMessage' (Failure' c fr)) (go l ms)
 
     -- special handler for many subsequent package rejections
     goPReject :: Int
@@ -96,9 +160,10 @@ showMessages = go 0
               -> Progress Message a b
               -> Progress String 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)
+        (atLevel l $ displayMessage' (RejectMany qpn is c fr)) (go l ms)
 
     -- Handle many subsequent skipped package instances.
     goPSkip :: Int
@@ -110,10 +175,7 @@ showMessages = go 0
     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)
+        (atLevel l $ displayMessage' (SkipMany qpn is conflicts)) (go l ms)
 
     -- write a message with the current level number
     atLevel :: Int -> String -> Progress String a b -> Progress String a b
@@ -124,8 +186,9 @@ showMessages = go 0
 -- | 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: "
-     ++ conflictMsg ++ ")"
+    "all other available packages. They are excluded by the same constraint that caused the last version tried to fail:\n"
+    ++ conflictMsg -- FIXME: Is this message important to highlight to user?
+     -- It's currently easy to miss...
   where
     conflictMsg :: String
     conflictMsg =
@@ -220,7 +283,7 @@ showFR :: ConflictSet -> FailReason -> String
 showFR _ (UnsupportedExtension ext)       = " (conflict: requires " ++ showUnsupportedExtension ext ++ ")"
 showFR _ (UnsupportedLanguage lang)       = " (conflict: requires " ++ showUnsupportedLanguage lang ++ ")"
 showFR _ (MissingPkgconfigPackage pn vr)  = " (conflict: pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ ", not found in the pkg-config database)"
-showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")"
+showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: new package does not match existing constraint " ++ showConflictingDep d ++ ")"
 showFR _ (ConflictingConstraints d1 d2)   = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")"
 showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")"
 showFR _ (NewPackageHasPrivateRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is private, but it is required by " ++ showDependencyReason dr ++ ")"
@@ -258,8 +321,13 @@ showExposedComponent (ExposedExe name)               = "executable '" ++ unUnqua
 constraintSource :: ConstraintSource -> String
 constraintSource src = "constraint from " ++ showConstraintSource src
 
+-- FIXME: use a ANSI formating library like ansi-terminal to achieve this?
+-- bold :: String -> String
+-- bold str = "\ESC[1m" ++ str ++ "\ESC[0m"
+--
+-- The point is to highlight the conflict in solver output:
 showConflictingDep :: ConflictingDep -> String
-showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =
+showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) = -- bold $
   let DependencyReason qpn' _ _ = dr
       componentStr = case comp of
                        ExposedExe exe               -> " (exe " ++ unUnqualComponentName exe ++ ")"