Skip to content

Commit d0d6592

Browse files
grayjaygrayjay
committed
Add option to specify minimum install plan quality
1 parent aa8a029 commit d0d6592

21 files changed

+529
-259
lines changed

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -236,6 +236,7 @@ instance Monoid SavedConfig where
236236
installHaddockIndex = combine installHaddockIndex,
237237
installDryRun = combine installDryRun,
238238
installMaxBackjumps = combine installMaxBackjumps,
239+
installMaxScore = combine installMaxScore,
239240
installReorderGoals = combine installReorderGoals,
240241
installIndependentGoals = combine installIndependentGoals,
241242
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 cinfo 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
@@ -27,6 +27,7 @@ import Distribution.Client.Dependency.Modular.Package
2727
import Distribution.Client.Dependency.Modular.PSQ (PSQ)
2828
import qualified Distribution.Client.Dependency.Modular.PSQ as P
2929
import Distribution.Client.Dependency.Modular.Tree
30+
import qualified Distribution.Client.Dependency.Modular.WeightedPSQ as W
3031

3132
import Distribution.Client.ComponentDeps (Component)
3233

@@ -99,16 +100,16 @@ data BuildType =
99100
| Instance QPN I PInfo QGoalReasonChain -- ^ build a tree for a concrete instance
100101
deriving Show
101102

102-
build :: BuildState -> Tree QGoalReasonChain
103+
build :: BuildState -> Tree () QGoalReasonChain
103104
build = ana go
104105
where
105-
go :: BuildState -> TreeF QGoalReasonChain BuildState
106+
go :: BuildState -> TreeF () QGoalReasonChain BuildState
106107

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

@@ -124,8 +125,8 @@ build = ana go
124125
go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _) _) gr) }) =
125126
case M.lookup pn idx of
126127
Nothing -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn)
127-
Just pis -> PChoiceF qpn gr (P.fromList (L.map (\ (i, info) ->
128-
(POption i Nothing, bs { next = Instance qpn i info gr }))
128+
Just pis -> PChoiceF qpn gr (W.fromList (L.map (\ (i, info) ->
129+
([], POption i Nothing, bs { next = Instance qpn i info gr }))
129130
(M.toList pis)))
130131
-- TODO: data structure conversion is rather ugly here
131132

@@ -134,18 +135,16 @@ build = ana go
134135
--
135136
-- TODO: Should we include the flag default in the tree?
136137
go bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
137-
FChoiceF qfn gr (w || trivial) m (P.fromList (reorder b
138-
[(True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True : gr)) t) bs) { next = Goals }),
139-
(False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })]))
138+
FChoiceF qfn gr (w || trivial) m (W.fromList
139+
[([if b then 0 else 1], True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True : gr)) t) bs) { next = Goals }),
140+
([if b then 1 else 0], False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })])
140141
where
141-
reorder True = id
142-
reorder False = reverse
143142
trivial = L.null t && L.null f
144143

145144
go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
146-
SChoiceF qsn gr trivial (P.fromList
147-
[(False, bs { next = Goals }),
148-
(True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })])
145+
SChoiceF qsn gr trivial (W.fromList
146+
[([0], False, bs { next = Goals }),
147+
([1], True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })])
149148
where
150149
trivial = L.null t
151150

@@ -159,7 +158,7 @@ build = ana go
159158

160159
-- | Interface to the tree builder. Just takes an index and a list of package names,
161160
-- and computes the initial state and then the tree from there.
162-
buildTree :: Index -> Bool -> [PN] -> Tree QGoalReasonChain
161+
buildTree :: Index -> Bool -> [PN] -> Tree () QGoalReasonChain
163162
buildTree idx ind igs =
164163
build BS {
165164
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 Language.Haskell.Extension (Extension(..), Language(..))
6365

@@ -109,10 +111,41 @@ varPI (S (SN (PI qpn i) _)) = (qpn, Just i)
109111
Conflict sets
110112
-------------------------------------------------------------------------------}
111113

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

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

117150
{-------------------------------------------------------------------------------
118151
Constrained instances
@@ -146,13 +179,13 @@ showCI (Constrained vr) = showVR (collapse vr)
146179
merge :: Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn)
147180
merge c@(Fixed i g1) d@(Fixed j g2)
148181
| i == j = Right c
149-
| otherwise = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, d))
182+
| otherwise = Left (unionCS (toConflictSet g1) (toConflictSet g2), (c, d))
150183
merge c@(Fixed (I v _) g1) (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ...
151184
where
152185
go [] = Right c
153186
go (d@(vr, g2) : vrs)
154187
| checkVR vr v = go vrs
155-
| otherwise = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, Constrained [d]))
188+
| otherwise = Left (unionCS (toConflictSet g1) (toConflictSet g2), (c, Constrained [d]))
156189
merge c@(Constrained _) d@(Fixed _ _) = merge d c
157190
merge (Constrained rs) (Constrained ss) = Right (Constrained (rs ++ ss))
158191

@@ -400,19 +433,19 @@ instance ResetGoal Goal where
400433
-- | Compute a conflic set from a goal. The conflict set contains the
401434
-- closure of goal reasons as well as the variable of the goal itself.
402435
toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn
403-
toConflictSet (Goal g grs) = S.insert (simplifyVar g) (goalReasonChainToVars grs)
436+
toConflictSet (Goal g grs) = M.insert (simplifyVar g) ConflictAll (goalReasonChainToVars grs)
404437

405438
goalReasonToVars :: GoalReason qpn -> ConflictSet qpn
406-
goalReasonToVars UserGoal = S.empty
407-
goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn)
408-
goalReasonToVars (FDependency qfn _) = S.singleton (simplifyVar (F qfn))
409-
goalReasonToVars (SDependency qsn) = S.singleton (S qsn)
439+
goalReasonToVars UserGoal = M.empty
440+
goalReasonToVars (PDependency (PI qpn _)) = M.singleton (P qpn) ConflictAll
441+
goalReasonToVars (FDependency qfn _) = M.singleton (simplifyVar (F qfn)) ConflictAll
442+
goalReasonToVars (SDependency qsn) = M.singleton (S qsn) ConflictAll
410443

411444
goalReasonChainToVars :: Ord qpn => GoalReasonChain qpn -> ConflictSet qpn
412-
goalReasonChainToVars = S.unions . L.map goalReasonToVars
445+
goalReasonChainToVars = unionsCS . L.map goalReasonToVars
413446

414447
goalReasonChainsToVars :: Ord qpn => [GoalReasonChain qpn] -> ConflictSet qpn
415-
goalReasonChainsToVars = S.unions . L.map goalReasonChainToVars
448+
goalReasonChainsToVars = unionsCS . L.map goalReasonChainToVars
416449

417450
{-------------------------------------------------------------------------------
418451
Open goals

0 commit comments

Comments
 (0)