1{-# LANGUAGE LambdaCase #-} 2{-# LANGUAGE ScopedTypeVariables #-} 3 4module 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 15import Prelude () 16import Distribution.Solver.Compat.Prelude 17 18import qualified Data.Map as M 19import Data.Set (isSubsetOf) 20import Distribution.Compat.Graph 21 ( IsNode(..) ) 22import Distribution.Compiler 23 ( CompilerInfo ) 24import Distribution.Solver.Modular.Assignment 25 ( Assignment, toCPs ) 26import Distribution.Solver.Modular.ConfiguredConversion 27 ( convCP ) 28import qualified Distribution.Solver.Modular.ConflictSet as CS 29import Distribution.Solver.Modular.Dependency 30import Distribution.Solver.Modular.Flag 31import Distribution.Solver.Modular.Index 32import Distribution.Solver.Modular.IndexConversion 33 ( convPIs ) 34import Distribution.Solver.Modular.Log 35 ( SolverFailure(..), displayLogMessages ) 36import Distribution.Solver.Modular.Package 37 ( PN ) 38import Distribution.Solver.Modular.RetryLog 39import Distribution.Solver.Modular.Solver 40 ( SolverConfig(..), PruneAfterFirstSuccess(..), solve ) 41import Distribution.Solver.Types.DependencyResolver 42import Distribution.Solver.Types.LabeledPackageConstraint 43import Distribution.Solver.Types.PackageConstraint 44import Distribution.Solver.Types.PackagePath 45import Distribution.Solver.Types.PackagePreferences 46import Distribution.Solver.Types.PkgConfigDb 47 ( PkgConfigDb ) 48import Distribution.Solver.Types.Progress 49import Distribution.Solver.Types.Variable 50import Distribution.System 51 ( Platform(..) ) 52import Distribution.Simple.Setup 53 ( BooleanFlag(..) ) 54import Distribution.Simple.Utils 55 ( ordNubBy ) 56import 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. 61modularResolver :: SolverConfig -> DependencyResolver loc 62modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns = 63 fmap (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. 116solve' :: SolverConfig 117 -> CompilerInfo 118 -> Index 119 -> PkgConfigDb 120 -> (PN -> PackagePreferences) 121 -> Map PN [LabeledPackageConstraint] 122 -> Set PN 123 -> Progress String String (Assignment, RevDepMap) 124solve' 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. 222tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a) 223 -> SolverConfig 224 -> ConflictSet 225 -> ConflictMap 226 -> RetryLog String SolverFailure a 227tryToMinimizeConflictSet 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. 302preferGoalsFromConflictSet :: ConflictSet 303 -> Variable QPN -> Variable QPN -> Ordering 304preferGoalsFromConflictSet cs = comparing $ \v -> not $ CS.member (toVar v) cs 305 306-- | Goal ordering that chooses the given goal first. 307preferGoal :: Var QPN -> Variable QPN -> Variable QPN -> Ordering 308preferGoal preferred = comparing $ \v -> toVar v /= preferred 309 310toVar :: Variable QPN -> Var QPN 311toVar (PackageVar qpn) = P qpn 312toVar (FlagVar qpn fn) = F (FN qpn fn) 313toVar (StanzaVar qpn sn) = S (SN qpn sn) 314 315finalErrorMsg :: SolverConfig -> SolverFailure -> String 316finalErrorMsg 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 = "" 339