Add option to find best install plan before backjump limit

Author: grayjay

cabal-install/Distribution/Client/Config.hs

@@ -239,6 +239,7 @@ instance Semigroup SavedConfig where
         installDryRun                = combine installDryRun,
         installMaxBackjumps          = combine installMaxBackjumps,
         installMaxScore              = combine installMaxScore,
+        installFindBestSolution      = combine installFindBestSolution,
         installReorderGoals          = combine installReorderGoals,
         installCountConflicts        = combine installCountConflicts,
         installIndependentGoals      = combine installIndependentGoals,

cabal-install/Distribution/Client/Dependency.hs

@@ -53,6 +53,7 @@ module Distribution.Client.Dependency (
     setEnableBackjumping,
     setGoalOrder,
     setMaxScore,
+    setFindBestSolution,
     removeLowerBounds,
     removeUpperBounds,
     addDefaultSetupDependencies,
@@ -162,7 +163,8 @@ data DepResolverParams = DepResolverParams {
 
        -- | Function to override the solver's goal-ordering heuristics.
        depResolverGoalOrder         :: Maybe (Variable QPN -> Variable QPN -> Ordering),
-       depResolverMaxScore          :: Maybe InstallPlanScore
+       depResolverMaxScore          :: Maybe InstallPlanScore,
+       depResolverFindBestSolution  :: FindBestSolution
      }
 
 showDepResolverParams :: DepResolverParams -> String
@@ -238,7 +240,8 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
        depResolverMaxBackjumps      = Nothing,
        depResolverEnableBackjumping = EnableBackjumping True,
        depResolverGoalOrder         = Nothing,
-       depResolverMaxScore          = Nothing
+       depResolverMaxScore          = Nothing,
+       depResolverFindBestSolution  = FindBestSolution False
      }
 
 addTargets :: [PackageName]
@@ -333,6 +336,12 @@ setMaxScore n params =
       depResolverMaxScore = n
     }
 
+setFindBestSolution :: FindBestSolution -> DepResolverParams -> DepResolverParams
+setFindBestSolution findBest params =
+    params {
+      depResolverFindBestSolution = findBest
+    }
+
 -- | Some packages are specific to a given compiler version and should never be
 -- upgraded.
 dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams
@@ -618,7 +627,7 @@ resolveDependencies platform comp pkgConfigDB solver params =
     Step (showDepResolverParams finalparams)
   $ fmap (uncurry $ validateSolverResult platform comp indGoals)
   $ runSolver solver (SolverConfig reordGoals cntConflicts indGoals noReinstalls
-                      shadowing strFlags maxBkjumps enableBj order mScore)
+                      shadowing strFlags maxBkjumps enableBj order mScore findBest)
                      platform comp installedPkgIndex sourcePkgIndex
                      pkgConfigDB preferences constraints targets
   where
@@ -637,7 +646,8 @@ resolveDependencies platform comp pkgConfigDB solver params =
       maxBkjumps
       enableBj
       order
-      mScore) = dontUpgradeNonUpgradeablePackages params
+      mScore
+      findBest) = dontUpgradeNonUpgradeablePackages params
 
     preferences = interpretPackagesPreference targets defpref prefs
 
@@ -863,7 +873,8 @@ resolveWithoutDependencies :: DepResolverParams
 resolveWithoutDependencies (DepResolverParams targets constraints
                               prefs defpref installedPkgIndex sourcePkgIndex
                               _reorderGoals _countConflicts _indGoals _avoidReinstalls
-                              _shadowing _strFlags _maxBjumps _enableBj _order _maxScore) =
+                              _shadowing _strFlags _maxBjumps _enableBj _order _maxScore
+                              _findBest) =
     collectEithers $ map selectPackage (Set.toList targets)
   where
     selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage

cabal-install/Distribution/Client/Install.hs

@@ -382,6 +382,8 @@ planPackages comp platform mSandboxPkgInfo solver
 
       . setMaxScore maxScore
 
+      . setFindBestSolution findBest
+
       . setIndependentGoals independentGoals
 
       . setReorderGoals reorderGoals
@@ -448,6 +450,7 @@ planPackages comp platform mSandboxPkgInfo solver
     strongFlags      = fromFlag (installStrongFlags       installFlags)
     maxBackjumps     = fromFlag (installMaxBackjumps      installFlags)
     maxScore         = flagToMaybe (installMaxScore       installFlags)
+    findBest         = fromFlag (installFindBestSolution  installFlags)
     upgradeDeps      = fromFlag (installUpgradeDeps       installFlags)
     onlyDeps         = fromFlag (installOnlyDeps          installFlags)
     allowOlder       = fromMaybe (AllowOlder RelaxDepsNone)

cabal-install/Distribution/Client/ProjectConfig/Legacy.hs

@@ -499,6 +499,7 @@ convertToLegacySharedConfig
       installMaxBackjumps      = projectConfigMaxBackjumps,
       installMaxScore          = mempty, --projectConfigMaxScore,
       installUpgradeDeps       = mempty, --projectConfigUpgradeDeps,
+      installFindBestSolution  = mempty, --projectConfigFindBestSolution,
       installReorderGoals      = projectConfigReorderGoals,
       installCountConflicts    = projectConfigCountConflicts,
       installIndependentGoals  = mempty, --projectConfigIndependentGoals,

cabal-install/Distribution/Client/Setup.hs

@@ -640,6 +640,7 @@ data FetchFlags = FetchFlags {
       fetchSolver           :: Flag PreSolver,
       fetchMaxBackjumps     :: Flag Int,
       fetchMaxScore         :: Flag InstallPlanScore,
+      fetchFindBestSolution :: Flag FindBestSolution,
       fetchReorderGoals     :: Flag ReorderGoals,
       fetchCountConflicts   :: Flag CountConflicts,
       fetchIndependentGoals :: Flag IndependentGoals,
@@ -656,6 +657,7 @@ defaultFetchFlags = FetchFlags {
     fetchSolver           = Flag defaultSolver,
     fetchMaxBackjumps     = Flag defaultMaxBackjumps,
     fetchMaxScore         = mempty,
+    fetchFindBestSolution = Flag (FindBestSolution False),
     fetchReorderGoals     = Flag (ReorderGoals False),
     fetchCountConflicts   = Flag (CountConflicts True),
     fetchIndependentGoals = Flag (IndependentGoals False),
@@ -704,6 +706,7 @@ fetchCommand = CommandUI {
        optionSolverFlags showOrParseArgs
                          fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })
                          fetchMaxScore         (\v flags -> flags { fetchMaxScore         = v })
+                         fetchFindBestSolution (\v flags -> flags { fetchFindBestSolution = v })
                          fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                          fetchCountConflicts   (\v flags -> flags { fetchCountConflicts   = v })
                          fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
@@ -723,6 +726,7 @@ data FreezeFlags = FreezeFlags {
       freezeSolver           :: Flag PreSolver,
       freezeMaxBackjumps     :: Flag Int,
       freezeMaxScore         :: Flag InstallPlanScore,
+      freezeFindBestSolution :: Flag FindBestSolution,
       freezeReorderGoals     :: Flag ReorderGoals,
       freezeCountConflicts   :: Flag CountConflicts,
       freezeIndependentGoals :: Flag IndependentGoals,
@@ -739,6 +743,7 @@ defaultFreezeFlags = FreezeFlags {
     freezeSolver           = Flag defaultSolver,
     freezeMaxBackjumps     = Flag defaultMaxBackjumps,
     freezeMaxScore         = mempty,
+    freezeFindBestSolution = Flag (FindBestSolution False),
     freezeReorderGoals     = Flag (ReorderGoals False),
     freezeCountConflicts   = Flag (CountConflicts True),
     freezeIndependentGoals = Flag (IndependentGoals False),
@@ -786,6 +791,7 @@ freezeCommand = CommandUI {
        optionSolverFlags showOrParseArgs
                          freezeMaxBackjumps     (\v flags -> flags { freezeMaxBackjumps     = v })
                          freezeMaxScore         (\v flags -> flags { freezeMaxScore         = v })
+                         freezeFindBestSolution (\v flags -> flags { freezeFindBestSolution = v })
                          freezeReorderGoals     (\v flags -> flags { freezeReorderGoals     = v })
                          freezeCountConflicts   (\v flags -> flags { freezeCountConflicts   = v })
                          freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })
@@ -1190,6 +1196,7 @@ data InstallFlags = InstallFlags {
     installDryRun           :: Flag Bool,
     installMaxBackjumps     :: Flag Int,
     installMaxScore         :: Flag InstallPlanScore,
+    installFindBestSolution :: Flag FindBestSolution,
     installReorderGoals     :: Flag ReorderGoals,
     installCountConflicts   :: Flag CountConflicts,
     installIndependentGoals :: Flag IndependentGoals,
@@ -1224,6 +1231,7 @@ defaultInstallFlags = InstallFlags {
     installDryRun          = Flag False,
     installMaxBackjumps    = Flag defaultMaxBackjumps,
     installMaxScore        = mempty,
+    installFindBestSolution= Flag (FindBestSolution False),
     installReorderGoals    = Flag (ReorderGoals False),
     installCountConflicts  = Flag (CountConflicts True),
     installIndependentGoals= Flag (IndependentGoals False),
@@ -1371,6 +1379,7 @@ installOptions showOrParseArgs =
       optionSolverFlags showOrParseArgs
                         installMaxBackjumps     (\v flags -> flags { installMaxBackjumps     = v })
                         installMaxScore         (\v flags -> flags { installMaxScore         = v })
+                        installFindBestSolution (\v flags -> flags { installFindBestSolution = v })
                         installReorderGoals     (\v flags -> flags { installReorderGoals     = v })
                         installCountConflicts   (\v flags -> flags { installCountConflicts   = v })
                         installIndependentGoals (\v flags -> flags { installIndependentGoals = v })
@@ -2138,13 +2147,14 @@ optionSolver get set =
 optionSolverFlags :: ShowOrParseArgs
                   -> (flags -> Flag Int   ) -> (Flag Int    -> flags -> flags)
                   -> (flags -> Flag InstallPlanScore) -> (Flag InstallPlanScore -> flags -> flags)
+                  -> (flags -> Flag FindBestSolution) -> (Flag FindBestSolution -> flags -> flags)
                   -> (flags -> Flag ReorderGoals)     -> (Flag ReorderGoals     -> flags -> flags)
                   -> (flags -> Flag CountConflicts)   -> (Flag CountConflicts   -> flags -> flags)
                   -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags)
                   -> (flags -> Flag ShadowPkgs)       -> (Flag ShadowPkgs       -> flags -> flags)
                   -> (flags -> Flag StrongFlags)      -> (Flag StrongFlags      -> flags -> flags)
                   -> [OptionField flags]
-optionSolverFlags showOrParseArgs getmbj setmbj getms setms getrg setrg getcc setcc _getig _setig getsip setsip getstrfl setstrfl =
+optionSolverFlags showOrParseArgs getmbj setmbj getms setms getfb setfb getrg setrg getcc setcc _getig _setig getsip setsip getstrfl setstrfl =
   [ option [] ["max-backjumps"]
       ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.")
       getmbj setmbj
@@ -2157,6 +2167,11 @@ optionSolverFlags showOrParseArgs getmbj setmbj getms setms getrg setrg getcc se
       (reqArg "NUM" (readP_to_E ("Cannot parse number: "++)
                                 (fmap toFlag (Parse.readS_to_P reads)))
                     (map show . flagToList))
+  , option [] ["find-best-solution"]
+      "Find the best-scoring solution within the backjump limit."
+      (fmap asBool . getfb)
+      (setfb . fmap FindBestSolution)
+      (yesNoOpt showOrParseArgs)
   , option [] ["reorder-goals"]
       "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages."
       (fmap asBool . getrg)

cabal-install/Distribution/Solver/Modular/Dependency.hs

@@ -14,6 +14,8 @@ module Distribution.Solver.Modular.Dependency (
   , ConflictSet
   , CS.ConflictType(..)
   , CS.showCS
+    -- * Install plan scoring
+  , ScoringState(..)
     -- * Constrained instances
   , CI(..)
   , merge
@@ -63,6 +65,21 @@ import qualified Distribution.Solver.Modular.ConflictSet as CS
 
 import Distribution.Solver.Types.ComponentDeps (Component(..))
 import Distribution.Solver.Types.PackagePath
+import Distribution.Solver.Types.Settings
+
+{-------------------------------------------------------------------------------
+  Install plan scoring
+-------------------------------------------------------------------------------}
+
+-- | State used for finding solutions based on score. Storing 'ScoringState' on
+-- nodes allows the nodes to be scored before the cutoff score is known.
+data ScoringState = ScoringState {
+      -- | The sum of the scores of all nodes from the root to the current node.
+      ssTotalScore  :: InstallPlanScore
+
+      -- | The conflict set that should be used if a node exceeds the max score.
+    , ssConflictSet :: ConflictSet QPN
+    }
 
 #ifdef DEBUG_CONFLICT_SETS
 import GHC.Stack (CallStack)