Skip to content

Commit

Permalink
[WIP] Fix #4251: Simplify verbose "rejecting" message in solver
Browse files Browse the repository at this point in the history
This commit makes the following changes:

- Enhancements to the codebase:
  * Adds several TODO/FIXME/HELP comments, laying the groundwork for
    improved solver output as described in RFC 4251 ;
  * Refactors the `showMessages` function to split the logic of
    building the output (now as a `Message'` enumeration) and the
    string representation of it (now formatted by `displayMessage'`).

- Modifications to the solver output:
  * If the `-v3` or `--minimize-conflict-set` flags are not set, it
    now prompts the user to consider using them in cases of the
    "Could not resolve dependencies: ..." error ;
  * The message "(has the same characteristics that caused the
    previous version to fail: ...)" has been rephrased to
    "all other available packages. They are excluded due to the same
    constraint that caused the last version attempted to fail: ..." ;
  * Package lists are now grouped by name. For example, instead of
    displaying `aeson-1.0.2.1, aeson-1.0.2.0, aeson-1.0.1.0, ...`, it
    now shows `aeson: 1.0.2.1, 1.0.2.0, 1.0.1.0, ...`.
  • Loading branch information
yvan-sraka committed Aug 29, 2023
1 parent 747af13 commit 84700a2
Show file tree
Hide file tree
Showing 2 changed files with 130 additions and 45 deletions.
46 changes: 31 additions & 15 deletions cabal-install-solver/src/Distribution/Solver/Modular.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -170,23 +172,37 @@ 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."]

-- TODO: If index-state is outdated (Cabal might know, right?), then suggest running `cabal update`.
-- suggestCabalUpdate = ...

messages :: Progress step fail done -> [step]
messages = foldProgress (:) (const []) (const [])
-- HELP: where can I fould this info?

printFullLog = solverVerbosity sc >= verbose

-- | Try to remove variables from the given conflict set to create a minimal
-- conflict set.
Expand Down
129 changes: 99 additions & 30 deletions cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -41,6 +42,67 @@ 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
-- HELP: How to pass the verbosity level to this function?

-- 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
Expand All @@ -54,38 +116,42 @@ 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
Expand All @@ -96,9 +162,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
Expand All @@ -110,10 +177,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
Expand All @@ -124,8 +188,8 @@ 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 =
Expand Down Expand Up @@ -220,7 +284,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 ++ ")"
Expand Down Expand Up @@ -258,8 +322,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 would be 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 ++ ")"
Expand Down

0 comments on commit 84700a2

Please sign in to comment.