Skip to content

Commit 26445e1

Browse files
grayjaygrayjay
committed
Add option to specify minimum install plan quality
1 parent 398db90 commit 26445e1

File tree

24 files changed

+329
-96
lines changed

24 files changed

+329
-96
lines changed

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

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

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

Lines changed: 22 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -57,6 +57,7 @@ module Distribution.Client.Dependency (
5757
setSolveExecutables,
5858
setGoalOrder,
5959
setSolverVerbosity,
60+
setMaxScore,
6061
removeLowerBounds,
6162
removeUpperBounds,
6263
addDefaultSetupDependencies,
@@ -176,7 +177,8 @@ data DepResolverParams = DepResolverParams {
176177

177178
-- | Function to override the solver's goal-ordering heuristics.
178179
depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering),
179-
depResolverVerbosity :: Verbosity
180+
depResolverVerbosity :: Verbosity,
181+
depResolverMaxScore :: Maybe InstallPlanScore
180182
}
181183

182184
showDepResolverParams :: DepResolverParams -> String
@@ -255,7 +257,8 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
255257
depResolverEnableBackjumping = EnableBackjumping True,
256258
depResolverSolveExecutables = SolveExecutables True,
257259
depResolverGoalOrder = Nothing,
258-
depResolverVerbosity = normal
260+
depResolverVerbosity = normal,
261+
depResolverMaxScore = Nothing
259262
}
260263

261264
addTargets :: [PackageName]
@@ -362,6 +365,12 @@ setSolverVerbosity verbosity params =
362365
depResolverVerbosity = verbosity
363366
}
364367

368+
setMaxScore :: Maybe InstallPlanScore -> DepResolverParams -> DepResolverParams
369+
setMaxScore n params =
370+
params {
371+
depResolverMaxScore = n
372+
}
373+
365374
-- | Some packages are specific to a given compiler version and should never be
366375
-- upgraded.
367376
dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams
@@ -659,18 +668,19 @@ resolveDependencies :: Platform
659668
--TODO: is this needed here? see dontUpgradeNonUpgradeablePackages
660669
resolveDependencies platform comp _pkgConfigDB _solver params
661670
| Set.null (depResolverTargets params)
662-
= return (validateSolverResult platform comp indGoals [])
671+
= return
672+
(validateSolverResult platform comp indGoals [] defaultInstallPlanScore)
663673
where
664674
indGoals = depResolverIndependentGoals params
665675

666676
resolveDependencies platform comp pkgConfigDB solver params =
667677

668678
Step (showDepResolverParams finalparams)
669-
$ fmap (validateSolverResult platform comp indGoals)
679+
$ fmap (uncurry $ validateSolverResult platform comp indGoals)
670680
$ runSolver solver (SolverConfig reordGoals cntConflicts
671681
indGoals noReinstalls
672682
shadowing strFlags allowBootLibs maxBkjumps enableBj
673-
solveExes order verbosity)
683+
solveExes order verbosity mScore)
674684
platform comp installedPkgIndex sourcePkgIndex
675685
pkgConfigDB preferences constraints targets
676686
where
@@ -691,7 +701,8 @@ resolveDependencies platform comp pkgConfigDB solver params =
691701
enableBj
692702
solveExes
693703
order
694-
verbosity) =
704+
verbosity
705+
mScore) =
695706
if asBool (depResolverAllowBootLibInstalls params)
696707
then params
697708
else dontUpgradeNonUpgradeablePackages params
@@ -749,10 +760,11 @@ validateSolverResult :: Platform
749760
-> CompilerInfo
750761
-> IndependentGoals
751762
-> [ResolverPackage UnresolvedPkgLoc]
763+
-> InstallPlanScore
752764
-> SolverInstallPlan
753-
validateSolverResult platform comp indepGoals pkgs =
765+
validateSolverResult platform comp indepGoals pkgs score =
754766
case planPackagesProblems platform comp pkgs of
755-
[] -> case SolverInstallPlan.new indepGoals graph of
767+
[] -> case SolverInstallPlan.new indepGoals score graph of
756768
Right plan -> plan
757769
Left problems -> error (formatPlanProblems problems)
758770
problems -> error (formatPkgProblems problems)
@@ -927,7 +939,8 @@ resolveWithoutDependencies (DepResolverParams targets constraints
927939
prefs defpref installedPkgIndex sourcePkgIndex
928940
_reorderGoals _countConflicts _indGoals _avoidReinstalls
929941
_shadowing _strFlags _maxBjumps _enableBj
930-
_solveExes _allowBootLibInstalls _order _verbosity) =
942+
_solveExes _allowBootLibInstalls _order _verbosity
943+
_maxScore) =
931944
collectEithers $ map selectPackage (Set.toList targets)
932945
where
933946
selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage

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

Lines changed: 8 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -380,6 +380,8 @@ planPackages verbosity comp platform mSandboxPkgInfo solver
380380
setMaxBackjumps (if maxBackjumps < 0 then Nothing
381381
else Just maxBackjumps)
382382

383+
. setMaxScore maxScore
384+
383385
. setIndependentGoals independentGoals
384386

385387
. setReorderGoals reorderGoals
@@ -456,6 +458,7 @@ planPackages verbosity comp platform mSandboxPkgInfo solver
456458
strongFlags = fromFlag (installStrongFlags installFlags)
457459
maxBackjumps = fromFlag (installMaxBackjumps installFlags)
458460
allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags)
461+
maxScore = flagToMaybe (installMaxScore installFlags)
459462
upgradeDeps = fromFlag (installUpgradeDeps installFlags)
460463
onlyDeps = fromFlag (installOnlyDeps installFlags)
461464
allowOlder = fromMaybe (AllowOlder RelaxDepsNone)
@@ -556,7 +559,7 @@ checkPrintPlan verbosity installed installPlan sourcePkgDb
556559
-- with a dangerous install plan.
557560
when (dryRun || containsReinstalls && not overrideReinstall) $
558561
printPlan (dryRun || breaksPkgs && not overrideReinstall)
559-
adaptedVerbosity lPlan sourcePkgDb
562+
adaptedVerbosity lPlan (InstallPlan.planScore installPlan) sourcePkgDb
560563

561564
-- If the install plan is dangerous, we print various warning messages. In
562565
-- particular, if we can see that packages are likely to be broken, we even
@@ -647,9 +650,12 @@ packageStatus installedPkgIndex cpkg =
647650
printPlan :: Bool -- is dry run
648651
-> Verbosity
649652
-> [(ReadyPackage, PackageStatus)]
653+
-> InstallPlanScore
650654
-> SourcePackageDb
651655
-> IO ()
652-
printPlan dryRun verbosity plan sourcePkgDb = case plan of
656+
printPlan dryRun verbosity plan score sourcePkgDb = do
657+
notice verbosity $ "Install plan score: " ++ showInstallPlanScore score
658+
case plan of
653659
[] -> return ()
654660
pkgs
655661
| verbosity >= Verbosity.verbose -> putStr $ unlines $

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

Lines changed: 19 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,7 @@
2020
-----------------------------------------------------------------------------
2121
module Distribution.Client.InstallPlan (
2222
InstallPlan,
23-
GenericInstallPlan,
23+
GenericInstallPlan(planScore),
2424
PlanPackage,
2525
GenericPlanPackage(..),
2626
IsUnit,
@@ -216,7 +216,10 @@ instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) =>
216216

217217
data GenericInstallPlan ipkg srcpkg = GenericInstallPlan {
218218
planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)),
219-
planIndepGoals :: !IndependentGoals
219+
planIndepGoals :: !IndependentGoals,
220+
221+
-- TODO: This field can be removed if we don't print the install plan score.
222+
planScore :: !InstallPlanScore
220223
}
221224
deriving (Typeable)
222225

@@ -230,12 +233,14 @@ mkInstallPlan :: (IsUnit ipkg, IsUnit srcpkg)
230233
=> String
231234
-> Graph (GenericPlanPackage ipkg srcpkg)
232235
-> IndependentGoals
236+
-> InstallPlanScore
233237
-> GenericInstallPlan ipkg srcpkg
234-
mkInstallPlan loc graph indepGoals =
238+
mkInstallPlan loc graph indepGoals score =
235239
assert (valid loc graph)
236240
GenericInstallPlan {
237241
planGraph = graph,
238-
planIndepGoals = indepGoals
242+
planIndepGoals = indepGoals,
243+
planScore = score
239244
}
240245

241246
internalError :: String -> String -> a
@@ -247,12 +252,13 @@ instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId,
247252
=> Binary (GenericInstallPlan ipkg srcpkg) where
248253
put GenericInstallPlan {
249254
planGraph = graph,
250-
planIndepGoals = indepGoals
251-
} = put (graph, indepGoals)
255+
planIndepGoals = indepGoals,
256+
planScore = score
257+
} = put (graph, indepGoals, score)
252258

253259
get = do
254-
(graph, indepGoals) <- get
255-
return $! mkInstallPlan "(instance Binary)" graph indepGoals
260+
(graph, indepGoals, score) <- get
261+
return $! mkInstallPlan "(instance Binary)" graph indepGoals score
256262

257263
showPlanGraph :: (Package ipkg, Package srcpkg,
258264
IsUnit ipkg, IsUnit srcpkg)
@@ -279,9 +285,10 @@ showPlanPackageTag (Installed _) = "Installed"
279285
--
280286
new :: (IsUnit ipkg, IsUnit srcpkg)
281287
=> IndependentGoals
288+
-> InstallPlanScore
282289
-> Graph (GenericPlanPackage ipkg srcpkg)
283290
-> GenericInstallPlan ipkg srcpkg
284-
new indepGoals graph = mkInstallPlan "new" graph indepGoals
291+
new indepGoals score graph = mkInstallPlan "new" graph indepGoals score
285292

286293
toGraph :: GenericInstallPlan ipkg srcpkg
287294
-> Graph (GenericPlanPackage ipkg srcpkg)
@@ -312,7 +319,7 @@ remove :: (IsUnit ipkg, IsUnit srcpkg)
312319
-> GenericInstallPlan ipkg srcpkg
313320
-> GenericInstallPlan ipkg srcpkg
314321
remove shouldRemove plan =
315-
mkInstallPlan "remove" newGraph (planIndepGoals plan)
322+
mkInstallPlan "remove" newGraph (planIndepGoals plan) (planScore plan)
316323
where
317324
newGraph = Graph.fromDistinctList $
318325
filter (not . shouldRemove) (toList plan)
@@ -418,6 +425,7 @@ fromSolverInstallPlan f plan =
418425
mkInstallPlan "fromSolverInstallPlan"
419426
(Graph.fromDistinctList pkgs'')
420427
(SolverInstallPlan.planIndepGoals plan)
428+
(SolverInstallPlan.planScore plan)
421429
where
422430
(_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, [])
423431
(SolverInstallPlan.reverseTopologicalOrder plan)
@@ -455,6 +463,7 @@ fromSolverInstallPlanWithProgress f plan = do
455463
return $ mkInstallPlan "fromSolverInstallPlanWithProgress"
456464
(Graph.fromDistinctList pkgs'')
457465
(SolverInstallPlan.planIndepGoals plan)
466+
(SolverInstallPlan.planScore plan)
458467
where
459468
f' (pidMap, ipiMap, pkgs) pkg = do
460469
pkgs' <- f (mapDep pidMap ipiMap) pkg

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -300,6 +300,7 @@ convertLegacyAllPackageFlags globalFlags configFlags
300300
--installOverrideReinstall = projectConfigOverrideReinstall,
301301
installIndexState = projectConfigIndexState,
302302
installMaxBackjumps = projectConfigMaxBackjumps,
303+
--installMaxScore = projectConfigMaxScore,
303304
--installUpgradeDeps = projectConfigUpgradeDeps,
304305
installReorderGoals = projectConfigReorderGoals,
305306
installCountConflicts = projectConfigCountConflicts,
@@ -497,6 +498,7 @@ convertToLegacySharedConfig
497498
installAvoidReinstalls = mempty, --projectConfigAvoidReinstalls,
498499
installOverrideReinstall = mempty, --projectConfigOverrideReinstall,
499500
installMaxBackjumps = projectConfigMaxBackjumps,
501+
installMaxScore = mempty, --projectConfigMaxScore,
500502
installUpgradeDeps = mempty, --projectConfigUpgradeDeps,
501503
installReorderGoals = projectConfigReorderGoals,
502504
installCountConflicts = projectConfigCountConflicts,

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

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1839,7 +1839,7 @@ getComponentId (InstallPlan.Installed elab) = elabComponentId elab
18391839

18401840
instantiateInstallPlan :: ElaboratedInstallPlan -> ElaboratedInstallPlan
18411841
instantiateInstallPlan plan =
1842-
InstallPlan.new (IndependentGoals False)
1842+
InstallPlan.new (IndependentGoals False) (InstallPlan.planScore plan)
18431843
(Graph.fromDistinctList (Map.elems ready_map))
18441844
where
18451845
pkgs = InstallPlan.toList plan
@@ -2057,7 +2057,7 @@ elabBuildTargetWholeComponents elab =
20572057
pruneInstallPlanToTargets :: Map UnitId [PackageTarget]
20582058
-> ElaboratedInstallPlan -> ElaboratedInstallPlan
20592059
pruneInstallPlanToTargets perPkgTargetsMap elaboratedPlan =
2060-
InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan)
2060+
InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) (InstallPlan.planScore elaboratedPlan)
20612061
. Graph.fromDistinctList
20622062
-- We have to do this in two passes
20632063
. pruneInstallPlanPass2
@@ -2357,7 +2357,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan =
23572357
assert (all (isJust . InstallPlan.lookup installPlan)
23582358
(Set.toList pkgTargets)) $
23592359

2360-
fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan))
2360+
fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan) (InstallPlan.planScore installPlan))
23612361
. checkBrokenDeps
23622362
. Graph.fromDistinctList
23632363
. filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets)

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

Lines changed: 20 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -109,7 +109,7 @@ import Distribution.Text
109109
import Distribution.ReadE
110110
( ReadE(..), readP_to_E, succeedReadE )
111111
import qualified Distribution.Compat.ReadP as Parse
112-
( ReadP, char, munch1, pfail, sepBy1, (+++) )
112+
( ReadP, readS_to_P, char, munch1, pfail, sepBy1, (+++) )
113113
import Distribution.ParseUtils
114114
( readPToMaybe )
115115
import Distribution.Verbosity
@@ -681,6 +681,7 @@ data FetchFlags = FetchFlags {
681681
fetchDryRun :: Flag Bool,
682682
fetchSolver :: Flag PreSolver,
683683
fetchMaxBackjumps :: Flag Int,
684+
fetchMaxScore :: Flag InstallPlanScore,
684685
fetchReorderGoals :: Flag ReorderGoals,
685686
fetchCountConflicts :: Flag CountConflicts,
686687
fetchIndependentGoals :: Flag IndependentGoals,
@@ -697,6 +698,7 @@ defaultFetchFlags = FetchFlags {
697698
fetchDryRun = toFlag False,
698699
fetchSolver = Flag defaultSolver,
699700
fetchMaxBackjumps = Flag defaultMaxBackjumps,
701+
fetchMaxScore = mempty,
700702
fetchReorderGoals = Flag (ReorderGoals False),
701703
fetchCountConflicts = Flag (CountConflicts True),
702704
fetchIndependentGoals = Flag (IndependentGoals False),
@@ -745,6 +747,7 @@ fetchCommand = CommandUI {
745747
optionSolver fetchSolver (\v flags -> flags { fetchSolver = v }) :
746748
optionSolverFlags showOrParseArgs
747749
fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v })
750+
fetchMaxScore (\v flags -> flags { fetchMaxScore = v })
748751
fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v })
749752
fetchCountConflicts (\v flags -> flags { fetchCountConflicts = v })
750753
fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
@@ -764,6 +767,7 @@ data FreezeFlags = FreezeFlags {
764767
freezeBenchmarks :: Flag Bool,
765768
freezeSolver :: Flag PreSolver,
766769
freezeMaxBackjumps :: Flag Int,
770+
freezeMaxScore :: Flag InstallPlanScore,
767771
freezeReorderGoals :: Flag ReorderGoals,
768772
freezeCountConflicts :: Flag CountConflicts,
769773
freezeIndependentGoals :: Flag IndependentGoals,
@@ -780,6 +784,7 @@ defaultFreezeFlags = FreezeFlags {
780784
freezeBenchmarks = toFlag False,
781785
freezeSolver = Flag defaultSolver,
782786
freezeMaxBackjumps = Flag defaultMaxBackjumps,
787+
freezeMaxScore = mempty,
783788
freezeReorderGoals = Flag (ReorderGoals False),
784789
freezeCountConflicts = Flag (CountConflicts True),
785790
freezeIndependentGoals = Flag (IndependentGoals False),
@@ -831,6 +836,7 @@ freezeCommand = CommandUI {
831836
freezeSolver (\v flags -> flags { freezeSolver = v }):
832837
optionSolverFlags showOrParseArgs
833838
freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v })
839+
freezeMaxScore (\v flags -> flags { freezeMaxScore = v })
834840
freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v })
835841
freezeCountConflicts (\v flags -> flags { freezeCountConflicts = v })
836842
freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })
@@ -1396,6 +1402,7 @@ data InstallFlags = InstallFlags {
13961402
installHaddockIndex :: Flag PathTemplate,
13971403
installDryRun :: Flag Bool,
13981404
installMaxBackjumps :: Flag Int,
1405+
installMaxScore :: Flag InstallPlanScore,
13991406
installReorderGoals :: Flag ReorderGoals,
14001407
installCountConflicts :: Flag CountConflicts,
14011408
installIndependentGoals :: Flag IndependentGoals,
@@ -1439,6 +1446,7 @@ defaultInstallFlags = InstallFlags {
14391446
installHaddockIndex = Flag docIndexFile,
14401447
installDryRun = Flag False,
14411448
installMaxBackjumps = Flag defaultMaxBackjumps,
1449+
installMaxScore = mempty,
14421450
installReorderGoals = Flag (ReorderGoals False),
14431451
installCountConflicts = Flag (CountConflicts True),
14441452
installIndependentGoals= Flag (IndependentGoals False),
@@ -1588,6 +1596,7 @@ installOptions showOrParseArgs =
15881596

15891597
optionSolverFlags showOrParseArgs
15901598
installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v })
1599+
installMaxScore (\v flags -> flags { installMaxScore = v })
15911600
installReorderGoals (\v flags -> flags { installReorderGoals = v })
15921601
installCountConflicts (\v flags -> flags { installCountConflicts = v })
15931602
installIndependentGoals (\v flags -> flags { installIndependentGoals = v })
@@ -2371,22 +2380,31 @@ optionSolver get set =
23712380
(toFlag `fmap` parse))
23722381
(flagToList . fmap display))
23732382

2383+
-- TODO: Add new solver options to fetch and freeze.
23742384
optionSolverFlags :: ShowOrParseArgs
23752385
-> (flags -> Flag Int ) -> (Flag Int -> flags -> flags)
2386+
-> (flags -> Flag InstallPlanScore) -> (Flag InstallPlanScore -> flags -> flags)
23762387
-> (flags -> Flag ReorderGoals) -> (Flag ReorderGoals -> flags -> flags)
23772388
-> (flags -> Flag CountConflicts) -> (Flag CountConflicts -> flags -> flags)
23782389
-> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags)
23792390
-> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags)
23802391
-> (flags -> Flag StrongFlags) -> (Flag StrongFlags -> flags -> flags)
23812392
-> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags)
23822393
-> [OptionField flags]
2383-
optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc _getig _setig
2394+
optionSolverFlags showOrParseArgs getmbj setmbj getms setms getrg setrg getcc setcc _getig _setig
23842395
getsip setsip getstrfl setstrfl getib setib =
23852396
[ option [] ["max-backjumps"]
23862397
("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.")
23872398
getmbj setmbj
23882399
(reqArg "NUM" (readP_to_E ("Cannot parse number: "++) (fmap toFlag parse))
23892400
(map show . flagToList))
2401+
, option [] ["max-score"]
2402+
"Maximum score for the install plan."
2403+
(fmap unInstallPlanScore . getms)
2404+
(setms . fmap InstallPlanScore)
2405+
(reqArg "NUM" (readP_to_E ("Cannot parse number: "++)
2406+
(fmap toFlag (Parse.readS_to_P reads)))
2407+
(map show . flagToList))
23902408
, option [] ["reorder-goals"]
23912409
"Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages."
23922410
(fmap asBool . getrg)

0 commit comments

Comments
 (0)