Skip to content

Commit 8f32ab4

Browse files
23Skidoo23Skidoo
authored
Merge pull request #3510 from grayjay/issue-3489
Add a goal order parameter to the dependency solver
2 parents efe23a9 + bfdcd7e commit 8f32ab4

File tree

9 files changed

+247
-76
lines changed

9 files changed

+247
-76
lines changed

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

Lines changed: 21 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -54,6 +54,7 @@ module Distribution.Client.Dependency (
5454
setStrongFlags,
5555
setMaxBackjumps,
5656
setEnableBackjumping,
57+
setGoalOrder,
5758
addSourcePackages,
5859
hideInstalledPackagesSpecificByUnitId,
5960
hideInstalledPackagesSpecificBySourcePackageId,
@@ -119,6 +120,7 @@ import Distribution.Solver.Types.InstalledPreference
119120
import Distribution.Solver.Types.LabeledPackageConstraint
120121
import Distribution.Solver.Types.OptionalStanza
121122
import Distribution.Solver.Types.PackageConstraint
123+
import Distribution.Solver.Types.PackagePath
122124
import Distribution.Solver.Types.PackagePreferences
123125
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
124126
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
@@ -128,6 +130,7 @@ import Distribution.Solver.Types.Settings
128130
import Distribution.Solver.Types.SolverId
129131
import Distribution.Solver.Types.SolverPackage
130132
import Distribution.Solver.Types.SourcePackage
133+
import Distribution.Solver.Types.Variable
131134

132135
import Data.List
133136
( foldl', sort, sortBy, nubBy, maximumBy, intercalate, nub )
@@ -161,7 +164,10 @@ data DepResolverParams = DepResolverParams {
161164
depResolverShadowPkgs :: ShadowPkgs,
162165
depResolverStrongFlags :: StrongFlags,
163166
depResolverMaxBackjumps :: Maybe Int,
164-
depResolverEnableBackjumping :: EnableBackjumping
167+
depResolverEnableBackjumping :: EnableBackjumping,
168+
169+
-- | Function to override the solver's goal-ordering heuristics.
170+
depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
165171
}
166172

167173
showDepResolverParams :: DepResolverParams -> String
@@ -233,7 +239,8 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
233239
depResolverShadowPkgs = ShadowPkgs False,
234240
depResolverStrongFlags = StrongFlags False,
235241
depResolverMaxBackjumps = Nothing,
236-
depResolverEnableBackjumping = EnableBackjumping True
242+
depResolverEnableBackjumping = EnableBackjumping True,
243+
depResolverGoalOrder = Nothing
237244
}
238245

239246
addTargets :: [PackageName]
@@ -308,6 +315,14 @@ setEnableBackjumping b params =
308315
depResolverEnableBackjumping = b
309316
}
310317

318+
setGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
319+
-> DepResolverParams
320+
-> DepResolverParams
321+
setGoalOrder order params =
322+
params {
323+
depResolverGoalOrder = order
324+
}
325+
311326
-- | Some packages are specific to a given compiler version and should never be
312327
-- upgraded.
313328
dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams
@@ -607,7 +622,7 @@ resolveDependencies platform comp pkgConfigDB solver params =
607622
Step (showDepResolverParams finalparams)
608623
$ fmap (validateSolverResult platform comp indGoals)
609624
$ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls
610-
shadowing strFlags maxBkjumps enableBj)
625+
shadowing strFlags maxBkjumps enableBj order)
611626
platform comp installedPkgIndex sourcePkgIndex
612627
pkgConfigDB preferences constraints targets
613628
where
@@ -623,7 +638,8 @@ resolveDependencies platform comp pkgConfigDB solver params =
623638
shadowing
624639
strFlags
625640
maxBkjumps
626-
enableBj) = dontUpgradeNonUpgradeablePackages
641+
enableBj
642+
order) = dontUpgradeNonUpgradeablePackages
627643
-- TODO:
628644
-- The modular solver can properly deal with broken
629645
-- packages and won't select them. So the
@@ -858,7 +874,7 @@ resolveWithoutDependencies :: DepResolverParams
858874
resolveWithoutDependencies (DepResolverParams targets constraints
859875
prefs defpref installedPkgIndex sourcePkgIndex
860876
_reorderGoals _indGoals _avoidReinstalls
861-
_shadowing _strFlags _maxBjumps _enableBj) =
877+
_shadowing _strFlags _maxBjumps _enableBj _order) =
862878
collectEithers (map selectPackage targets)
863879
where
864880
selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,7 @@ module Distribution.Solver.Modular.Dependency (
3535
, GoalReason(..)
3636
, QGoalReason
3737
, ResetVar(..)
38+
, goalToVar
3839
, goalVarToConflictSet
3940
, varToConflictSet
4041
, goalReasonToVars
@@ -361,6 +362,9 @@ instance ResetVar Dep where
361362
instance ResetVar Var where
362363
resetVar = const
363364

365+
goalToVar :: Goal a -> Var a
366+
goalToVar (Goal v _) = v
367+
364368
-- | Compute a singleton conflict set from a goal, containing just
365369
-- the goal variable.
366370
--

‎cabal-install/Distribution/Solver/Modular/Preference.hs

Lines changed: 26 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -13,10 +13,12 @@ module Distribution.Solver.Modular.Preference
1313
, preferPackagePreferences
1414
, preferReallyEasyGoalChoices
1515
, requireInstalled
16+
, sortGoals
1617
) where
1718

1819
-- Reordering or pruning the tree in order to prefer or make certain choices.
1920

21+
import Data.Function (on)
2022
import qualified Data.List as L
2123
import qualified Data.Map as M
2224
#if !MIN_VERSION_base(4,8,0)
@@ -35,6 +37,7 @@ import Distribution.Solver.Types.OptionalStanza
3537
import Distribution.Solver.Types.PackageConstraint
3638
import Distribution.Solver.Types.PackagePath
3739
import Distribution.Solver.Types.PackagePreferences
40+
import Distribution.Solver.Types.Variable
3841

3942
import Distribution.Solver.Modular.Dependency
4043
import Distribution.Solver.Modular.Flag
@@ -191,8 +194,8 @@ processPackageConstraintS s c b' (LabeledPackageConstraint pc src) r = go pc
191194
-- by selectively disabling choices that have been ruled out by global user
192195
-- constraints.
193196
enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]
194-
-> Tree QGoalReason
195-
-> Tree QGoalReason
197+
-> Tree a
198+
-> Tree a
196199
enforcePackageConstraints pcs = trav go
197200
where
198201
go (PChoiceF qpn@(Q pp pn) gr ts) =
@@ -220,7 +223,7 @@ enforcePackageConstraints pcs = trav go
220223
-- be run after user preferences have been enforced. For manual flags,
221224
-- it checks if a user choice has been made. If not, it disables all but
222225
-- the first choice.
223-
enforceManualFlags :: Tree QGoalReason -> Tree QGoalReason
226+
enforceManualFlags :: Tree a -> Tree a
224227
enforceManualFlags = trav go
225228
where
226229
go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $
@@ -234,7 +237,7 @@ enforceManualFlags = trav go
234237
go x = x
235238

236239
-- | Require installed packages.
237-
requireInstalled :: (PN -> Bool) -> Tree QGoalReason -> Tree QGoalReason
240+
requireInstalled :: (PN -> Bool) -> Tree a -> Tree a
238241
requireInstalled p = trav go
239242
where
240243
go (PChoiceF v@(Q _ pn) gr cs)
@@ -258,7 +261,7 @@ requireInstalled p = trav go
258261
-- they are, perhaps this should just result in trying to reinstall those other
259262
-- packages as well. However, doing this all neatly in one pass would require to
260263
-- change the builder, or at least to change the goal set after building.
261-
avoidReinstalls :: (PN -> Bool) -> Tree QGoalReason -> Tree QGoalReason
264+
avoidReinstalls :: (PN -> Bool) -> Tree a -> Tree a
262265
avoidReinstalls p = trav go
263266
where
264267
go (PChoiceF qpn@(Q _ pn) gr cs)
@@ -275,6 +278,21 @@ avoidReinstalls p = trav go
275278
x
276279
go x = x
277280

281+
-- | Sort all goals using the provided function.
282+
sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree a -> Tree a
283+
sortGoals variableOrder = trav go
284+
where
285+
go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys goalOrder xs)
286+
go x = x
287+
288+
goalOrder :: Goal QPN -> Goal QPN -> Ordering
289+
goalOrder = variableOrder `on` (varToVariable . goalToVar)
290+
291+
varToVariable :: Var QPN -> Variable QPN
292+
varToVariable (P qpn) = PackageVar qpn
293+
varToVariable (F (FN (PI qpn _) fn)) = FlagVar qpn fn
294+
varToVariable (S (SN (PI qpn _) stanza)) = StanzaVar qpn stanza
295+
278296
-- | Always choose the first goal in the list next, abandoning all
279297
-- other choices.
280298
--
@@ -371,10 +389,10 @@ type EnforceSIR = Reader (Map (PI PN) QPN)
371389
-- (that is, package name + package version) there can be at most one qualified
372390
-- goal resolving to that instance (there may be other goals _linking_ to that
373391
-- instance however).
374-
enforceSingleInstanceRestriction :: Tree QGoalReason -> Tree QGoalReason
392+
enforceSingleInstanceRestriction :: Tree a -> Tree a
375393
enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go
376394
where
377-
go :: TreeF QGoalReason (EnforceSIR (Tree QGoalReason)) -> EnforceSIR (Tree QGoalReason)
395+
go :: TreeF a (EnforceSIR (Tree a)) -> EnforceSIR (Tree a)
378396

379397
-- We just verify package choices.
380398
go (PChoiceF qpn gr cs) =
@@ -383,7 +401,7 @@ enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go
383401
innM _otherwise
384402

385403
-- The check proper
386-
goP :: QPN -> POption -> EnforceSIR (Tree QGoalReason) -> EnforceSIR (Tree QGoalReason)
404+
goP :: QPN -> POption -> EnforceSIR (Tree a) -> EnforceSIR (Tree a)
387405
goP qpn@(Q _ pn) (POption i linkedTo) r = do
388406
let inst = PI pn i
389407
env <- ask

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

Lines changed: 19 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ import Distribution.Solver.Types.PackagePreferences
1919
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
2020
import Distribution.Solver.Types.LabeledPackageConstraint
2121
import Distribution.Solver.Types.Settings
22+
import Distribution.Solver.Types.Variable
2223

2324
import Distribution.Solver.Modular.Assignment
2425
import Distribution.Solver.Modular.Builder
@@ -56,7 +57,8 @@ data SolverConfig = SolverConfig {
5657
shadowPkgs :: ShadowPkgs,
5758
strongFlags :: StrongFlags,
5859
maxBackjumps :: Maybe Int,
59-
enableBackjumping :: EnableBackjumping
60+
enableBackjumping :: EnableBackjumping,
61+
goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
6062
}
6163

6264
-- | Run all solver phases.
@@ -103,15 +105,22 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
103105
where
104106
explorePhase = backjumpAndExplore (enableBackjumping sc)
105107
detectCycles = traceTree "cycles.json" id . detectCyclesPhase
106-
heuristicsPhase = (if asBool (preferEasyGoalChoices sc)
107-
then P.preferEasyGoalChoices -- also leaves just one choice
108-
else P.firstGoal) . -- after doing goal-choice heuristics, commit to the first choice (saves space)
109-
traceTree "heuristics.json" id .
110-
P.deferWeakFlagChoices .
111-
P.deferSetupChoices .
112-
P.preferBaseGoalChoice .
113-
P.preferLinked
114-
preferencesPhase = P.preferPackagePreferences userPrefs
108+
heuristicsPhase =
109+
let heuristicsTree = traceTree "heuristics.json" id
110+
in case goalOrder sc of
111+
Nothing -> (if asBool (preferEasyGoalChoices sc)
112+
then P.preferEasyGoalChoices -- also leaves just one choice
113+
else P.firstGoal) . -- after doing goal-choice heuristics,
114+
-- commit to the first choice (saves space)
115+
heuristicsTree .
116+
P.deferWeakFlagChoices .
117+
P.deferSetupChoices .
118+
P.preferBaseGoalChoice
119+
Just order -> P.firstGoal .
120+
heuristicsTree .
121+
P.sortGoals order
122+
preferencesPhase = P.preferLinked .
123+
P.preferPackagePreferences userPrefs
115124
validationPhase = traceTree "validated.json" id .
116125
P.enforceManualFlags . -- can only be done after user constraints
117126
P.enforcePackageConstraints userConstraints .

‎cabal-install/Distribution/Solver/Types/Variable.hs

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
module Distribution.Solver.Types.Variable where
2+
3+
import Distribution.Solver.Types.OptionalStanza
4+
5+
import Distribution.PackageDescription (FlagName)
6+
7+
-- | Variables used by the dependency solver. This type is similar to the
8+
-- internal 'Var' type, except that flags and stanzas are associated with
9+
-- package names instead of package instances.
10+
data Variable qpn =
11+
PackageVar qpn
12+
| FlagVar qpn FlagName
13+
| StanzaVar qpn OptionalStanza
14+
deriving Eq

‎cabal-install/cabal-install.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -281,6 +281,7 @@ executable cabal
281281
Distribution.Solver.Types.SolverId
282282
Distribution.Solver.Types.SolverPackage
283283
Distribution.Solver.Types.SourcePackage
284+
Distribution.Solver.Types.Variable
284285
Distribution.Solver.Modular
285286
Distribution.Solver.Modular.Assignment
286287
Distribution.Solver.Modular.Builder

‎cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs

Lines changed: 44 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,8 @@ module UnitTests.Distribution.Solver.Modular.DSL (
1111
, ExamplePkgName
1212
, ExampleAvailable(..)
1313
, ExampleInstalled(..)
14+
, ExampleQualifier(..)
15+
, ExampleVar(..)
1416
, exAv
1517
, exInst
1618
, exFlag
@@ -23,9 +25,10 @@ module UnitTests.Distribution.Solver.Modular.DSL (
2325

2426
-- base
2527
import Data.Either (partitionEithers)
26-
import Data.Maybe (catMaybes)
27-
import Data.List (nub)
28+
import Data.Maybe (catMaybes, isNothing)
29+
import Data.List (elemIndex, nub)
2830
import Data.Monoid
31+
import Data.Ord (comparing)
2932
import Data.Version
3033
import qualified Data.Map as Map
3134

@@ -52,10 +55,12 @@ import Distribution.Solver.Types.ConstraintSource
5255
import Distribution.Solver.Types.LabeledPackageConstraint
5356
import Distribution.Solver.Types.OptionalStanza
5457
import qualified Distribution.Solver.Types.PackageIndex as CI.PackageIndex
58+
import qualified Distribution.Solver.Types.PackagePath as P
5559
import qualified Distribution.Solver.Types.PkgConfigDb as PC
5660
import Distribution.Solver.Types.Settings
5761
import Distribution.Solver.Types.SolverPackage
5862
import Distribution.Solver.Types.SourcePackage
63+
import Distribution.Solver.Types.Variable
5964

6065
{-------------------------------------------------------------------------------
6166
Example package database DSL
@@ -143,6 +148,17 @@ data ExampleAvailable = ExAv {
143148
, exAvDeps :: ComponentDeps [ExampleDependency]
144149
} deriving Show
145150

151+
data ExampleVar =
152+
P ExampleQualifier ExamplePkgName
153+
| F ExampleQualifier ExamplePkgName ExampleFlagName
154+
| S ExampleQualifier ExamplePkgName OptionalStanza
155+
156+
data ExampleQualifier =
157+
None
158+
| Indep Int
159+
| Setup ExamplePkgName
160+
| IndepSetup Int ExamplePkgName
161+
146162
-- | Constructs an 'ExampleAvailable' package for the 'ExampleDb',
147163
-- given:
148164
--
@@ -398,10 +414,11 @@ exResolve :: ExampleDb
398414
-> IndependentGoals
399415
-> ReorderGoals
400416
-> EnableBackjumping
417+
-> Maybe [ExampleVar]
401418
-> [ExPreference]
402419
-> ([String], Either String CI.InstallPlan.SolverInstallPlan)
403420
exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder
404-
enableBj prefs
421+
enableBj vars prefs
405422
= runProgress $ resolveDependencies C.buildPlatform
406423
compiler pkgConfigDb
407424
solver
@@ -427,10 +444,34 @@ exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder
427444
$ setReorderGoals reorder
428445
$ setMaxBackjumps mbj
429446
$ setEnableBackjumping enableBj
447+
$ setGoalOrder goalOrder
430448
$ standardInstallPolicy instIdx avaiIdx targets'
431449
toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown
432450
toPref (ExPref n v) = PackageVersionPreference (C.PackageName n) v
433451

452+
goalOrder :: Maybe (Variable P.QPN -> Variable P.QPN -> Ordering)
453+
goalOrder = (orderFromList . map toVariable) `fmap` vars
454+
455+
-- Sort elements in the list ahead of elements not in the list. Otherwise,
456+
-- follow the order in the list.
457+
orderFromList :: Eq a => [a] -> a -> a -> Ordering
458+
orderFromList xs =
459+
comparing $ \x -> let i = elemIndex x xs in (isNothing i, i)
460+
461+
toVariable :: ExampleVar -> Variable P.QPN
462+
toVariable (P q pn) = PackageVar (toQPN q pn)
463+
toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.FlagName fn)
464+
toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza
465+
466+
toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN
467+
toQPN q pn = P.Q pp (C.PackageName pn)
468+
where
469+
pp = case q of
470+
None -> P.PackagePath P.DefaultNamespace P.Unqualified
471+
Indep x -> P.PackagePath (P.Independent x) P.Unqualified
472+
Setup p -> P.PackagePath P.DefaultNamespace (P.Setup (C.PackageName p))
473+
IndepSetup x p -> P.PackagePath (P.Independent x) (P.Setup (C.PackageName p))
474+
434475
extractInstallPlan :: CI.InstallPlan.SolverInstallPlan
435476
-> [(ExamplePkgName, ExamplePkgVersion)]
436477
extractInstallPlan = catMaybes . map confPkg . CI.InstallPlan.toList

0 commit comments

Comments
 (0)