{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Solver.Modular
( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) where
-- Here, we try to map between the external cabal-install solver
-- interface and the internal interface that the solver actually
-- expects. There are a number of type conversions to perform: we
-- have to convert the package indices to the uniform index used
-- by the solver; we also have to convert the initial constraints;
-- and finally, we have to convert back the resulting install
-- plan.
import Prelude ()
import Distribution.Solver.Compat.Prelude
import qualified Data.Map as M
import Data.Set (Set, isSubsetOf)
import Data.Ord
import Distribution.Compat.Graph
( IsNode(..) )
import Distribution.Compiler
( CompilerInfo )
import Distribution.Solver.Modular.Assignment
( Assignment, toCPs )
import Distribution.Solver.Modular.ConfiguredConversion
( convCP )
import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.Index
import Distribution.Solver.Modular.IndexConversion
( convPIs )
import Distribution.Solver.Modular.Log
( SolverFailure(..), displayLogMessages )
import Distribution.Solver.Modular.Package
( PN )
import Distribution.Solver.Modular.RetryLog
import Distribution.Solver.Modular.Solver
( SolverConfig(..), PruneAfterFirstSuccess(..), solve )
import Distribution.Solver.Types.DependencyResolver
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.PackageConstraint
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.PackagePreferences
import Distribution.Solver.Types.PkgConfigDb
( PkgConfigDb )
import Distribution.Solver.Types.Progress
import Distribution.Solver.Types.Variable
import Distribution.System
( Platform(..) )
import Distribution.Simple.Setup
( BooleanFlag(..) )
import Distribution.Simple.Utils
( ordNubBy )
import Distribution.Verbosity
-- | Ties the two worlds together: classic cabal-install vs. the modular
-- solver. Performs the necessary translations before and after.
modularResolver :: SolverConfig -> DependencyResolver loc
modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =
fmap (uncurry postprocess) $ -- convert install plan
solve' sc cinfo idx pkgConfigDB pprefs gcs pns
where
-- Indices have to be converted into solver-specific uniform index.
idx = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx
-- Constraints have to be converted into a finite map indexed by PN.
gcs = M.fromListWith (++) (map pair pcs)
where
pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc])
-- Results have to be converted into an install plan. 'convCP' removes
-- package qualifiers, which means that linked packages become duplicates
-- and can be removed.
postprocess a rdm = ordNubBy nodeKey $
map (convCP iidx sidx) (toCPs a rdm)
-- Helper function to extract the PN from a constraint.
pcName :: PackageConstraint -> PN
pcName (PackageConstraint scope _) = scopeToPackageName scope
-- | Run 'D.S.Modular.Solver.solve' and then produce a summarized log to display
-- in the error case.
--
-- When there is no solution, we produce the error message by rerunning the
-- solver but making it prefer the goals from the final conflict set from the
-- first run (or a subset of the final conflict set with
-- --minimize-conflict-set). We also set the backjump limit to 0, so that the
-- log stops at the first backjump and is relatively short. Preferring goals
-- from the final conflict set increases the probability that the log to the
-- first backjump contains package, flag, and stanza choices that are relevant
-- to the final failure. The solver shouldn't need to choose any packages that
-- aren't in the final conflict set. (For every variable in the final conflict
-- set, the final conflict set should also contain the variable that introduced
-- that variable. The solver can then follow that chain of variables in reverse
-- order from the user target to the conflict.) However, it is possible that the
-- conflict set contains unnecessary variables.
--
-- Producing an error message when the solver reaches the backjump limit is more
-- complicated. There is no final conflict set, so we create one for the minimal
-- subtree containing the path that the solver took to the first backjump. This
-- conflict set helps explain why the solver reached the backjump limit, because
-- the first backjump contributes to reaching the backjump limit. Additionally,
-- the solver is much more likely to be able to finish traversing this subtree
-- before the backjump limit, since its size is linear (not exponential) in the
-- number of goal choices. We create it by pruning all children after the first
-- successful child under each node in the original tree, so that there is at
-- most one valid choice at each level. Then we use the final conflict set from
-- that run to generate an error message, as in the case where the solver found
-- that there was no solution.
--
-- Using the full log from a rerun of the solver ensures that the log is
-- complete, i.e., it shows the whole chain of dependencies from the user
-- targets to the conflicting packages.
solve' :: SolverConfig
-> CompilerInfo
-> Index
-> PkgConfigDb
-> (PN -> PackagePreferences)
-> Map PN [LabeledPackageConstraint]
-> Set PN
-> Progress String String (Assignment, RevDepMap)
solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
toProgress $ retry (runSolver printFullLog sc) createErrorMsg
where
runSolver :: Bool -> SolverConfig
-> RetryLog String 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) =
if asBool $ minimizeConflictSet sc
then continueWith ("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) $
\case
ExhaustiveSearch cs' cm' ->
fromProgress $ Fail $
rerunSolverForErrorMsg cs'
++ finalErrorMsg sc (ExhaustiveSearch cs' cm')
BackjumpLimitReached ->
fromProgress $ Fail $
"Reached backjump limit while trying to minimize the "
++ "conflict set to create a better error message. "
++ "Original error message:\n"
++ rerunSolverForErrorMsg cs
++ finalErrorMsg sc failure
else fromProgress $ Fail $
rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure
createErrorMsg failure@BackjumpLimitReached =
continueWith
("Backjump limit reached. Rerunning dependency solver to generate "
++ "a final conflict set for the search tree containing the "
++ "first backjump.") $
retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $
\case
ExhaustiveSearch cs _ ->
fromProgress $ Fail $
rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure
BackjumpLimitReached ->
-- This case is possible when the number of goals involved in
-- conflicts is greater than the backjump limit.
fromProgress $ Fail $ finalErrorMsg sc failure
++ "Failed to generate a summarized dependency solver "
++ "log due to low backjump limit."
rerunSolverForErrorMsg :: ConflictSet -> String
rerunSolverForErrorMsg cs =
let sc' = sc {
goalOrder = Just goalOrder'
, maxBackjumps = Just 0
}
-- 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')))
printFullLog = solverVerbosity sc >= verbose
messages :: Progress step fail done -> [step]
messages = foldProgress (:) (const []) (const [])
-- | Try to remove variables from the given conflict set to create a minimal
-- conflict set.
--
-- Minimal means that no proper subset of the conflict set is also a conflict
-- set, though there may be other possible conflict sets with fewer variables.
-- This function minimizes the input by trying to remove one variable at a time.
-- It only makes one pass over the variables, so it runs the solver at most N
-- times when given a conflict set of size N. Only one pass is necessary,
-- because every superset of a conflict set is also a conflict set, meaning that
-- failing to remove variable X from a conflict set in one step means that X
-- cannot be removed from any subset of that conflict set in a subsequent step.
--
-- Example steps:
--
-- Start with {A, B, C}.
-- Try to remove A from {A, B, C} and fail.
-- Try to remove B from {A, B, C} and succeed.
-- Try to remove C from {A, C} and fail.
-- Return {A, C}
--
-- This function can fail for two reasons:
--
-- 1. The solver can reach the backjump limit on any run. In this case the
-- returned RetryLog ends with BackjumpLimitReached.
-- TODO: Consider applying the backjump limit to all solver runs combined,
-- instead of each individual run. For example, 10 runs with 10 backjumps
-- each should count as 100 backjumps.
-- 2. Since this function works by rerunning the solver, it is possible for the
-- 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)
-> SolverConfig
-> ConflictSet
-> ConflictMap
-> RetryLog String SolverFailure a
tryToMinimizeConflictSet runSolver sc cs cm =
foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v)
(fromProgress $ Fail $ ExhaustiveSearch cs cm)
(CS.toList cs)
where
-- This function runs the solver and makes it prefer goals in the following
-- order:
--
-- 1. variables in 'smallestKnownCS', excluding 'v'
-- 2. 'v'
-- 3. all other variables
--
-- If 'v' is not necessary, then the solver will find that there is no
-- solution before starting to solve for 'v', and the new final conflict set
-- will be very likely to not contain 'v'. If 'v' is necessary, the solver
-- will most likely need to try solving for 'v' before finding that there is
-- no solution, and the new final conflict set will still contain 'v'.
-- However, this method isn't perfect, because it is possible for the solver
-- to add new unnecessary variables to the conflict set on any run. This
-- function prevents the conflict set from growing by checking that the new
-- conflict set is a subset of the old one and falling back to using the old
-- conflict set when that check fails.
tryToRemoveOneVar :: Var QPN
-> ConflictSet
-> ConflictMap
-> RetryLog String SolverFailure a
tryToRemoveOneVar v smallestKnownCS smallestKnownCM
-- Check whether v is still present, because it may have already been
-- removed in a previous solver rerun.
| not (v `CS.member` smallestKnownCS) =
fromProgress $ Fail $ ExhaustiveSearch smallestKnownCS smallestKnownCM
| otherwise =
continueWith ("Trying to remove variable " ++ varStr ++ " from the "
++ "conflict set.") $
retry (runSolver sc') $ \case
err@(ExhaustiveSearch cs' _)
| CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS ->
let msg = if not $ CS.member v cs'
then "Successfully removed " ++ varStr ++ " from "
++ "the conflict set."
else "Failed to remove " ++ varStr ++ " from the "
++ "conflict set."
in -- Use the new conflict set, even if v wasn't removed,
-- because other variables may have been removed.
failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err
| otherwise ->
failWith ("Failed to find a smaller conflict set. The new "
++ "conflict set is not a subset of the previous "
++ "conflict set: " ++ showCS cs') $
ExhaustiveSearch smallestKnownCS smallestKnownCM
BackjumpLimitReached ->
failWith ("Reached backjump limit while minimizing conflict set.")
BackjumpLimitReached
where
varStr = "\"" ++ showVar v ++ "\""
showCS cs' = "{" ++ showConflictSet cs' ++ "}"
sc' = sc { goalOrder = Just goalOrder' }
goalOrder' =
preferGoalsFromConflictSet (v `CS.delete` smallestKnownCS)
<> preferGoal v
<> fromMaybe mempty (goalOrder sc)
-- Like 'retry', except that it only applies the input function when the
-- backjump limit has not been reached.
retryNoSolution :: RetryLog step SolverFailure done
-> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done)
-> RetryLog step SolverFailure done
retryNoSolution lg f = retry lg $ \case
ExhaustiveSearch cs' cm' -> f cs' cm'
BackjumpLimitReached -> fromProgress (Fail BackjumpLimitReached)
-- | Goal ordering that chooses goals contained in the conflict set before
-- other goals.
preferGoalsFromConflictSet :: ConflictSet
-> Variable QPN -> Variable QPN -> Ordering
preferGoalsFromConflictSet cs = comparing $ \v -> not $ CS.member (toVar v) cs
-- | Goal ordering that chooses the given goal first.
preferGoal :: Var QPN -> Variable QPN -> Variable QPN -> Ordering
preferGoal preferred = comparing $ \v -> toVar v /= preferred
toVar :: Variable QPN -> Var QPN
toVar (PackageVar qpn) = P qpn
toVar (FlagVar qpn fn) = F (FN qpn fn)
toVar (StanzaVar qpn sn) = S (SN qpn sn)
finalErrorMsg :: SolverConfig -> SolverFailure -> String
finalErrorMsg sc failure =
case failure of
ExhaustiveSearch cs cm ->
"After searching the rest of the dependency tree exhaustively, "
++ "these were the goals I've had most trouble fulfilling: "
++ showCS cm cs
++ flagSuggestion
where
showCS = if solverVerbosity sc > normal
then CS.showCSWithFrequency
else CS.showCSSortedByFrequency
flagSuggestion =
-- Don't suggest --minimize-conflict-set if the conflict set is
-- already small, because it is unlikely to be reduced further.
if CS.size cs > 3 && not (asBool (minimizeConflictSet sc))
then "\nTry running with --minimize-conflict-set to improve the "
++ "error message."
else ""
BackjumpLimitReached ->
"Backjump limit reached (" ++ currlimit (maxBackjumps sc) ++
"change with --max-backjumps or try to run with --reorder-goals).\n"
where currlimit (Just n) = "currently " ++ show n ++ ", "
currlimit Nothing = ""