Skip to content

Commit 1725739

Browse files
sebrightsebright
committed
Add goal order parameter to the dependency solver
1 parent 86d8c33 commit 1725739

File tree

9 files changed

+127
-26
lines changed

9 files changed

+127
-26
lines changed

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

Lines changed: 19 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,8 @@ data DepResolverParams = DepResolverParams {
161164
depResolverShadowPkgs :: ShadowPkgs,
162165
depResolverStrongFlags :: StrongFlags,
163166
depResolverMaxBackjumps :: Maybe Int,
164-
depResolverEnableBackjumping :: EnableBackjumping
167+
depResolverEnableBackjumping :: EnableBackjumping,
168+
depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
165169
}
166170

167171
showDepResolverParams :: DepResolverParams -> String
@@ -233,7 +237,8 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
233237
depResolverShadowPkgs = ShadowPkgs False,
234238
depResolverStrongFlags = StrongFlags False,
235239
depResolverMaxBackjumps = Nothing,
236-
depResolverEnableBackjumping = EnableBackjumping True
240+
depResolverEnableBackjumping = EnableBackjumping True,
241+
depResolverGoalOrder = Nothing
237242
}
238243

239244
addTargets :: [PackageName]
@@ -308,6 +313,14 @@ setEnableBackjumping b params =
308313
depResolverEnableBackjumping = b
309314
}
310315

316+
setGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
317+
-> DepResolverParams
318+
-> DepResolverParams
319+
setGoalOrder order params =
320+
params {
321+
depResolverGoalOrder = order
322+
}
323+
311324
-- | Some packages are specific to a given compiler version and should never be
312325
-- upgraded.
313326
dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams
@@ -607,7 +620,7 @@ resolveDependencies platform comp pkgConfigDB solver params =
607620
Step (showDepResolverParams finalparams)
608621
$ fmap (validateSolverResult platform comp indGoals)
609622
$ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls
610-
shadowing strFlags maxBkjumps enableBj)
623+
shadowing strFlags maxBkjumps enableBj order)
611624
platform comp installedPkgIndex sourcePkgIndex
612625
pkgConfigDB preferences constraints targets
613626
where
@@ -623,7 +636,8 @@ resolveDependencies platform comp pkgConfigDB solver params =
623636
shadowing
624637
strFlags
625638
maxBkjumps
626-
enableBj) = dontUpgradeNonUpgradeablePackages
639+
enableBj
640+
order) = dontUpgradeNonUpgradeablePackages
627641
-- TODO:
628642
-- The modular solver can properly deal with broken
629643
-- packages and won't select them. So the
@@ -858,7 +872,7 @@ resolveWithoutDependencies :: DepResolverParams
858872
resolveWithoutDependencies (DepResolverParams targets constraints
859873
prefs defpref installedPkgIndex sourcePkgIndex
860874
_reorderGoals _indGoals _avoidReinstalls
861-
_shadowing _strFlags _maxBjumps _enableBj) =
875+
_shadowing _strFlags _maxBjumps _enableBj _order) =
862876
collectEithers (map selectPackage targets)
863877
where
864878
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: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ module Distribution.Solver.Modular.Preference
66
, enforceManualFlags
77
, enforcePackageConstraints
88
, enforceSingleInstanceRestriction
9+
, sortGoals
910
, firstGoal
1011
, preferBaseGoalChoice
1112
, preferEasyGoalChoices
@@ -17,6 +18,7 @@ module Distribution.Solver.Modular.Preference
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
@@ -275,6 +278,20 @@ avoidReinstalls p = trav go
275278
x
276279
go x = x
277280

281+
sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree a -> Tree a
282+
sortGoals varOrder = trav go
283+
where
284+
go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys goalOrder xs)
285+
go x = x
286+
287+
goalOrder :: Goal QPN -> Goal QPN -> Ordering
288+
goalOrder = varOrder `on` (varToVariable . goalToVar)
289+
290+
varToVariable :: Var QPN -> Variable QPN
291+
varToVariable (P qpn) = PackageVar qpn
292+
varToVariable (F (FN (PI qpn _) fn)) = FlagVar qpn fn
293+
varToVariable (S (SN (PI qpn _) sn)) = StanzaVar qpn sn
294+
278295
-- | Always choose the first goal in the list next, abandoning all
279296
-- other choices.
280297
--

‎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: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
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 solver.
8+
data Variable qpn =
9+
PackageVar qpn
10+
| FlagVar qpn FlagName
11+
| StanzaVar qpn OptionalStanza
12+
deriving Eq

‎cabal-install/cabal-install.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -269,6 +269,7 @@ executable cabal
269269
Distribution.Solver.Types.SolverId
270270
Distribution.Solver.Types.SolverPackage
271271
Distribution.Solver.Types.SourcePackage
272+
Distribution.Solver.Types.Variable
272273
Distribution.Solver.Modular
273274
Distribution.Solver.Modular.Assignment
274275
Distribution.Solver.Modular.Builder

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

Lines changed: 45 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,35 @@ 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 = (goalOrderFromList . map toVariable) `fmap` vars
454+
455+
-- Sort variables in the list ahead of variables not in the list. Otherwise,
456+
-- follow the order in the list.
457+
goalOrderFromList :: [Variable P.QPN]
458+
-> Variable P.QPN -> Variable P.QPN -> Ordering
459+
goalOrderFromList vs =
460+
comparing $ \v -> let i = elemIndex v vs in (isNothing i, i)
461+
462+
toVariable :: ExampleVar -> Variable P.QPN
463+
toVariable (P q pn) = PackageVar (toQPN q pn)
464+
toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.FlagName fn)
465+
toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza
466+
467+
toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN
468+
toQPN q pn = P.Q pp (C.PackageName pn)
469+
where
470+
pp = case q of
471+
None -> P.PackagePath P.DefaultNamespace P.Unqualified
472+
Indep x -> P.PackagePath (P.Independent x) P.Unqualified
473+
Setup s -> P.PackagePath P.DefaultNamespace (P.Setup (C.PackageName s))
474+
IndepSetup x s -> P.PackagePath (P.Independent x) (P.Setup (C.PackageName s))
475+
434476
extractInstallPlan :: CI.InstallPlan.SolverInstallPlan
435477
-> [(ExamplePkgName, ExamplePkgVersion)]
436478
extractInstallPlan = catMaybes . map confPkg . CI.InstallPlan.toList

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

Lines changed: 7 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -102,7 +102,7 @@ solve enableBj reorder indep solver targets (TestDb db) =
102102
-- The backjump limit prevents individual tests from using
103103
-- too much time and memory.
104104
(Just defaultMaxBackjumps)
105-
indep reorder enableBj []
105+
indep reorder enableBj Nothing []
106106

107107
failure :: String -> Failure
108108
failure msg
@@ -223,12 +223,12 @@ arbitraryComponentDep :: TestDb -> Gen (ComponentDep [ExampleDependency])
223223
arbitraryComponentDep db = do
224224
comp <- arbitrary
225225
deps <- case comp of
226-
ComponentSetup -> smallListOf (arbitraryExDep db Setup)
227-
_ -> boundedListOf 5 (arbitraryExDep db NonSetup)
226+
ComponentSetup -> smallListOf (arbitraryExDep db SetupDep)
227+
_ -> boundedListOf 5 (arbitraryExDep db NonSetupDep)
228228
return (comp, deps)
229229

230230
-- | Location of an 'ExampleDependency'. It determines which values are valid.
231-
data ExDepLocation = Setup | NonSetup
231+
data ExDepLocation = SetupDep | NonSetupDep
232232

233233
arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency
234234
arbitraryExDep db@(TestDb pkgs) level =
@@ -247,13 +247,13 @@ arbitraryExDep db@(TestDb pkgs) level =
247247
]
248248
in oneof $
249249
case level of
250-
NonSetup -> flag : other
251-
Setup -> other
250+
NonSetupDep -> flag : other
251+
SetupDep -> other
252252

253253
arbitraryDeps :: TestDb -> Gen Dependencies
254254
arbitraryDeps db = frequency
255255
[ (1, return NotBuildable)
256-
, (20, Buildable <$> smallListOf (arbitraryExDep db NonSetup))
256+
, (20, Buildable <$> smallListOf (arbitraryExDep db NonSetupDep))
257257
]
258258

259259
arbitraryFlagName :: Gen String

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

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -172,6 +172,7 @@ data SolverTest = SolverTest {
172172
, testTargets :: [String]
173173
, testResult :: SolverResult
174174
, testIndepGoals :: IndependentGoals
175+
, testGoalOrder :: Maybe [ExampleVar]
175176
, testSoftConstraints :: [ExPreference]
176177
, testDb :: ExampleDb
177178
, testSupportedExts :: Maybe [Extension]
@@ -246,6 +247,7 @@ mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest {
246247
, testTargets = targets
247248
, testResult = result
248249
, testIndepGoals = IndependentGoals False
250+
, testGoalOrder = Nothing
249251
, testSoftConstraints = []
250252
, testDb = db
251253
, testSupportedExts = exts
@@ -259,7 +261,7 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
259261
let (_msgs, result) = exResolve testDb testSupportedExts
260262
testSupportedLangs testPkgConfigDb testTargets
261263
Modular Nothing testIndepGoals (ReorderGoals False)
262-
(EnableBackjumping True) testSoftConstraints
264+
(EnableBackjumping True) testGoalOrder testSoftConstraints
263265
when showSolverLog $ mapM_ putStrLn _msgs
264266
case result of
265267
Left err -> assertBool ("Unexpected error:\n" ++ err) (check testResult err)

0 commit comments

Comments
 (0)