Skip to content

Commit 0f92a86

Browse files
andreabediniandreabedini
committed
feat: all of it, second cabal-install-solver part
1 parent 04fe295 commit 0f92a86

File tree

11 files changed

+83
-89
lines changed

11 files changed

+83
-89
lines changed

‎cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs‎

Lines changed: 39 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE ScopedTypeVariables #-}
2+
{-# LANGUAGE NamedFieldPuns #-}
23
module Distribution.Solver.Modular.Builder (
34
buildTree
45
, splits -- for testing
@@ -35,6 +36,7 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W
3536

3637
import Distribution.Solver.Types.ComponentDeps
3738
import Distribution.Solver.Types.PackagePath
39+
import qualified Distribution.Solver.Types.Stage as Stage
3840

3941
-- | All state needed to build and link the search tree. It has a type variable
4042
-- because the linking phase doesn't need to know about the state used to build
@@ -138,40 +140,42 @@ addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals })
138140

139141
-- If we have already picked a goal, then the choice depends on the kind
140142
-- of goal.
141-
--
142-
-- For a package, we look up the instances available in the global info,
143-
-- and then handle each instance in turn.
144-
addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) =
145-
case M.lookup pn idx of
146-
Nothing -> FailF
147-
(varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr)
148-
UnknownPackage
149-
Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) ->
150-
([], POption i Nothing, bs { next = Instance qpn info }))
151-
(M.toList pis)))
152-
-- TODO: data structure conversion is rather ugly here
153-
154-
-- For a flag, we create only two subtrees, and we create them in the order
155-
-- that is indicated by the flag default.
156-
addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) =
157-
FChoiceF qfn rdm gr weak m b (W.fromList
158-
[([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals }),
159-
([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })])
160-
where
161-
trivial = L.null t && L.null f
162-
weak = WeakOrTrivial $ unWeakOrTrivial w || trivial
163-
164-
-- For a stanza, we also create only two subtrees. The order is initially
165-
-- False, True. This can be changed later by constraints (force enabling
166-
-- the stanza by replacing the False branch with failure) or preferences
167-
-- (try enabling the stanza if possible by moving the True branch first).
168-
169-
addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) =
170-
SChoiceF qsn rdm gr trivial (W.fromList
171-
[([0], False, bs { next = Goals }),
172-
([1], True, (extendOpen qpn t bs) { next = Goals })])
173-
where
174-
trivial = WeakOrTrivial (L.null t)
143+
addChildren bs@(BS { rdeps, index, next = OneGoal goal }) =
144+
case goal of
145+
PkgGoal qpn@(Q (PackagePath s _) pn) gr ->
146+
-- For a package goal, we look up the instances available in the global
147+
-- info, and then handle each instance in turn.
148+
case M.lookup pn index of
149+
Nothing -> FailF
150+
(varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr)
151+
UnknownPackage
152+
Just pis -> PChoiceF qpn rdeps gr $ W.fromList
153+
[ ([], POption i Nothing, bs { next = Instance qpn info })
154+
| (i@(I s' _ver _loc), info) <- M.toList pis
155+
-- Only instances belonging to the same stage are allowed.
156+
, s == s'
157+
]
158+
-- For a flag, we create only two subtrees, and we create them in the order
159+
-- that is indicated by the flag default.
160+
FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr ->
161+
FChoiceF qfn rdeps gr weak m b $ W.fromList
162+
[ ([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals })
163+
, ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })
164+
]
165+
where
166+
trivial = L.null t && L.null f
167+
weak = WeakOrTrivial $ unWeakOrTrivial w || trivial
168+
-- For a stanza, we also create only two subtrees. The order is initially
169+
-- False, True. This can be changed later by constraints (force enabling
170+
-- the stanza by replacing the False branch with failure) or preferences
171+
-- (try enabling the stanza if possible by moving the True branch first).
172+
StanzaGoal qsn@(SN qpn _) t gr ->
173+
SChoiceF qsn rdeps gr trivial $ W.fromList
174+
[ ([0], False, bs { next = Goals })
175+
, ([1], True, (extendOpen qpn t bs) { next = Goals })
176+
]
177+
where
178+
trivial = WeakOrTrivial (L.null t)
175179

176180
-- For a particular instance, we change the state: we update the scope,
177181
-- and furthermore we update the set of goals.
@@ -259,7 +263,7 @@ buildTree idx igs =
259263
where
260264
topLevelGoal qpn = PkgGoal qpn UserGoal
261265

262-
qpns = L.map (Q (PackagePath QualToplevel)) igs
266+
qpns = L.map (Q (PackagePath Stage.Host QualToplevel)) igs
263267

264268
{-------------------------------------------------------------------------------
265269
Goals

‎cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -43,7 +43,7 @@ convCP iidx sidx (CP qpi fa es ds) =
4343
ipkg = fromMaybe (error "convCP: lookupUnitId failed") $
4444
SI.lookupUnitId (getStage iidx s) pi
4545
-- "In repo" i.e. a source package
46-
(PI qpn@(Q _path pn) (I s v InRepo)) ->
46+
(PI qpn@(Q _path pn) (I s v (InRepo _pn))) ->
4747
let pi = PackageIdentifier pn v in
4848
Configured $
4949
SolverPackage {
@@ -60,7 +60,7 @@ convCP iidx sidx (CP qpi fa es ds) =
6060
ds' = fmap (partitionEithers . map convConfId) ds
6161

6262
convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -}
63-
convConfId (PI (Q (PackagePath q) pn) (I _ v loc)) =
63+
convConfId (PI (Q (PackagePath _ q) pn) (I _ v loc)) =
6464
case loc of
6565
Inst pi -> Left (PreExistingId sourceId pi)
6666
_otherwise

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

Lines changed: 12 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -62,6 +62,7 @@ import Distribution.Solver.Types.PackagePath
6262
import Distribution.Types.LibraryName
6363
import Distribution.Types.PkgconfigVersionRange
6464
import Distribution.Types.UnqualComponentName
65+
import qualified Distribution.Solver.Types.Stage as Stage
6566

6667
{-------------------------------------------------------------------------------
6768
Constrained instances
@@ -97,6 +98,7 @@ data FlaggedDep qpn
9798
Stanza (SN qpn) (TrueFlaggedDeps qpn)
9899
| -- | Dependencies which are always enabled, for the component 'comp'.
99100
Simple (LDep qpn) Component
101+
deriving Show
100102

101103
-- | Conservatively flatten out flagged dependencies
102104
--
@@ -119,6 +121,7 @@ type FalseFlaggedDeps qpn = FlaggedDeps qpn
119121
-- depending; having a 'Functor' instance makes bugs where we don't distinguish
120122
-- these two far too likely. (By rights 'LDep' ought to have two type variables.)
121123
data LDep qpn = LDep (DependencyReason qpn) (Dep qpn)
124+
deriving Show
122125

123126
-- | A dependency (constraint) associates a package name with a constrained
124127
-- instance. It can also represent other types of dependencies, such as
@@ -132,7 +135,7 @@ data Dep qpn
132135
Lang Language
133136
| -- | dependency on a pkg-config package
134137
Pkg PkgconfigName PkgconfigVersionRange
135-
deriving (Functor)
138+
deriving (Functor, Show)
136139

137140
-- | An exposed component within a package. This type is used to represent
138141
-- build-depends and build-tool-depends dependencies.
@@ -166,7 +169,7 @@ showDependencyReason (DependencyReason qpn flags stanzas) =
166169
-- NOTE: It's the _dependencies_ of a package that may or may not be independent
167170
-- from the package itself. Package flag choices must of course be consistent.
168171
qualifyDeps :: QPN -> FlaggedDeps PN -> FlaggedDeps QPN
169-
qualifyDeps (Q pp@(PackagePath q) pn) = go
172+
qualifyDeps (Q pp@(PackagePath s q) pn) = go
170173
where
171174
go :: FlaggedDeps PN -> FlaggedDeps QPN
172175
go = map go1
@@ -191,24 +194,14 @@ qualifyDeps (Q pp@(PackagePath q) pn) = go
191194
goD (Ext ext) _ = Ext ext
192195
goD (Lang lang) _ = Lang lang
193196
goD (Pkg pkn vr) _ = Pkg pkn vr
197+
-- In case of executable and setup dependencies, we need to qualify the dependency
198+
-- with the previsous stage (e.g. Host -> Build).
194199
goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ =
195-
Dep (Q (PackagePath (QualExe pn qpn)) <$> dep) ci
196-
goD (Dep dep@(PkgComponent _qpn (ExposedLib _)) ci) comp
197-
| comp == ComponentSetup = Dep (Q (PackagePath (QualSetup pn)) <$> dep) ci
198-
| otherwise = Dep (Q (PackagePath inheritedQ) <$> dep) ci
199-
200-
-- If P has a setup dependency on Q, and Q has a regular dependency on R, then
201-
-- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup
202-
-- dependency on R. We do not do this for the base qualifier however.
203-
--
204-
-- The inherited qualifier is only used for regular dependencies; for setup
205-
-- and base dependencies we override the existing qualifier. See #3160 for
206-
-- a detailed discussion.
207-
inheritedQ :: Qualifier
208-
inheritedQ = case q of
209-
QualSetup _ -> q
210-
QualExe _ _ -> q
211-
QualToplevel -> q
200+
Dep (Q (PackagePath (Stage.prev s) (QualExe pn qpn)) <$> dep) ci
201+
goD (Dep dep@(PkgComponent _qpn (ExposedLib _)) ci) ComponentSetup =
202+
Dep (Q (PackagePath (Stage.prev s) (QualSetup pn)) <$> dep) ci
203+
goD (Dep dep@(PkgComponent _qpn _) ci) _ =
204+
Dep (Q (PackagePath s q) <$> dep) ci
212205

213206
-- | Remove qualifiers from set of dependencies
214207
--

‎cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -190,7 +190,7 @@ convSP
190190
-> SourcePackage loc
191191
-> (PN, I, PInfo)
192192
convSP stage os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
193-
let i = I stage pv InRepo
193+
let i = I stage pv (InRepo pn)
194194
pkgConstraints = fromMaybe [] $ M.lookup pn constraints
195195
in (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd)
196196

‎cabal-install-solver/src/Distribution/Solver/Modular/Message.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -220,9 +220,9 @@ data ProgressAction =
220220

221221
blurb :: ProgressAction -> String
222222
blurb = \case
223-
Trying -> "trying: "
224-
Skipping -> "skipping: "
225-
Rejecting -> "rejecting: "
223+
Trying -> "trying "
224+
Skipping -> "skipping "
225+
Rejecting -> "rejecting "
226226

227227
blurbQFNBool :: ProgressAction -> QFN -> Bool -> String
228228
blurbQFNBool a q b = blurb a ++ Flag.showQFNBool q b
@@ -239,8 +239,8 @@ blurbOptions a q ps = blurb a ++ showOptions q ps
239239
showOption :: QPN -> POption -> String
240240
showOption qpn@(Q _pp pn) (POption i linkedTo) =
241241
case linkedTo of
242-
Nothing -> showPI (PI qpn i) -- Consistent with prior to POption
243-
Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i)
242+
Nothing -> showQPN qpn ++ " == " ++ showI i
243+
Just pp' -> showQPN qpn ++ " ~> " ++ showQPN (Q pp' pn)
244244

245245
-- | Shows a mixed list of instances and versions in a human-friendly way,
246246
-- abbreviated.

‎cabal-install-solver/src/Distribution/Solver/Modular/Package.hs‎

Lines changed: 3 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -46,7 +46,7 @@ type PId = UnitId
4646
-- package instance via its 'PId'.
4747
--
4848
-- TODO: More information is needed about the repo.
49-
data Loc = Inst PId | InRepo
49+
data Loc = Inst PId | InRepo PackageName
5050
deriving (Eq, Ord, Show)
5151

5252
-- | Instance. A version number and a location.
@@ -55,13 +55,8 @@ data I = I Stage Ver Loc
5555

5656
-- | String representation of an instance.
5757
showI :: I -> String
58-
showI (I s v InRepo) = showVer v ++ " (" ++ showStage s ++ ")"
59-
showI (I s v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid ++ " (" ++ showStage s ++ ")"
60-
where
61-
extractPackageAbiHash xs =
62-
case first reverse $ break (=='-') $ reverse (prettyShow xs) of
63-
(ys, []) -> ys
64-
(ys, _) -> '-' : ys
58+
showI (I s v (InRepo pn)) = prettyShow (PackageIdentifier pn v) ++ " (source, " ++ showStage s ++ ")"
59+
showI (I s _v (Inst uid)) = prettyShow uid ++ " (installed, " ++ showStage s ++ ")"
6560

6661
-- | Package instance. A package name and an instance.
6762
data PI qpn = PI qpn I

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

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -341,7 +341,7 @@ avoidReinstalls p = go
341341
let installed = [ v | (_, POption (I _ v (Inst _)) _, _) <- W.toList cs ]
342342
in W.mapWithKey (notReinstall installed) cs
343343

344-
notReinstall vs (POption (I _ v InRepo) _) _ | v `elem` vs =
344+
notReinstall vs (POption (I _ v (InRepo _pn)) _) _ | v `elem` vs =
345345
Fail (varToConflictSet (P qpn)) CannotReinstall
346346
notReinstall _ _ x =
347347
x
@@ -420,9 +420,9 @@ deferSetupExeChoices = go
420420
go x = x
421421

422422
noSetupOrExe :: Goal QPN -> Bool
423-
noSetupOrExe (Goal (P (Q (PackagePath (QualSetup _)) _)) _) = False
424-
noSetupOrExe (Goal (P (Q (PackagePath (QualExe _ _)) _)) _) = False
425-
noSetupOrExe _ = True
423+
noSetupOrExe (Goal (P (Q (PackagePath _ (QualSetup _)) _)) _) = False
424+
noSetupOrExe (Goal (P (Q (PackagePath _ (QualExe _ _)) _)) _) = False
425+
noSetupOrExe _ = True
426426

427427
-- | Transformation that tries to avoid making weak flag choices early.
428428
-- Weak flags are trivial flags (not influencing dependencies) or such

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -44,7 +44,7 @@ import Distribution.Solver.Modular.Tree
4444
import qualified Distribution.Solver.Modular.PSQ as PSQ
4545

4646
import Distribution.Simple.Setup (BooleanFlag(..))
47-
import Distribution.Solver.Types.Stage (Staged)
47+
import Distribution.Solver.Types.Stage (Staged, Stage(..))
4848

4949
#ifdef DEBUG_TRACETREE
5050
import qualified Distribution.Solver.Modular.ConflictSet as CS
@@ -251,5 +251,5 @@ _removeGR = trav go
251251
dummy =
252252
DependencyGoal $
253253
DependencyReason
254-
(Q (PackagePath QualToplevel) (mkPackageName "$"))
254+
(Q (PackagePath Host QualToplevel) (mkPackageName "$"))
255255
M.empty S.empty

‎cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs‎

Lines changed: 8 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -190,7 +190,7 @@ validate = go
190190

191191
-- What to do for package nodes ...
192192
goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
193-
goP qpn@(Q _pp pn) (POption i _mpp) r = do
193+
goP qpn@(Q (PackagePath _stage _) pn) (POption i _mpp) r = do
194194
PA ppa pfa psa <- asks pa -- obtain current preassignment
195195
extSupported <- asks supportedExt -- obtain the supported extensions
196196
langSupported <- asks supportedLang -- obtain the supported languages
@@ -200,15 +200,16 @@ validate = go
200200
aComps <- asks availableComponents
201201
rComps <- asks requiredComponents
202202
-- obtain dependencies and index-dictated exclusions introduced by the choice
203+
let I stage _vr _loc = i
203204
let (PInfo deps comps _ mfr) = idx ! pn ! i
204205
-- qualify the deps in the current scope
205206
let qdeps = qualifyDeps qpn deps
206207
-- the new active constraints are given by the instance we have chosen,
207208
-- plus the dependency information we have for that instance
208209
let newactives = extractAllDeps pfa psa qdeps
209210
-- We now try to extend the partial assignment with the new active constraints.
210-
let mnppa = extend ({- FIXME -} extSupported Host) ({- FIXME -} langSupported Host) ({- FIXME -} pkgPresent Host) newactives
211-
=<< extendWithPackageChoice (PI qpn i) ppa
211+
let mnppa = extend (extSupported stage) (langSupported stage) (pkgPresent stage) newactives
212+
=<< extendWithPackageChoice (PI qpn i) ppa
212213
-- In case we continue, we save the scoped dependencies
213214
let nsvd = M.insert qpn qdeps svd
214215
case mfr of
@@ -233,7 +234,7 @@ validate = go
233234

234235
-- What to do for flag nodes ...
235236
goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
236-
goF qfn@(FN qpn _f) b r = do
237+
goF qfn@(FN qpn@(Q (PackagePath stage _) _) _f) b r = do
237238
PA ppa pfa psa <- asks pa -- obtain current preassignment
238239
extSupported <- asks supportedExt -- obtain the supported extensions
239240
langSupported <- asks supportedLang -- obtain the supported languages
@@ -255,15 +256,15 @@ validate = go
255256
let newactives = extractNewDeps (F qfn) b npfa psa qdeps
256257
mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives
257258
-- As in the package case, we try to extend the partial assignment.
258-
let mnppa = extend ({- FIXME -} extSupported Host) ({- FIXME -} langSupported Host) ({- FIXME -} pkgPresent Host) newactives ppa
259+
let mnppa = extend (extSupported stage) (langSupported stage) (pkgPresent stage) newactives ppa
259260
case liftM2 (,) mnppa mNewRequiredComps of
260261
Left (c, fr) -> return (Fail c fr) -- inconsistency found
261262
Right (nppa, rComps') ->
262263
local (\ s -> s { pa = PA nppa npfa psa, requiredComponents = rComps' }) r
263264

264265
-- What to do for stanza nodes (similar to flag nodes) ...
265266
goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
266-
goS qsn@(SN qpn _f) b r = do
267+
goS qsn@(SN qpn@(Q (PackagePath stage _) _) _f) b r = do
267268
PA ppa pfa psa <- asks pa -- obtain current preassignment
268269
extSupported <- asks supportedExt -- obtain the supported extensions
269270
langSupported <- asks supportedLang -- obtain the supported languages
@@ -285,7 +286,7 @@ validate = go
285286
let newactives = extractNewDeps (S qsn) b pfa npsa qdeps
286287
mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives
287288
-- As in the package case, we try to extend the partial assignment.
288-
let mnppa = extend ({- FIXME -} extSupported Host) ({- FIXME -} langSupported Host) ({- FIXME -} pkgPresent Host) newactives ppa
289+
let mnppa = extend (extSupported stage) (langSupported stage) (pkgPresent stage) newactives ppa
289290
case liftM2 (,) mnppa mNewRequiredComps of
290291
Left (c, fr) -> return (Fail c fr) -- inconsistency found
291292
Right (nppa, rComps') ->

‎cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -68,12 +68,12 @@ scopeToPackageName (ScopeAnySetupQualifier pn) = pn
6868
scopeToPackageName (ScopeAnyQualifier pn) = pn
6969

7070
constraintScopeMatches :: ConstraintScope -> QPN -> Bool
71-
constraintScopeMatches (ScopeTarget pn) (Q (PackagePath q) pn') =
71+
constraintScopeMatches (ScopeTarget pn) (Q (PackagePath _ q) pn') =
7272
q == QualToplevel && pn == pn'
73-
constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath q') pn') =
73+
constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') =
7474
q == q' && pn == pn'
7575
constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') =
76-
let setup (PackagePath (QualSetup _)) = True
76+
let setup (PackagePath _ (QualSetup _)) = True
7777
setup _ = False
7878
in setup pp && pn == pn'
7979
constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn'

0 commit comments

Comments
 (0)