cabal-install-solver/src/Distribution/Solver/Modular.hs

   1 {-# LANGUAGE LambdaCase #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3
   4 module Distribution.Solver.Modular
   5          ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) where
   6
   7 -- Here, we try to map between the external cabal-install solver
   8 -- interface and the internal interface that the solver actually
   9 -- expects. There are a number of type conversions to perform: we
  10 -- have to convert the package indices to the uniform index used
  11 -- by the solver; we also have to convert the initial constraints;
  12 -- and finally, we have to convert back the resulting install
  13 -- plan.
  14
  15 import Prelude ()
  16 import Distribution.Solver.Compat.Prelude
  17
  18 import qualified Data.Map as M
  19 import Data.Set (isSubsetOf)
  20 import Distribution.Compat.Graph
  21          ( IsNode(..) )
  22 import Distribution.Compiler
  23          ( CompilerInfo )
  24 import Distribution.Solver.Modular.Assignment
  25          ( Assignment, toCPs )
  26 import Distribution.Solver.Modular.ConfiguredConversion
  27          ( convCP )
  28 import qualified Distribution.Solver.Modular.ConflictSet as CS
  29 import Distribution.Solver.Modular.Dependency
  30 import Distribution.Solver.Modular.Flag
  31 import Distribution.Solver.Modular.Index
  32 import Distribution.Solver.Modular.IndexConversion
  33          ( convPIs )
  34 import Distribution.Solver.Modular.Log
  35          ( SolverFailure(..), displayLogMessages )
  36 import Distribution.Solver.Modular.Package
  37          ( PN )
  38 import Distribution.Solver.Modular.RetryLog
  39 import Distribution.Solver.Modular.Solver
  40          ( SolverConfig(..), PruneAfterFirstSuccess(..), solve )
  41 import Distribution.Solver.Types.DependencyResolver
  42 import Distribution.Solver.Types.LabeledPackageConstraint
  43 import Distribution.Solver.Types.PackageConstraint
  44 import Distribution.Solver.Types.PackagePath
  45 import Distribution.Solver.Types.PackagePreferences
  46 import Distribution.Solver.Types.PkgConfigDb
  47          ( PkgConfigDb )
  48 import Distribution.Solver.Types.Progress
  49 import Distribution.Solver.Types.Variable
  50 import Distribution.System
  51          ( Platform(..) )
  52 import Distribution.Simple.Setup
  53          ( BooleanFlag(..) )
  54 import Distribution.Simple.Utils
  55          ( ordNubBy )
  56 import Distribution.Verbosity
  57
  58
  59 -- | Ties the two worlds together: classic cabal-install vs. the modular
  60 -- solver. Performs the necessary translations before and after.
  61 modularResolver :: SolverConfig -> DependencyResolver loc
  62 modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =
  63   uncurry postprocess <$> -- convert install plan
  64   solve' sc cinfo idx pkgConfigDB pprefs gcs pns
  65     where
  66       -- Indices have to be converted into solver-specific uniform index.
  67       idx    = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx
  68       -- Constraints have to be converted into a finite map indexed by PN.
  69       gcs    = M.fromListWith (++) (map pair pcs)
  70         where
  71           pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc])
  72
  73       -- Results have to be converted into an install plan. 'convCP' removes
  74       -- package qualifiers, which means that linked packages become duplicates
  75       -- and can be removed.
  76       postprocess a rdm = ordNubBy nodeKey $
  77                           map (convCP iidx sidx) (toCPs a rdm)
  78
  79       -- Helper function to extract the PN from a constraint.
  80       pcName :: PackageConstraint -> PN
  81       pcName (PackageConstraint scope _) = scopeToPackageName scope
  82
  83 -- | Run 'D.S.Modular.Solver.solve' and then produce a summarized log to display
  84 -- in the error case.
  85 --
  86 -- When there is no solution, we produce the error message by rerunning the
  87 -- solver but making it prefer the goals from the final conflict set from the
  88 -- first run (or a subset of the final conflict set with
  89 -- --minimize-conflict-set). We also set the backjump limit to 0, so that the
  90 -- log stops at the first backjump and is relatively short. Preferring goals
  91 -- from the final conflict set increases the probability that the log to the
  92 -- first backjump contains package, flag, and stanza choices that are relevant
  93 -- to the final failure. The solver shouldn't need to choose any packages that
  94 -- aren't in the final conflict set. (For every variable in the final conflict
  95 -- set, the final conflict set should also contain the variable that introduced
  96 -- that variable. The solver can then follow that chain of variables in reverse
  97 -- order from the user target to the conflict.) However, it is possible that the
  98 -- conflict set contains unnecessary variables.
  99 --
 100 -- Producing an error message when the solver reaches the backjump limit is more
 101 -- complicated. There is no final conflict set, so we create one for the minimal
 102 -- subtree containing the path that the solver took to the first backjump. This
 103 -- conflict set helps explain why the solver reached the backjump limit, because
 104 -- the first backjump contributes to reaching the backjump limit. Additionally,
 105 -- the solver is much more likely to be able to finish traversing this subtree
 106 -- before the backjump limit, since its size is linear (not exponential) in the
 107 -- number of goal choices. We create it by pruning all children after the first
 108 -- successful child under each node in the original tree, so that there is at
 109 -- most one valid choice at each level. Then we use the final conflict set from
 110 -- that run to generate an error message, as in the case where the solver found
 111 -- that there was no solution.
 112 --
 113 -- Using the full log from a rerun of the solver ensures that the log is
 114 -- complete, i.e., it shows the whole chain of dependencies from the user
 115 -- targets to the conflicting packages.
 116 solve' :: SolverConfig
 117        -> CompilerInfo
 118        -> Index
 119        -> Maybe PkgConfigDb
 120        -> (PN -> PackagePreferences)
 121        -> Map PN [LabeledPackageConstraint]
 122        -> Set PN
 123        -> Progress String String (Assignment, RevDepMap)
 124 solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
 125     toProgress $ retry (runSolver printFullLog sc) createErrorMsg
 126   where
 127     runSolver :: Bool -> SolverConfig
 128               -> RetryLog String SolverFailure (Assignment, RevDepMap)
 129     runSolver keepLog sc' =
 130         displayLogMessages keepLog $
 131         solve sc' cinfo idx pkgConfigDB pprefs gcs pns
 132
 133     createErrorMsg :: SolverFailure
 134                    -> RetryLog String String (Assignment, RevDepMap)
 135     createErrorMsg failure@(ExhaustiveSearch cs cm) =
 136       if asBool $ minimizeConflictSet sc
 137       then continueWith ("Found no solution after exhaustively searching the "
 138                           ++ "dependency tree. Rerunning the dependency solver "
 139                           ++ "to minimize the conflict set ({"
 140                           ++ showConflictSet cs ++ "}).") $
 141            retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) $
 142                \case
 143                   ExhaustiveSearch cs' cm' ->
 144                       fromProgress $ Fail $
 145                           rerunSolverForErrorMsg cs'
 146                        ++ finalErrorMsg sc (ExhaustiveSearch cs' cm')
 147                   BackjumpLimitReached ->
 148                       fromProgress $ Fail $
 149                           "Reached backjump limit while trying to minimize the "
 150                        ++ "conflict set to create a better error message. "
 151                        ++ "Original error message:\n"
 152                        ++ rerunSolverForErrorMsg cs
 153                        ++ finalErrorMsg sc failure
 154       else fromProgress $ Fail $
 155            rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure
 156     createErrorMsg failure@BackjumpLimitReached     =
 157         continueWith
 158              ("Backjump limit reached. Rerunning dependency solver to generate "
 159               ++ "a final conflict set for the search tree containing the "
 160               ++ "first backjump.") $
 161         retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $
 162             \case
 163                ExhaustiveSearch cs _ ->
 164                    fromProgress $ Fail $
 165                    rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure
 166                BackjumpLimitReached  ->
 167                    -- This case is possible when the number of goals involved in
 168                    -- conflicts is greater than the backjump limit.
 169                    fromProgress $ Fail $ finalErrorMsg sc failure
 170                     ++ "Failed to generate a summarized dependency solver "
 171                     ++ "log due to low backjump limit."
 172
 173     rerunSolverForErrorMsg :: ConflictSet -> String
 174     rerunSolverForErrorMsg cs =
 175       let sc' = sc {
 176                     goalOrder = Just goalOrder'
 177                   , maxBackjumps = Just 0
 178                   }
 179
 180           -- Preferring goals from the conflict set takes precedence over the
 181           -- original goal order.
 182           goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc)
 183
 184       in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc')))
 185
 186     printFullLog = solverVerbosity sc >= verbose
 187
 188     messages :: Progress step fail done -> [step]
 189     messages = foldProgress (:) (const []) (const [])
 190
 191 -- | Try to remove variables from the given conflict set to create a minimal
 192 -- conflict set.
 193 --
 194 -- Minimal means that no proper subset of the conflict set is also a conflict
 195 -- set, though there may be other possible conflict sets with fewer variables.
 196 -- This function minimizes the input by trying to remove one variable at a time.
 197 -- It only makes one pass over the variables, so it runs the solver at most N
 198 -- times when given a conflict set of size N. Only one pass is necessary,
 199 -- because every superset of a conflict set is also a conflict set, meaning that
 200 -- failing to remove variable X from a conflict set in one step means that X
 201 -- cannot be removed from any subset of that conflict set in a subsequent step.
 202 --
 203 -- Example steps:
 204 --
 205 -- Start with {A, B, C}.
 206 -- Try to remove A from {A, B, C} and fail.
 207 -- Try to remove B from {A, B, C} and succeed.
 208 -- Try to remove C from {A, C} and fail.
 209 -- Return {A, C}
 210 --
 211 -- This function can fail for two reasons:
 212 --
 213 -- 1. The solver can reach the backjump limit on any run. In this case the
 214 --    returned RetryLog ends with BackjumpLimitReached.
 215 --    TODO: Consider applying the backjump limit to all solver runs combined,
 216 --    instead of each individual run. For example, 10 runs with 10 backjumps
 217 --    each should count as 100 backjumps.
 218 -- 2. Since this function works by rerunning the solver, it is possible for the
 219 --    solver to add new unnecessary variables to the conflict set. This function
 220 --    discards the result from any run that adds new variables to the conflict
 221 --    set, but the end result may not be completely minimized.
 222 tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a)
 223                          -> SolverConfig
 224                          -> ConflictSet
 225                          -> ConflictMap
 226                          -> RetryLog String SolverFailure a
 227 tryToMinimizeConflictSet runSolver sc cs cm =
 228     foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v)
 229           (fromProgress $ Fail $ ExhaustiveSearch cs cm)
 230           (CS.toList cs)
 231   where
 232     -- This function runs the solver and makes it prefer goals in the following
 233     -- order:
 234     --
 235     -- 1. variables in 'smallestKnownCS', excluding 'v'
 236     -- 2. 'v'
 237     -- 3. all other variables
 238     --
 239     -- If 'v' is not necessary, then the solver will find that there is no
 240     -- solution before starting to solve for 'v', and the new final conflict set
 241     -- will be very likely to not contain 'v'. If 'v' is necessary, the solver
 242     -- will most likely need to try solving for 'v' before finding that there is
 243     -- no solution, and the new final conflict set will still contain 'v'.
 244     -- However, this method isn't perfect, because it is possible for the solver
 245     -- to add new unnecessary variables to the conflict set on any run. This
 246     -- function prevents the conflict set from growing by checking that the new
 247     -- conflict set is a subset of the old one and falling back to using the old
 248     -- conflict set when that check fails.
 249     tryToRemoveOneVar :: Var QPN
 250                       -> ConflictSet
 251                       -> ConflictMap
 252                       -> RetryLog String SolverFailure a
 253     tryToRemoveOneVar v smallestKnownCS smallestKnownCM
 254         -- Check whether v is still present, because it may have already been
 255         -- removed in a previous solver rerun.
 256       | not (v `CS.member` smallestKnownCS) =
 257           fromProgress $ Fail $ ExhaustiveSearch smallestKnownCS smallestKnownCM
 258       | otherwise =
 259         continueWith ("Trying to remove variable " ++ varStr ++ " from the "
 260                       ++ "conflict set.") $
 261         retry (runSolver sc') $ \case
 262             err@(ExhaustiveSearch cs' _)
 263               | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS ->
 264                   let msg = if not $ CS.member v cs'
 265                             then "Successfully removed " ++ varStr ++ " from "
 266                                   ++ "the conflict set."
 267                             else "Failed to remove " ++ varStr ++ " from the "
 268                                   ++ "conflict set."
 269                   in -- Use the new conflict set, even if v wasn't removed,
 270                      -- because other variables may have been removed.
 271                      failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err
 272               | otherwise ->
 273                   failWith ("Failed to find a smaller conflict set. The new "
 274                              ++ "conflict set is not a subset of the previous "
 275                              ++ "conflict set: " ++ showCS cs') $
 276                   ExhaustiveSearch smallestKnownCS smallestKnownCM
 277             BackjumpLimitReached ->
 278                 failWith "Reached backjump limit while minimizing conflict set."
 279                          BackjumpLimitReached
 280       where
 281         varStr = "\"" ++ showVar v ++ "\""
 282         showCS cs' = "{" ++ showConflictSet cs' ++ "}"
 283
 284         sc' = sc { goalOrder = Just goalOrder' }
 285
 286         goalOrder' =
 287             preferGoalsFromConflictSet (v `CS.delete` smallestKnownCS)
 288          <> preferGoal v
 289          <> fromMaybe mempty (goalOrder sc)
 290
 291     -- Like 'retry', except that it only applies the input function when the
 292     -- backjump limit has not been reached.
 293     retryNoSolution :: RetryLog step SolverFailure done
 294                     -> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done)
 295                     -> RetryLog step SolverFailure done
 296     retryNoSolution lg f = retry lg $ \case
 297         ExhaustiveSearch cs' cm' -> f cs' cm'
 298         BackjumpLimitReached     -> fromProgress (Fail BackjumpLimitReached)
 299
 300 -- | Goal ordering that chooses goals contained in the conflict set before
 301 -- other goals.
 302 preferGoalsFromConflictSet :: ConflictSet
 303                            -> Variable QPN -> Variable QPN -> Ordering
 304 preferGoalsFromConflictSet cs = comparing $ \v -> not $ CS.member (toVar v) cs
 305
 306 -- | Goal ordering that chooses the given goal first.
 307 preferGoal :: Var QPN -> Variable QPN -> Variable QPN -> Ordering
 308 preferGoal preferred = comparing $ \v -> toVar v /= preferred
 309
 310 toVar :: Variable QPN -> Var QPN
 311 toVar (PackageVar qpn)    = P qpn
 312 toVar (FlagVar    qpn fn) = F (FN qpn fn)
 313 toVar (StanzaVar  qpn sn) = S (SN qpn sn)
 314
 315 finalErrorMsg :: SolverConfig -> SolverFailure -> String
 316 finalErrorMsg sc failure =
 317     case failure of
 318       ExhaustiveSearch cs cm ->
 319           "After searching the rest of the dependency tree exhaustively, "
 320           ++ "these were the goals I've had most trouble fulfilling: "
 321           ++ showCS cm cs
 322           ++ flagSuggestion
 323         where
 324           showCS = if solverVerbosity sc > normal
 325                    then CS.showCSWithFrequency
 326                    else CS.showCSSortedByFrequency
 327           flagSuggestion =
 328               -- Don't suggest --minimize-conflict-set if the conflict set is
 329               -- already small, because it is unlikely to be reduced further.
 330               if CS.size cs > 3 && not (asBool (minimizeConflictSet sc))
 331               then "\nTry running with --minimize-conflict-set to improve the "
 332                     ++ "error message."
 333               else ""
 334       BackjumpLimitReached ->
 335           "Backjump limit reached (" ++ currlimit (maxBackjumps sc) ++
 336           "change with --max-backjumps or try to run with --reorder-goals).\n"
 337         where currlimit (Just n) = "currently " ++ show n ++ ", "
 338               currlimit Nothing  = ""