Skip to content

Commit 17d6ecb

Browse files
sebrightsebright
committed
Add option to specify minimum install plan quality
1 parent 8a7eb35 commit 17d6ecb

24 files changed

+390
-157
lines changed

‎cabal-install/Distribution/Client/Config.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -238,6 +238,7 @@ instance Semigroup SavedConfig where
238238
installHaddockIndex = combine installHaddockIndex,
239239
installDryRun = combine installDryRun,
240240
installMaxBackjumps = combine installMaxBackjumps,
241+
installMaxScore = combine installMaxScore,
241242
installReorderGoals = combine installReorderGoals,
242243
installCountConflicts = combine installCountConflicts,
243244
installIndependentGoals = combine installIndependentGoals,

‎cabal-install/Distribution/Client/Dependency.hs

Lines changed: 22 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -52,6 +52,7 @@ module Distribution.Client.Dependency (
5252
setMaxBackjumps,
5353
setEnableBackjumping,
5454
setGoalOrder,
55+
setMaxScore,
5556
removeLowerBounds,
5657
removeUpperBounds,
5758
addDefaultSetupDependencies,
@@ -160,7 +161,8 @@ data DepResolverParams = DepResolverParams {
160161
depResolverEnableBackjumping :: EnableBackjumping,
161162

162163
-- | Function to override the solver's goal-ordering heuristics.
163-
depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
164+
depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering),
165+
depResolverMaxScore :: Maybe InstallPlanScore
164166
}
165167

166168
showDepResolverParams :: DepResolverParams -> String
@@ -235,7 +237,8 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
235237
depResolverStrongFlags = StrongFlags False,
236238
depResolverMaxBackjumps = Nothing,
237239
depResolverEnableBackjumping = EnableBackjumping True,
238-
depResolverGoalOrder = Nothing
240+
depResolverGoalOrder = Nothing,
241+
depResolverMaxScore = Nothing
239242
}
240243

241244
addTargets :: [PackageName]
@@ -324,6 +327,12 @@ setGoalOrder order params =
324327
depResolverGoalOrder = order
325328
}
326329

330+
setMaxScore :: Maybe InstallPlanScore -> DepResolverParams -> DepResolverParams
331+
setMaxScore n params =
332+
params {
333+
depResolverMaxScore = n
334+
}
335+
327336
-- | Some packages are specific to a given compiler version and should never be
328337
-- upgraded.
329338
dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams
@@ -599,17 +608,17 @@ resolveDependencies :: Platform
599608
--TODO: is this needed here? see dontUpgradeNonUpgradeablePackages
600609
resolveDependencies platform comp _pkgConfigDB _solver params
601610
| null (depResolverTargets params)
602-
= return (validateSolverResult platform comp indGoals [])
611+
= return
612+
(validateSolverResult platform comp indGoals [] defaultInstallPlanScore)
603613
where
604614
indGoals = depResolverIndependentGoals params
605615

606616
resolveDependencies platform comp pkgConfigDB solver params =
607617

608618
Step (showDepResolverParams finalparams)
609-
$ fmap (validateSolverResult platform comp indGoals)
610-
$ runSolver solver (SolverConfig reordGoals cntConflicts
611-
indGoals noReinstalls
612-
shadowing strFlags maxBkjumps enableBj order)
619+
$ fmap (uncurry $ validateSolverResult platform comp indGoals)
620+
$ runSolver solver (SolverConfig reordGoals cntConflicts indGoals noReinstalls
621+
shadowing strFlags maxBkjumps enableBj order mScore)
613622
platform comp installedPkgIndex sourcePkgIndex
614623
pkgConfigDB preferences constraints targets
615624
where
@@ -627,7 +636,8 @@ resolveDependencies platform comp pkgConfigDB solver params =
627636
strFlags
628637
maxBkjumps
629638
enableBj
630-
order) = dontUpgradeNonUpgradeablePackages params
639+
order
640+
mScore) = dontUpgradeNonUpgradeablePackages params
631641

632642
preferences = interpretPackagesPreference
633643
(Set.fromList targets) defpref prefs
@@ -683,10 +693,11 @@ validateSolverResult :: Platform
683693
-> CompilerInfo
684694
-> IndependentGoals
685695
-> [ResolverPackage UnresolvedPkgLoc]
696+
-> InstallPlanScore
686697
-> SolverInstallPlan
687-
validateSolverResult platform comp indepGoals pkgs =
698+
validateSolverResult platform comp indepGoals pkgs score =
688699
case planPackagesProblems platform comp pkgs of
689-
[] -> case SolverInstallPlan.new indepGoals index of
700+
[] -> case SolverInstallPlan.new indepGoals score index of
690701
Right plan -> plan
691702
Left problems -> error (formatPlanProblems problems)
692703
problems -> error (formatPkgProblems problems)
@@ -853,7 +864,7 @@ resolveWithoutDependencies :: DepResolverParams
853864
resolveWithoutDependencies (DepResolverParams targets constraints
854865
prefs defpref installedPkgIndex sourcePkgIndex
855866
_reorderGoals _countConflicts _indGoals _avoidReinstalls
856-
_shadowing _strFlags _maxBjumps _enableBj _order) =
867+
_shadowing _strFlags _maxBjumps _enableBj _order _maxScore) =
857868
collectEithers (map selectPackage targets)
858869
where
859870
selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage

‎cabal-install/Distribution/Client/Install.hs

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -119,6 +119,7 @@ import Distribution.Solver.Types.OptionalStanza
119119
import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex
120120
import Distribution.Solver.Types.PkgConfigDb
121121
( PkgConfigDb, readPkgConfigDb )
122+
import Distribution.Solver.Types.Settings
122123
import Distribution.Solver.Types.SourcePackage as SourcePackage
123124

124125
import Distribution.Utils.NubList
@@ -379,6 +380,8 @@ planPackages comp platform mSandboxPkgInfo solver
379380
setMaxBackjumps (if maxBackjumps < 0 then Nothing
380381
else Just maxBackjumps)
381382

383+
. setMaxScore maxScore
384+
382385
. setIndependentGoals independentGoals
383386

384387
. setReorderGoals reorderGoals
@@ -444,6 +447,7 @@ planPackages comp platform mSandboxPkgInfo solver
444447
shadowPkgs = fromFlag (installShadowPkgs installFlags)
445448
strongFlags = fromFlag (installStrongFlags installFlags)
446449
maxBackjumps = fromFlag (installMaxBackjumps installFlags)
450+
maxScore = flagToMaybe (installMaxScore installFlags)
447451
upgradeDeps = fromFlag (installUpgradeDeps installFlags)
448452
onlyDeps = fromFlag (installOnlyDeps installFlags)
449453
allowOlder = fromMaybe (AllowOlder RelaxDepsNone)
@@ -544,7 +548,7 @@ checkPrintPlan verbosity installed installPlan sourcePkgDb
544548
-- with a dangerous install plan.
545549
when (dryRun || containsReinstalls && not overrideReinstall) $
546550
printPlan (dryRun || breaksPkgs && not overrideReinstall)
547-
adaptedVerbosity lPlan sourcePkgDb
551+
adaptedVerbosity lPlan (InstallPlan.planScore installPlan) sourcePkgDb
548552

549553
-- If the install plan is dangerous, we print various warning messages. In
550554
-- particular, if we can see that packages are likely to be broken, we even
@@ -635,9 +639,12 @@ packageStatus installedPkgIndex cpkg =
635639
printPlan :: Bool -- is dry run
636640
-> Verbosity
637641
-> [(ReadyPackage, PackageStatus)]
642+
-> InstallPlanScore
638643
-> SourcePackageDb
639644
-> IO ()
640-
printPlan dryRun verbosity plan sourcePkgDb = case plan of
645+
printPlan dryRun verbosity plan score sourcePkgDb = do
646+
notice verbosity $ "Install plan score: " ++ showInstallPlanScore score
647+
case plan of
641648
[] -> return ()
642649
pkgs
643650
| verbosity >= Verbosity.verbose -> putStr $ unlines $

‎cabal-install/Distribution/Client/InstallPlan.hs

Lines changed: 18 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,7 @@
1919
-----------------------------------------------------------------------------
2020
module Distribution.Client.InstallPlan (
2121
InstallPlan,
22-
GenericInstallPlan,
22+
GenericInstallPlan(planScore),
2323
PlanPackage,
2424
GenericPlanPackage(..),
2525
IsUnit,
@@ -200,7 +200,10 @@ instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) =>
200200

201201
data GenericInstallPlan ipkg srcpkg = GenericInstallPlan {
202202
planIndex :: !(PlanIndex ipkg srcpkg),
203-
planIndepGoals :: !IndependentGoals
203+
planIndepGoals :: !IndependentGoals,
204+
205+
-- TODO: This field can be removed if we don't print the install plan score.
206+
planScore :: !InstallPlanScore
204207
}
205208

206209
-- | 'GenericInstallPlan' specialised to most commonly used types.
@@ -214,11 +217,13 @@ type PlanIndex ipkg srcpkg =
214217
--
215218
mkInstallPlan :: PlanIndex ipkg srcpkg
216219
-> IndependentGoals
220+
-> InstallPlanScore
217221
-> GenericInstallPlan ipkg srcpkg
218-
mkInstallPlan index indepGoals =
222+
mkInstallPlan index indepGoals score =
219223
GenericInstallPlan {
220224
planIndex = index,
221-
planIndepGoals = indepGoals
225+
planIndepGoals = indepGoals,
226+
planScore = score
222227
}
223228

224229
internalError :: String -> a
@@ -229,12 +234,13 @@ instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId,
229234
=> Binary (GenericInstallPlan ipkg srcpkg) where
230235
put GenericInstallPlan {
231236
planIndex = index,
232-
planIndepGoals = indepGoals
233-
} = put (index, indepGoals)
237+
planIndepGoals = indepGoals,
238+
planScore = score
239+
} = put (index, indepGoals, score)
234240

235241
get = do
236-
(index, indepGoals) <- get
237-
return $! mkInstallPlan index indepGoals
242+
(index, indepGoals, score) <- get
243+
return $! mkInstallPlan index indepGoals score
238244

239245
showPlanIndex :: (Package ipkg, Package srcpkg,
240246
IsUnit ipkg, IsUnit srcpkg)
@@ -259,9 +265,10 @@ showPlanPackageTag (Configured _) = "Configured"
259265
-- | Build an installation plan from a valid set of resolved packages.
260266
--
261267
new :: IndependentGoals
268+
-> InstallPlanScore
262269
-> PlanIndex ipkg srcpkg
263270
-> GenericInstallPlan ipkg srcpkg
264-
new indepGoals index = mkInstallPlan index indepGoals
271+
new indepGoals score index = mkInstallPlan index indepGoals score
265272

266273
toList :: GenericInstallPlan ipkg srcpkg
267274
-> [GenericPlanPackage ipkg srcpkg]
@@ -278,7 +285,7 @@ remove :: (IsUnit ipkg, IsUnit srcpkg)
278285
-> GenericInstallPlan ipkg srcpkg
279286
-> GenericInstallPlan ipkg srcpkg
280287
remove shouldRemove plan =
281-
new (planIndepGoals plan) newIndex
288+
new (planIndepGoals plan) (planScore plan) newIndex
282289
where
283290
newIndex = Graph.fromList $
284291
filter (not . shouldRemove) (toList plan)
@@ -387,6 +394,7 @@ fromSolverInstallPlan ::
387394
fromSolverInstallPlan f plan =
388395
mkInstallPlan (Graph.fromList pkgs'')
389396
(SolverInstallPlan.planIndepGoals plan)
397+
(SolverInstallPlan.planScore plan)
390398
where
391399
(_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, [])
392400
(SolverInstallPlan.reverseTopologicalOrder plan)

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -302,6 +302,7 @@ convertLegacyAllPackageFlags globalFlags configFlags
302302
--installAvoidReinstalls = projectConfigAvoidReinstalls,
303303
--installOverrideReinstall = projectConfigOverrideReinstall,
304304
installMaxBackjumps = projectConfigMaxBackjumps,
305+
--installMaxScore = projectConfigMaxScore,
305306
--installUpgradeDeps = projectConfigUpgradeDeps,
306307
installReorderGoals = projectConfigReorderGoals,
307308
installCountConflicts = projectConfigCountConflicts,
@@ -496,6 +497,7 @@ convertToLegacySharedConfig
496497
installAvoidReinstalls = mempty, --projectConfigAvoidReinstalls,
497498
installOverrideReinstall = mempty, --projectConfigOverrideReinstall,
498499
installMaxBackjumps = projectConfigMaxBackjumps,
500+
installMaxScore = mempty, --projectConfigMaxScore,
499501
installUpgradeDeps = mempty, --projectConfigUpgradeDeps,
500502
installReorderGoals = projectConfigReorderGoals,
501503
installCountConflicts = projectConfigCountConflicts,

‎cabal-install/Distribution/Client/ProjectPlanning.hs

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1686,13 +1686,13 @@ elabBuildTargetWholeComponents elab =
16861686
--
16871687
pruneInstallPlanToTargets :: Map UnitId [PackageTarget]
16881688
-> ElaboratedInstallPlan -> ElaboratedInstallPlan
1689-
pruneInstallPlanToTargets perPkgTargetsMap =
1690-
InstallPlan.new (IndependentGoals False)
1689+
pruneInstallPlanToTargets perPkgTargetsMap plan =
1690+
InstallPlan.new (IndependentGoals False) (InstallPlan.planScore plan)
16911691
. Graph.fromList
16921692
-- We have to do this in two passes
16931693
. pruneInstallPlanPass2
16941694
. pruneInstallPlanPass1 perPkgTargetsMap
1695-
. InstallPlan.toList
1695+
$ InstallPlan.toList plan
16961696

16971697
-- | This is a temporary data type, where we temporarily
16981698
-- override the graph dependencies of an 'ElaboratedPackage',

‎cabal-install/Distribution/Client/Setup.hs

Lines changed: 20 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -99,7 +99,7 @@ import Distribution.Text
9999
import Distribution.ReadE
100100
( ReadE(..), readP_to_E, succeedReadE )
101101
import qualified Distribution.Compat.ReadP as Parse
102-
( ReadP, char, munch1, pfail, (+++) )
102+
( ReadP, readS_to_P, char, munch1, pfail, (+++) )
103103
import Distribution.Compat.Semigroup
104104
import Distribution.Verbosity
105105
( Verbosity, normal )
@@ -606,6 +606,7 @@ data FetchFlags = FetchFlags {
606606
fetchDryRun :: Flag Bool,
607607
fetchSolver :: Flag PreSolver,
608608
fetchMaxBackjumps :: Flag Int,
609+
fetchMaxScore :: Flag InstallPlanScore,
609610
fetchReorderGoals :: Flag ReorderGoals,
610611
fetchCountConflicts :: Flag CountConflicts,
611612
fetchIndependentGoals :: Flag IndependentGoals,
@@ -621,6 +622,7 @@ defaultFetchFlags = FetchFlags {
621622
fetchDryRun = toFlag False,
622623
fetchSolver = Flag defaultSolver,
623624
fetchMaxBackjumps = Flag defaultMaxBackjumps,
625+
fetchMaxScore = mempty,
624626
fetchReorderGoals = Flag (ReorderGoals False),
625627
fetchCountConflicts = Flag (CountConflicts True),
626628
fetchIndependentGoals = Flag (IndependentGoals False),
@@ -668,6 +670,7 @@ fetchCommand = CommandUI {
668670
optionSolver fetchSolver (\v flags -> flags { fetchSolver = v }) :
669671
optionSolverFlags showOrParseArgs
670672
fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v })
673+
fetchMaxScore (\v flags -> flags { fetchMaxScore = v })
671674
fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v })
672675
fetchCountConflicts (\v flags -> flags { fetchCountConflicts = v })
673676
fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
@@ -686,6 +689,7 @@ data FreezeFlags = FreezeFlags {
686689
freezeBenchmarks :: Flag Bool,
687690
freezeSolver :: Flag PreSolver,
688691
freezeMaxBackjumps :: Flag Int,
692+
freezeMaxScore :: Flag InstallPlanScore,
689693
freezeReorderGoals :: Flag ReorderGoals,
690694
freezeCountConflicts :: Flag CountConflicts,
691695
freezeIndependentGoals :: Flag IndependentGoals,
@@ -701,6 +705,7 @@ defaultFreezeFlags = FreezeFlags {
701705
freezeBenchmarks = toFlag False,
702706
freezeSolver = Flag defaultSolver,
703707
freezeMaxBackjumps = Flag defaultMaxBackjumps,
708+
freezeMaxScore = mempty,
704709
freezeReorderGoals = Flag (ReorderGoals False),
705710
freezeCountConflicts = Flag (CountConflicts True),
706711
freezeIndependentGoals = Flag (IndependentGoals False),
@@ -747,6 +752,7 @@ freezeCommand = CommandUI {
747752
optionSolver freezeSolver (\v flags -> flags { freezeSolver = v }) :
748753
optionSolverFlags showOrParseArgs
749754
freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v })
755+
freezeMaxScore (\v flags -> flags { freezeMaxScore = v })
750756
freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v })
751757
freezeCountConflicts (\v flags -> flags { freezeCountConflicts = v })
752758
freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })
@@ -1150,6 +1156,7 @@ data InstallFlags = InstallFlags {
11501156
installHaddockIndex :: Flag PathTemplate,
11511157
installDryRun :: Flag Bool,
11521158
installMaxBackjumps :: Flag Int,
1159+
installMaxScore :: Flag InstallPlanScore,
11531160
installReorderGoals :: Flag ReorderGoals,
11541161
installCountConflicts :: Flag CountConflicts,
11551162
installIndependentGoals :: Flag IndependentGoals,
@@ -1183,6 +1190,7 @@ defaultInstallFlags = InstallFlags {
11831190
installHaddockIndex = Flag docIndexFile,
11841191
installDryRun = Flag False,
11851192
installMaxBackjumps = Flag defaultMaxBackjumps,
1193+
installMaxScore = mempty,
11861194
installReorderGoals = Flag (ReorderGoals False),
11871195
installCountConflicts = Flag (CountConflicts True),
11881196
installIndependentGoals= Flag (IndependentGoals False),
@@ -1329,6 +1337,7 @@ installOptions showOrParseArgs =
13291337

13301338
optionSolverFlags showOrParseArgs
13311339
installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v })
1340+
installMaxScore (\v flags -> flags { installMaxScore = v })
13321341
installReorderGoals (\v flags -> flags { installReorderGoals = v })
13331342
installCountConflicts (\v flags -> flags { installCountConflicts = v })
13341343
installIndependentGoals (\v flags -> flags { installIndependentGoals = v })
@@ -2092,20 +2101,29 @@ optionSolver get set =
20922101
(toFlag `fmap` parse))
20932102
(flagToList . fmap display))
20942103

2104+
-- TODO: Add new solver options to fetch and freeze.
20952105
optionSolverFlags :: ShowOrParseArgs
20962106
-> (flags -> Flag Int ) -> (Flag Int -> flags -> flags)
2107+
-> (flags -> Flag InstallPlanScore) -> (Flag InstallPlanScore -> flags -> flags)
20972108
-> (flags -> Flag ReorderGoals) -> (Flag ReorderGoals -> flags -> flags)
20982109
-> (flags -> Flag CountConflicts) -> (Flag CountConflicts -> flags -> flags)
20992110
-> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags)
21002111
-> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags)
21012112
-> (flags -> Flag StrongFlags) -> (Flag StrongFlags -> flags -> flags)
21022113
-> [OptionField flags]
2103-
optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc _getig _setig getsip setsip getstrfl setstrfl =
2114+
optionSolverFlags showOrParseArgs getmbj setmbj getms setms getrg setrg getcc setcc _getig _setig getsip setsip getstrfl setstrfl =
21042115
[ option [] ["max-backjumps"]
21052116
("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.")
21062117
getmbj setmbj
21072118
(reqArg "NUM" (readP_to_E ("Cannot parse number: "++) (fmap toFlag parse))
21082119
(map show . flagToList))
2120+
, option [] ["max-score"]
2121+
"Maximum score for the install plan."
2122+
(fmap unInstallPlanScore . getms)
2123+
(setms . fmap InstallPlanScore)
2124+
(reqArg "NUM" (readP_to_E ("Cannot parse number: "++)
2125+
(fmap toFlag (Parse.readS_to_P reads)))
2126+
(map show . flagToList))
21092127
, option [] ["reorder-goals"]
21102128
"Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages."
21112129
(fmap asBool . getrg)

0 commit comments

Comments
 (0)