Skip to content

Commit 8689097

Browse files
grayjaygrayjay
committed
Add option to specify minimum install plan quality
1 parent c1189c3 commit 8689097

21 files changed

+531
-256
lines changed

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -235,6 +235,7 @@ instance Monoid SavedConfig where
235235
installHaddockIndex = combine installHaddockIndex,
236236
installDryRun = combine installDryRun,
237237
installMaxBackjumps = combine installMaxBackjumps,
238+
installMaxScore = combine installMaxScore,
238239
installReorderGoals = combine installReorderGoals,
239240
installIndependentGoals = combine installIndependentGoals,
240241
installShadowPkgs = combine installShadowPkgs,

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

Lines changed: 23 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -52,6 +52,7 @@ module Distribution.Client.Dependency (
5252
setShadowPkgs,
5353
setStrongFlags,
5454
setMaxBackjumps,
55+
setMaxScore,
5556
addSourcePackages,
5657
hideInstalledPackagesSpecificByComponentId,
5758
hideInstalledPackagesSpecificBySourcePackageId,
@@ -62,7 +63,7 @@ module Distribution.Client.Dependency (
6263
import Distribution.Client.Dependency.TopDown
6364
( topDownResolver )
6465
import Distribution.Client.Dependency.Modular
65-
( modularResolver, SolverConfig(..) )
66+
( modularResolver, SolverConfig(SolverConfig) )
6667
import qualified Distribution.Client.PackageIndex as PackageIndex
6768
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
6869
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
@@ -76,6 +77,7 @@ import Distribution.Client.Dependency.Types
7677
, PackageConstraint(..), showPackageConstraint
7778
, LabeledPackageConstraint(..), unlabelPackageConstraint
7879
, ConstraintSource(..), showConstraintSource
80+
, InstallPlanScore, defaultInstallPlanScore
7981
, AllowNewer(..), PackagePreferences(..), InstalledPreference(..)
8082
, PackagesPreferenceDefault(..)
8183
, Progress(..), foldProgress )
@@ -146,7 +148,8 @@ data DepResolverParams = DepResolverParams {
146148
depResolverAvoidReinstalls :: Bool,
147149
depResolverShadowPkgs :: Bool,
148150
depResolverStrongFlags :: Bool,
149-
depResolverMaxBackjumps :: Maybe Int
151+
depResolverMaxBackjumps :: Maybe Int,
152+
depResolverMaxScore :: Maybe InstallPlanScore
150153
}
151154

152155
showDepResolverParams :: DepResolverParams -> String
@@ -203,7 +206,8 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
203206
depResolverAvoidReinstalls = False,
204207
depResolverShadowPkgs = False,
205208
depResolverStrongFlags = False,
206-
depResolverMaxBackjumps = Nothing
209+
depResolverMaxBackjumps = Nothing,
210+
depResolverMaxScore = Nothing
207211
}
208212

209213
addTargets :: [PackageName]
@@ -272,6 +276,12 @@ setMaxBackjumps n params =
272276
depResolverMaxBackjumps = n
273277
}
274278

279+
setMaxScore :: Maybe InstallPlanScore -> DepResolverParams -> DepResolverParams
280+
setMaxScore n params =
281+
params {
282+
depResolverMaxScore = n
283+
}
284+
275285
-- | Some packages are specific to a given compiler version and should never be
276286
-- upgraded.
277287
dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams
@@ -540,16 +550,17 @@ resolveDependencies :: Platform
540550
--TODO: is this needed here? see dontUpgradeNonUpgradeablePackages
541551
resolveDependencies platform comp _solver params
542552
| null (depResolverTargets params)
543-
= return (validateSolverResult platform comp indGoals [])
553+
= return
554+
(validateSolverResult platform comp indGoals [] defaultInstallPlanScore)
544555
where
545556
indGoals = depResolverIndependentGoals params
546557

547558
resolveDependencies platform comp solver params =
548559

549560
Step (showDepResolverParams finalparams)
550-
$ fmap (validateSolverResult platform comp indGoals)
561+
$ fmap (uncurry $ validateSolverResult platform comp indGoals)
551562
$ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls
552-
shadowing strFlags maxBkjumps)
563+
shadowing strFlags maxBkjumps maxScore)
553564
platform comp installedPkgIndex sourcePkgIndex
554565
preferences constraints targets
555566
where
@@ -564,7 +575,8 @@ resolveDependencies platform comp solver params =
564575
noReinstalls
565576
shadowing
566577
strFlags
567-
maxBkjumps) = dontUpgradeNonUpgradeablePackages
578+
maxBkjumps
579+
maxScore) = dontUpgradeNonUpgradeablePackages
568580
-- TODO:
569581
-- The modular solver can properly deal with broken
570582
-- packages and won't select them. So the
@@ -620,10 +632,11 @@ validateSolverResult :: Platform
620632
-> CompilerInfo
621633
-> Bool
622634
-> [ResolverPackage]
635+
-> InstallPlanScore
623636
-> InstallPlan
624-
validateSolverResult platform comp indepGoals pkgs =
637+
validateSolverResult platform comp indepGoals pkgs score =
625638
case planPackagesProblems platform comp pkgs of
626-
[] -> case InstallPlan.new indepGoals index of
639+
[] -> case InstallPlan.new indepGoals score index of
627640
Right plan -> plan
628641
Left problems -> error (formatPlanProblems problems)
629642
problems -> error (formatPkgProblems problems)
@@ -791,7 +804,7 @@ resolveWithoutDependencies :: DepResolverParams
791804
resolveWithoutDependencies (DepResolverParams targets constraints
792805
prefs defpref installedPkgIndex sourcePkgIndex
793806
_reorderGoals _indGoals _avoidReinstalls
794-
_shadowing _strFlags _maxBjumps) =
807+
_shadowing _strFlags _maxBjumps _maxScore) =
795808
collectEithers (map selectPackage targets)
796809
where
797810
selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -35,7 +35,7 @@ import Distribution.System
3535
-- solver. Performs the necessary translations before and after.
3636
modularResolver :: SolverConfig -> DependencyResolver
3737
modularResolver sc (Platform arch os) cinfo iidx sidx pprefs pcs pns =
38-
fmap (uncurry postprocess) $ -- convert install plan
38+
fmap (\(a, rds, score) -> (postprocess a rds, score)) $ -- convert install plan
3939
logToProgress (maxBackjumps sc) $ -- convert log format into progress format
4040
solve sc idx pprefs gcs pns
4141
where

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

Lines changed: 13 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ import Distribution.Client.Dependency.Modular.Index
2626
import Distribution.Client.Dependency.Modular.Package
2727
import Distribution.Client.Dependency.Modular.PSQ as P
2828
import Distribution.Client.Dependency.Modular.Tree
29+
import Distribution.Client.Dependency.Modular.WeightedPSQ as W
2930

3031
import Distribution.Client.ComponentDeps (Component)
3132

@@ -96,16 +97,16 @@ data BuildType =
9697
| Instance QPN I PInfo QGoalReasonChain -- ^ build a tree for a concrete instance
9798
deriving Show
9899

99-
build :: BuildState -> Tree QGoalReasonChain
100+
build :: BuildState -> Tree () QGoalReasonChain
100101
build = ana go
101102
where
102-
go :: BuildState -> TreeF QGoalReasonChain BuildState
103+
go :: BuildState -> TreeF () QGoalReasonChain BuildState
103104

104105
-- If we have a choice between many goals, we just record the choice in
105106
-- the tree. We select each open goal in turn, and before we descend, remove
106107
-- it from the queue of open goals.
107108
go bs@(BS { rdeps = rds, open = gs, next = Goals })
108-
| P.null gs = DoneF rds
109+
| P.null gs = DoneF rds ()
109110
| otherwise = GoalChoiceF (P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })
110111
(P.splits gs))
111112

@@ -117,8 +118,8 @@ build = ana go
117118
go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _) _) gr) }) =
118119
case M.lookup pn idx of
119120
Nothing -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn)
120-
Just pis -> PChoiceF qpn gr (P.fromList (L.map (\ (i, info) ->
121-
(POption i Nothing, bs { next = Instance qpn i info gr }))
121+
Just pis -> PChoiceF qpn gr (W.fromList (L.map (\ (i, info) ->
122+
([], POption i Nothing, bs { next = Instance qpn i info gr }))
122123
(M.toList pis)))
123124
-- TODO: data structure conversion is rather ugly here
124125

@@ -127,18 +128,16 @@ build = ana go
127128
--
128129
-- TODO: Should we include the flag default in the tree?
129130
go bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
130-
FChoiceF qfn gr (w || trivial) m (P.fromList (reorder b
131-
[(True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True : gr)) t) bs) { next = Goals }),
132-
(False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })]))
131+
FChoiceF qfn gr (w || trivial) m (W.fromList
132+
[([if b then 0 else 1], True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True : gr)) t) bs) { next = Goals }),
133+
([if b then 1 else 0], False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })])
133134
where
134-
reorder True = id
135-
reorder False = reverse
136135
trivial = L.null t && L.null f
137136

138137
go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
139-
SChoiceF qsn gr trivial (P.fromList
140-
[(False, bs { next = Goals }),
141-
(True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })])
138+
SChoiceF qsn gr trivial (W.fromList
139+
[([0], False, bs { next = Goals }),
140+
([1], True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })])
142141
where
143142
trivial = L.null t
144143

@@ -152,7 +151,7 @@ build = ana go
152151

153152
-- | Interface to the tree builder. Just takes an index and a list of package names,
154153
-- and computes the initial state and then the tree from there.
155-
buildTree :: Index -> Bool -> [PN] -> Tree QGoalReasonChain
154+
buildTree :: Index -> Bool -> [PN] -> Tree () QGoalReasonChain
156155
buildTree idx ind igs =
157156
build BS {
158157
index = idx

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

Lines changed: 46 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,10 @@ module Distribution.Client.Dependency.Modular.Dependency (
88
, varPI
99
-- * Conflict sets
1010
, ConflictSet
11+
, ConflictType(..)
1112
, showCS
13+
, unionCS
14+
, insertCS
1215
-- * Constrained instances
1316
, CI(..)
1417
, showCI
@@ -55,9 +58,8 @@ import Prelude hiding (pi)
5558
import Data.List (intercalate)
5659
import Data.Map (Map)
5760
import Data.Maybe (mapMaybe)
58-
import Data.Set (Set)
5961
import qualified Data.List as L
60-
import qualified Data.Set as S
62+
import qualified Data.Map as M
6163

6264
import Distribution.Client.Dependency.Modular.Flag
6365
import Distribution.Client.Dependency.Modular.Package
@@ -105,10 +107,41 @@ varPI (S (SN (PI qpn i) _)) = (qpn, Just i)
105107
Conflict sets
106108
-------------------------------------------------------------------------------}
107109

108-
type ConflictSet qpn = Set (Var qpn)
110+
type ConflictSet qpn = Map (Var qpn) ConflictType
111+
112+
-- TODO: The name of this type could be improved.
113+
data ConflictType =
114+
115+
-- | Any other value in the variable's domain might resolve the conflict.
116+
ConflictAll
117+
118+
-- | Only values that are less than the current assignment can resolve the
119+
-- conflict.
120+
| ConflictLessThan
121+
deriving (Eq, Show)
122+
123+
combineConflictType :: ConflictType -> ConflictType -> ConflictType
124+
combineConflictType ConflictLessThan ConflictLessThan = ConflictLessThan
125+
combineConflictType _ _ = ConflictAll
109126

110127
showCS :: ConflictSet QPN -> String
111-
showCS = intercalate ", " . L.map showVar . S.toList
128+
showCS = intercalate ", " . L.map (uncurry showConflict) . M.toList
129+
where
130+
-- TODO: How should we display the type of conflict?
131+
showConflict v t = "(" ++ showVar v ++ ", " ++ show t ++ ")"
132+
133+
unionCS :: Ord qpn => ConflictSet qpn -> ConflictSet qpn -> ConflictSet qpn
134+
unionCS = M.unionWith combineConflictType
135+
136+
unionsCS :: Ord qpn => [ConflictSet qpn] -> ConflictSet qpn
137+
unionsCS = M.unionsWith combineConflictType
138+
139+
insertCS :: Ord qpn
140+
=> Var qpn
141+
-> ConflictType
142+
-> ConflictSet qpn
143+
-> ConflictSet qpn
144+
insertCS = M.insertWith combineConflictType . simplifyVar
112145

113146
{-------------------------------------------------------------------------------
114147
Constrained instances
@@ -142,13 +175,13 @@ showCI (Constrained vr) = showVR (collapse vr)
142175
merge :: Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn)
143176
merge c@(Fixed i g1) d@(Fixed j g2)
144177
| i == j = Right c
145-
| otherwise = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, d))
178+
| otherwise = Left (unionCS (toConflictSet g1) (toConflictSet g2), (c, d))
146179
merge c@(Fixed (I v _) g1) (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ...
147180
where
148181
go [] = Right c
149182
go (d@(vr, g2) : vrs)
150183
| checkVR vr v = go vrs
151-
| otherwise = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, Constrained [d]))
184+
| otherwise = Left (unionCS (toConflictSet g1) (toConflictSet g2), (c, Constrained [d]))
152185
merge c@(Constrained _) d@(Fixed _ _) = merge d c
153186
merge (Constrained rs) (Constrained ss) = Right (Constrained (rs ++ ss))
154187

@@ -388,19 +421,19 @@ instance ResetGoal Goal where
388421
-- | Compute a conflic set from a goal. The conflict set contains the
389422
-- closure of goal reasons as well as the variable of the goal itself.
390423
toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn
391-
toConflictSet (Goal g grs) = S.insert (simplifyVar g) (goalReasonChainToVars grs)
424+
toConflictSet (Goal g grs) = M.insert (simplifyVar g) ConflictAll (goalReasonChainToVars grs)
392425

393426
goalReasonToVars :: GoalReason qpn -> ConflictSet qpn
394-
goalReasonToVars UserGoal = S.empty
395-
goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn)
396-
goalReasonToVars (FDependency qfn _) = S.singleton (simplifyVar (F qfn))
397-
goalReasonToVars (SDependency qsn) = S.singleton (S qsn)
427+
goalReasonToVars UserGoal = M.empty
428+
goalReasonToVars (PDependency (PI qpn _)) = M.singleton (P qpn) ConflictAll
429+
goalReasonToVars (FDependency qfn _) = M.singleton (simplifyVar (F qfn)) ConflictAll
430+
goalReasonToVars (SDependency qsn) = M.singleton (S qsn) ConflictAll
398431

399432
goalReasonChainToVars :: Ord qpn => GoalReasonChain qpn -> ConflictSet qpn
400-
goalReasonChainToVars = S.unions . L.map goalReasonToVars
433+
goalReasonChainToVars = unionsCS . L.map goalReasonToVars
401434

402435
goalReasonChainsToVars :: Ord qpn => [GoalReasonChain qpn] -> ConflictSet qpn
403-
goalReasonChainsToVars = S.unions . L.map goalReasonChainToVars
436+
goalReasonChainsToVars = unionsCS . L.map goalReasonChainToVars
404437

405438
{-------------------------------------------------------------------------------
406439
Open goals

0 commit comments

Comments
 (0)