[RFC] Add option to find best install plan before backjump limit

cabal-install/Distribution/Client/Config.hs

@@ -239,6 +239,8 @@ instance Semigroup SavedConfig where
         installHaddockIndex          = combine installHaddockIndex,
         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

@@ -57,6 +57,8 @@ module Distribution.Client.Dependency (
     setSolveExecutables,
     setGoalOrder,
     setSolverVerbosity,
+    setMaxScore,
+    setFindBestSolution,
     removeLowerBounds,
     removeUpperBounds,
     addDefaultSetupDependencies,
@@ -176,7 +178,9 @@ data DepResolverParams = DepResolverParams {
 
        -- | Function to override the solver's goal-ordering heuristics.
        depResolverGoalOrder         :: Maybe (Variable QPN -> Variable QPN -> Ordering),
-       depResolverVerbosity         :: Verbosity
+       depResolverVerbosity         :: Verbosity,
+       depResolverMaxScore          :: Maybe InstallPlanScore,
+       depResolverFindBestSolution  :: FindBestSolution
      }
 
 showDepResolverParams :: DepResolverParams -> String
@@ -255,7 +259,9 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
        depResolverEnableBackjumping = EnableBackjumping True,
        depResolverSolveExecutables  = SolveExecutables True,
        depResolverGoalOrder         = Nothing,
-       depResolverVerbosity         = normal
+       depResolverVerbosity         = normal,
+       depResolverMaxScore          = Nothing,
+       depResolverFindBestSolution  = FindBestSolution False
      }
 
 addTargets :: [PackageName]
@@ -362,6 +368,18 @@ setSolverVerbosity verbosity params =
       depResolverVerbosity = verbosity
     }
 
+setMaxScore :: Maybe InstallPlanScore -> DepResolverParams -> DepResolverParams
+setMaxScore n params =
+    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
@@ -659,18 +677,19 @@ resolveDependencies :: Platform
     --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages
 resolveDependencies platform comp _pkgConfigDB _solver params
   | Set.null (depResolverTargets params)
-  = return (validateSolverResult platform comp indGoals [])
+  = return
+    (validateSolverResult platform comp indGoals [] defaultInstallPlanScore)
   where
     indGoals = depResolverIndependentGoals params
 
 resolveDependencies platform comp pkgConfigDB solver params =
 
     Step (showDepResolverParams finalparams)
-  $ fmap (validateSolverResult platform comp indGoals)
+  $ fmap (uncurry $ validateSolverResult platform comp indGoals)
   $ runSolver solver (SolverConfig reordGoals cntConflicts
                       indGoals noReinstalls
                       shadowing strFlags allowBootLibs maxBkjumps enableBj
-                      solveExes order verbosity)
+                      solveExes order verbosity mScore findBest)
                      platform comp installedPkgIndex sourcePkgIndex
                      pkgConfigDB preferences constraints targets
   where
@@ -691,7 +710,9 @@ resolveDependencies platform comp pkgConfigDB solver params =
       enableBj
       solveExes
       order
-      verbosity) =
+      verbosity
+      mScore
+      findBest) =
         if asBool (depResolverAllowBootLibInstalls params)
         then params
         else dontUpgradeNonUpgradeablePackages params
@@ -749,10 +770,11 @@ validateSolverResult :: Platform
                      -> CompilerInfo
                      -> IndependentGoals
                      -> [ResolverPackage UnresolvedPkgLoc]
+                     -> InstallPlanScore
                      -> SolverInstallPlan
-validateSolverResult platform comp indepGoals pkgs =
+validateSolverResult platform comp indepGoals pkgs score =
     case planPackagesProblems platform comp pkgs of
-      [] -> case SolverInstallPlan.new indepGoals graph of
+      [] -> case SolverInstallPlan.new indepGoals score graph of
               Right plan     -> plan
               Left  problems -> error (formatPlanProblems problems)
       problems               -> error (formatPkgProblems problems)
@@ -927,7 +949,8 @@ resolveWithoutDependencies (DepResolverParams targets constraints
                               prefs defpref installedPkgIndex sourcePkgIndex
                               _reorderGoals _countConflicts _indGoals _avoidReinstalls
                               _shadowing _strFlags _maxBjumps _enableBj
-                              _solveExes _allowBootLibInstalls _order _verbosity) =
+                              _solveExes _allowBootLibInstalls _order _verbosity
+                              _maxScore _findBest) =
     collectEithers $ map selectPackage (Set.toList targets)
   where
     selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage

cabal-install/Distribution/Client/Install.hs

@@ -380,6 +380,10 @@ planPackages verbosity comp platform mSandboxPkgInfo solver
         setMaxBackjumps (if maxBackjumps < 0 then Nothing
                                              else Just maxBackjumps)
 
+      . setMaxScore maxScore
+
+      . setFindBestSolution findBest
+
       . setIndependentGoals independentGoals
 
       . setReorderGoals reorderGoals
@@ -456,6 +460,8 @@ planPackages verbosity comp platform mSandboxPkgInfo solver
     strongFlags      = fromFlag (installStrongFlags       installFlags)
     maxBackjumps     = fromFlag (installMaxBackjumps      installFlags)
     allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags)
+    maxScore         = flagToMaybe (installMaxScore       installFlags)
+    findBest         = fromFlag (installFindBestSolution  installFlags)
     upgradeDeps      = fromFlag (installUpgradeDeps       installFlags)
     onlyDeps         = fromFlag (installOnlyDeps          installFlags)
     allowOlder       = fromMaybe (AllowOlder RelaxDepsNone)
@@ -556,7 +562,7 @@ checkPrintPlan verbosity installed installPlan sourcePkgDb
   -- with a dangerous install plan.
   when (dryRun || containsReinstalls && not overrideReinstall) $
     printPlan (dryRun || breaksPkgs && not overrideReinstall)
-      adaptedVerbosity lPlan sourcePkgDb
+      adaptedVerbosity lPlan (InstallPlan.planScore installPlan) sourcePkgDb
 
   -- If the install plan is dangerous, we print various warning messages. In
   -- particular, if we can see that packages are likely to be broken, we even
@@ -647,9 +653,12 @@ packageStatus installedPkgIndex cpkg =
 printPlan :: Bool -- is dry run
           -> Verbosity
           -> [(ReadyPackage, PackageStatus)]
+          -> InstallPlanScore
           -> SourcePackageDb
           -> IO ()
-printPlan dryRun verbosity plan sourcePkgDb = case plan of
+printPlan dryRun verbosity plan score sourcePkgDb = do
+ notice verbosity $ "Install plan score: " ++ showInstallPlanScore score
+ case plan of
   []   -> return ()
   pkgs
     | verbosity >= Verbosity.verbose -> putStr $ unlines $

cabal-install/Distribution/Client/InstallPlan.hs

@@ -20,7 +20,7 @@
 -----------------------------------------------------------------------------
 module Distribution.Client.InstallPlan (
   InstallPlan,
-  GenericInstallPlan,
+  GenericInstallPlan(planScore),
   PlanPackage,
   GenericPlanPackage(..),
   IsUnit,
@@ -216,7 +216,10 @@ instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) =>
 
 data GenericInstallPlan ipkg srcpkg = GenericInstallPlan {
     planGraph      :: !(Graph (GenericPlanPackage ipkg srcpkg)),
-    planIndepGoals :: !IndependentGoals
+    planIndepGoals :: !IndependentGoals,
+
+    -- TODO: This field can be removed if we don't print the install plan score.
+    planScore      :: !InstallPlanScore
   }
   deriving (Typeable)
 
@@ -230,12 +233,14 @@ mkInstallPlan :: (IsUnit ipkg, IsUnit srcpkg)
               => String
               -> Graph (GenericPlanPackage ipkg srcpkg)
               -> IndependentGoals
+              -> InstallPlanScore
               -> GenericInstallPlan ipkg srcpkg
-mkInstallPlan loc graph indepGoals =
+mkInstallPlan loc graph indepGoals score =
     assert (valid loc graph)
     GenericInstallPlan {
       planGraph      = graph,
-      planIndepGoals = indepGoals
+      planIndepGoals = indepGoals,
+      planScore      = score
     }
 
 internalError :: String -> String -> a
@@ -247,12 +252,13 @@ instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId,
        => Binary (GenericInstallPlan ipkg srcpkg) where
     put GenericInstallPlan {
               planGraph      = graph,
-              planIndepGoals = indepGoals
-        } = put (graph, indepGoals)
+              planIndepGoals = indepGoals,
+              planScore      = score
+        } = put (graph, indepGoals, score)
 
     get = do
-      (graph, indepGoals) <- get
-      return $! mkInstallPlan "(instance Binary)" graph indepGoals
+      (graph, indepGoals, score) <- get
+      return $! mkInstallPlan "(instance Binary)" graph indepGoals score
 
 showPlanGraph :: (Package ipkg, Package srcpkg,
                   IsUnit ipkg, IsUnit srcpkg)
@@ -279,9 +285,10 @@ showPlanPackageTag (Installed   _)   = "Installed"
 --
 new :: (IsUnit ipkg, IsUnit srcpkg)
     => IndependentGoals
+    -> InstallPlanScore
     -> Graph (GenericPlanPackage ipkg srcpkg)
     -> GenericInstallPlan ipkg srcpkg
-new indepGoals graph = mkInstallPlan "new" graph indepGoals
+new indepGoals score graph = mkInstallPlan "new" graph indepGoals score
 
 toGraph :: GenericInstallPlan ipkg srcpkg
         -> Graph (GenericPlanPackage ipkg srcpkg)
@@ -312,7 +319,7 @@ remove :: (IsUnit ipkg, IsUnit srcpkg)
        -> GenericInstallPlan ipkg srcpkg
        -> GenericInstallPlan ipkg srcpkg
 remove shouldRemove plan =
-    mkInstallPlan "remove" newGraph (planIndepGoals plan)
+    mkInstallPlan "remove" newGraph (planIndepGoals plan) (planScore plan)
   where
     newGraph = Graph.fromDistinctList $
                  filter (not . shouldRemove) (toList plan)
@@ -418,6 +425,7 @@ fromSolverInstallPlan f plan =
     mkInstallPlan "fromSolverInstallPlan"
       (Graph.fromDistinctList pkgs'')
       (SolverInstallPlan.planIndepGoals plan)
+      (SolverInstallPlan.planScore plan)
   where
     (_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, [])
                         (SolverInstallPlan.reverseTopologicalOrder plan)
@@ -455,6 +463,7 @@ fromSolverInstallPlanWithProgress f plan = do
     return $ mkInstallPlan "fromSolverInstallPlanWithProgress"
                (Graph.fromDistinctList pkgs'')
                (SolverInstallPlan.planIndepGoals plan)
+               (SolverInstallPlan.planScore plan)
   where
     f' (pidMap, ipiMap, pkgs) pkg = do
         pkgs' <- f (mapDep pidMap ipiMap) pkg

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

@@ -300,6 +300,7 @@ convertLegacyAllPackageFlags globalFlags configFlags
     --installOverrideReinstall  = projectConfigOverrideReinstall,
       installIndexState         = projectConfigIndexState,
       installMaxBackjumps       = projectConfigMaxBackjumps,
+    --installMaxScore           = projectConfigMaxScore,
     --installUpgradeDeps        = projectConfigUpgradeDeps,
       installReorderGoals       = projectConfigReorderGoals,
       installCountConflicts     = projectConfigCountConflicts,
@@ -497,7 +498,9 @@ convertToLegacySharedConfig
       installAvoidReinstalls   = mempty, --projectConfigAvoidReinstalls,
       installOverrideReinstall = mempty, --projectConfigOverrideReinstall,
       installMaxBackjumps      = projectConfigMaxBackjumps,
+      installMaxScore          = mempty, --projectConfigMaxScore,
       installUpgradeDeps       = mempty, --projectConfigUpgradeDeps,
+      installFindBestSolution  = mempty, --projectConfigFindBestSolution,
       installReorderGoals      = projectConfigReorderGoals,
       installCountConflicts    = projectConfigCountConflicts,
       installIndependentGoals  = mempty, --projectConfigIndependentGoals,

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -1839,7 +1839,7 @@ getComponentId (InstallPlan.Installed elab) = elabComponentId elab
 
 instantiateInstallPlan :: ElaboratedInstallPlan -> ElaboratedInstallPlan
 instantiateInstallPlan plan =
-    InstallPlan.new (IndependentGoals False)
+    InstallPlan.new (IndependentGoals False) (InstallPlan.planScore plan)
                     (Graph.fromDistinctList (Map.elems ready_map))
   where
     pkgs = InstallPlan.toList plan
@@ -2057,7 +2057,7 @@ elabBuildTargetWholeComponents elab =
 pruneInstallPlanToTargets :: Map UnitId [PackageTarget]
                           -> ElaboratedInstallPlan -> ElaboratedInstallPlan
 pruneInstallPlanToTargets perPkgTargetsMap elaboratedPlan =
-    InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan)
+    InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) (InstallPlan.planScore elaboratedPlan)
   . Graph.fromDistinctList
     -- We have to do this in two passes
   . pruneInstallPlanPass2
@@ -2357,7 +2357,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan =
     assert (all (isJust . InstallPlan.lookup installPlan)
                 (Set.toList pkgTargets)) $
 
-    fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan))
+    fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan) (InstallPlan.planScore installPlan))
   . checkBrokenDeps
   . Graph.fromDistinctList
   . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets)