Skip to content

Commit

Permalink
[WIP] Add --json solver config arg
Browse files Browse the repository at this point in the history
This allows the cabal-install solver logs to be mechanized, e.g., similar to
the tree view provided by nix-output-monitor for Nix.
  • Loading branch information
yvan-sraka committed Oct 23, 2023
1 parent a260cde commit a564348
Show file tree
Hide file tree
Showing 5 changed files with 184 additions and 87 deletions.
46 changes: 26 additions & 20 deletions cabal-install-solver/src/Distribution/Solver/Modular.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down Expand Up @@ -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 $
Expand All @@ -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 _ ->
Expand All @@ -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.
--
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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'
Expand Down Expand Up @@ -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
Expand Down
4 changes: 2 additions & 2 deletions cabal-install-solver/src/Distribution/Solver/Modular/Log.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
148 changes: 110 additions & 38 deletions cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,8 @@

module Distribution.Solver.Modular.Message (
Message(..),
showMessages
SolverTrace(..),
groupMessages,
) where

import qualified Data.List as L
Expand Down Expand Up @@ -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
Expand All @@ -94,32 +174,24 @@ 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
-> QPN
-> [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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -34,4 +35,4 @@ type DependencyResolver loc = Platform
-> (PackageName -> PackagePreferences)
-> [LabeledPackageConstraint]
-> Set PackageName
-> Progress String String [ResolverPackage loc]
-> Progress SolverTrace String [ResolverPackage loc]
Loading

0 comments on commit a564348

Please sign in to comment.