From 11ae2f8e2388fbd8940a5dadc30c7748dd959678 Mon Sep 17 00:00:00 2001 From: Yvan Sraka Date: Mon, 16 Oct 2023 18:28:53 +0200 Subject: [PATCH] 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 544ad59a341..9b267e3cabd 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -160,6 +160,7 @@ import Data.List ) import qualified Data.Map as Map import qualified Data.Set as Set +import Distribution.Solver.Modular.Message (SolverTrace) -- ------------------------------------------------------------ @@ -770,32 +771,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 @@ -824,6 +826,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