From adce9a355687c83d472f710103e844a78ecb510d Mon Sep 17 00:00:00 2001 From: Yvan Sraka Date: Tue, 25 Jul 2023 11:43:42 +0200 Subject: [PATCH] [WIP] Fix #4251: Solver "rejecting" message is too verbose --- .../src/Distribution/Solver/Modular.hs | 44 ++++-- .../Distribution/Solver/Modular/Message.hs | 128 ++++++++++++++---- 2 files changed, 127 insertions(+), 45 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index 2aac240318f..91b2ae64300 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular.hs +++ b/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. diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs index 73580aff3e6..7707358cd55 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs +++ b/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 ++ ")"