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,
         installIndependentGoals      = combine installIndependentGoals,
         installShadowPkgs            = combine installShadowPkgs,

cabal-install/Distribution/Client/Dependency.hs

@@ -54,6 +54,7 @@ module Distribution.Client.Dependency (
     setMaxBackjumps,
     setEnableBackjumping,
     setMaxScore,
+    setFindBestSolution,
     addSourcePackages,
     hideInstalledPackagesSpecificByUnitId,
     hideInstalledPackagesSpecificBySourcePackageId,
@@ -159,7 +160,8 @@ data DepResolverParams = DepResolverParams {
        depResolverStrongFlags       :: StrongFlags,
        depResolverMaxBackjumps      :: Maybe Int,
        depResolverEnableBackjumping :: EnableBackjumping,
-       depResolverMaxScore          :: Maybe InstallPlanScore
+       depResolverMaxScore          :: Maybe InstallPlanScore,
+       depResolverFindBestSolution  :: FindBestSolution
      }
 
 showDepResolverParams :: DepResolverParams -> String
@@ -232,7 +234,8 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
        depResolverStrongFlags       = StrongFlags False,
        depResolverMaxBackjumps      = Nothing,
        depResolverEnableBackjumping = EnableBackjumping True,
-       depResolverMaxScore          = Nothing
+       depResolverMaxScore          = Nothing,
+       depResolverFindBestSolution  = FindBestSolution False
      }
 
 addTargets :: [PackageName]
@@ -313,6 +316,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
@@ -596,7 +605,7 @@ resolveDependencies platform comp pkgConfigDB solver params =
     Step (showDepResolverParams finalparams)
   $ fmap (uncurry $ validateSolverResult platform comp indGoals)
   $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls
-                      shadowing strFlags maxBkjumps enableBj mScore)
+                      shadowing strFlags maxBkjumps enableBj mScore findBest)
                      platform comp installedPkgIndex sourcePkgIndex
                      pkgConfigDB preferences constraints targets
   where
@@ -613,15 +622,16 @@ resolveDependencies platform comp pkgConfigDB solver params =
       strFlags
       maxBkjumps
       enableBj
-      mScore) = dontUpgradeNonUpgradeablePackages
+      mScore
+      findBest) = dontUpgradeNonUpgradeablePackages
                       -- TODO:
                       -- The modular solver can properly deal with broken
                       -- packages and won't select them. So the
                       -- 'hideBrokenInstalledPackages' function should be moved
                       -- into a module that is specific to the top-down solver.
-                      . (if solver /= Modular then hideBrokenInstalledPackages
-                                              else id)
-                      $ params
+                        . (if solver /= Modular then hideBrokenInstalledPackages
+                                                else id)
+                        $ params
 
     preferences = interpretPackagesPreference
                     (Set.fromList targets) defpref prefs
@@ -849,7 +859,8 @@ resolveWithoutDependencies :: DepResolverParams
 resolveWithoutDependencies (DepResolverParams targets constraints
                               prefs defpref installedPkgIndex sourcePkgIndex
                               _reorderGoals _indGoals _avoidReinstalls
-                              _shadowing _strFlags _maxBjumps _enableBj _maxScore) =
+                              _shadowing _strFlags _maxBjumps _enableBj _maxScore
+                              _findBest) =
     collectEithers (map selectPackage targets)
   where
     selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage

cabal-install/Distribution/Client/Install.hs

@@ -369,6 +369,8 @@ planPackages comp platform mSandboxPkgInfo solver
 
       . setMaxScore maxScore
 
+      . setFindBestSolution findBest
+
       . setIndependentGoals independentGoals
 
       . setReorderGoals reorderGoals
@@ -431,6 +433,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)
     allowNewer       = fromMaybe AllowNewerNone (configAllowNewer configFlags)

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

@@ -495,6 +495,7 @@ convertToLegacySharedConfig
       installMaxBackjumps      = projectConfigMaxBackjumps,
       installMaxScore          = mempty, --projectConfigMaxScore,
       installUpgradeDeps       = mempty, --projectConfigUpgradeDeps,
+      installFindBestSolution  = mempty, --projectConfigFindBestSolution,
       installReorderGoals      = projectConfigReorderGoals,
       installIndependentGoals  = mempty, --projectConfigIndependentGoals,
       installShadowPkgs        = mempty, --projectConfigShadowPkgs,

cabal-install/Distribution/Client/Setup.hs

@@ -605,6 +605,7 @@ data FetchFlags = FetchFlags {
       fetchSolver           :: Flag PreSolver,
       fetchMaxBackjumps     :: Flag Int,
       fetchMaxScore         :: Flag InstallPlanScore,
+      fetchFindBestSolution :: Flag FindBestSolution,
       fetchReorderGoals     :: Flag ReorderGoals,
       fetchIndependentGoals :: Flag IndependentGoals,
       fetchShadowPkgs       :: Flag ShadowPkgs,
@@ -620,6 +621,7 @@ defaultFetchFlags = FetchFlags {
     fetchSolver           = Flag defaultSolver,
     fetchMaxBackjumps     = Flag defaultMaxBackjumps,
     fetchMaxScore         = mempty,
+    fetchFindBestSolution = Flag (FindBestSolution False),
     fetchReorderGoals     = Flag (ReorderGoals False),
     fetchIndependentGoals = Flag (IndependentGoals False),
     fetchShadowPkgs       = Flag (ShadowPkgs False),
@@ -667,6 +669,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 })
                          fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
                          fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
@@ -685,6 +688,7 @@ data FreezeFlags = FreezeFlags {
       freezeSolver           :: Flag PreSolver,
       freezeMaxBackjumps     :: Flag Int,
       freezeMaxScore         :: Flag InstallPlanScore,
+      freezeFindBestSolution :: Flag FindBestSolution,
       freezeReorderGoals     :: Flag ReorderGoals,
       freezeIndependentGoals :: Flag IndependentGoals,
       freezeShadowPkgs       :: Flag ShadowPkgs,
@@ -700,6 +704,7 @@ defaultFreezeFlags = FreezeFlags {
     freezeSolver           = Flag defaultSolver,
     freezeMaxBackjumps     = Flag defaultMaxBackjumps,
     freezeMaxScore         = mempty,
+    freezeFindBestSolution = Flag (FindBestSolution False),
     freezeReorderGoals     = Flag (ReorderGoals False),
     freezeIndependentGoals = Flag (IndependentGoals False),
     freezeShadowPkgs       = Flag (ShadowPkgs False),
@@ -746,6 +751,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 })
                          freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })
                          freezeShadowPkgs       (\v flags -> flags { freezeShadowPkgs       = v })
@@ -1149,6 +1155,7 @@ data InstallFlags = InstallFlags {
     installDryRun           :: Flag Bool,
     installMaxBackjumps     :: Flag Int,
     installMaxScore         :: Flag InstallPlanScore,
+    installFindBestSolution :: Flag FindBestSolution,
     installReorderGoals     :: Flag ReorderGoals,
     installIndependentGoals :: Flag IndependentGoals,
     installShadowPkgs       :: Flag ShadowPkgs,
@@ -1181,6 +1188,7 @@ defaultInstallFlags = InstallFlags {
     installDryRun          = Flag False,
     installMaxBackjumps    = Flag defaultMaxBackjumps,
     installMaxScore        = mempty,
+    installFindBestSolution= Flag (FindBestSolution False),
     installReorderGoals    = Flag (ReorderGoals False),
     installIndependentGoals= Flag (IndependentGoals False),
     installShadowPkgs      = Flag (ShadowPkgs False),
@@ -1326,6 +1334,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 })
                         installIndependentGoals (\v flags -> flags { installIndependentGoals = v })
                         installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v })
@@ -2079,12 +2088,13 @@ 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 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 _getig _setig getsip setsip getstrfl setstrfl =
+optionSolverFlags showOrParseArgs getmbj setmbj getms setms getfb setfb getrg setrg _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
@@ -2096,6 +2106,11 @@ optionSolverFlags showOrParseArgs getmbj setmbj getms setms getrg setrg _getig _
       (setms . fmap InstallPlanScore)
       (reqArg "NUM" (readP_to_E ("Cannot parse number: "++) (fmap (toFlag . (fromIntegral :: Int -> Double)) parse))
                     (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/Cycles.hs

@@ -14,11 +14,11 @@ import Distribution.Solver.Modular.Tree
 import qualified Distribution.Solver.Modular.ConflictSet as CS
 
 -- | Find and reject any solutions that are cyclic
-detectCyclesPhase :: Tree a QGoalReason -> Tree a QGoalReason
+detectCyclesPhase :: Tree a b -> Tree a b
 detectCyclesPhase = cata go
   where
     -- The only node of interest is DoneF
-    go :: TreeF a QGoalReason (Tree a QGoalReason) -> Tree a QGoalReason
+    go :: TreeF a b (Tree a b) -> Tree a b
     go (PChoiceF qpn gr     cs) = PChoice qpn gr     cs
     go (FChoiceF qfn gr w m cs) = FChoice qfn gr w m cs
     go (SChoiceF qsn gr w   cs) = SChoice qsn gr w   cs

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

@@ -9,6 +9,8 @@ module Distribution.Solver.Modular.Dependency (
   , ConflictSet
   , CS.ConflictType(..)
   , CS.showCS
+    -- * Install plan scoring
+  , ScoringState(..)
     -- * Constrained instances
   , CI(..)
   , merge
@@ -56,6 +58,21 @@ import Distribution.Solver.Modular.Version
 import qualified Distribution.Solver.Modular.ConflictSet as CS
 
 import Distribution.Solver.Types.ComponentDeps (Component(..))
+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
+    }
 
 {-------------------------------------------------------------------------------
   Constrained instances