Skip to content

Commit 259b4e3

Browse files
dcouttsdcoutts
committed
Merge pull request #2530 from edsko/pr/base-shim
Add support for base shims to the modular solver
2 parents d938b91 + 72e2ea1 commit 259b4e3

File tree

7 files changed

+161
-25
lines changed

7 files changed

+161
-25
lines changed

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

Lines changed: 5 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,6 @@ module Distribution.Client.Dependency.Modular.Builder (buildTree) where
1616
-- flag-guarded dependencies, we cannot introduce them immediately. Instead, we
1717
-- store the entire dependency.
1818

19-
import Control.Monad.Reader hiding (sequence, mapM)
2019
import Data.List as L
2120
import Data.Map as M
2221
import Prelude hiding (sequence, mapM)
@@ -35,7 +34,8 @@ data BuildState = BS {
3534
index :: Index, -- ^ information about packages and their dependencies
3635
rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies
3736
open :: PSQ (OpenGoal ()) (), -- ^ set of still open goals (flag and package goals)
38-
next :: BuildType -- ^ kind of node to generate next
37+
next :: BuildType, -- ^ kind of node to generate next
38+
qualifyOptions :: QualifyOptions -- ^ qualification options
3939
}
4040

4141
-- | Extend the set of open goals with the new goals listed.
@@ -65,19 +65,10 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
6565
-- dependencies and then extend the set of open goals accordingly.
6666
scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps Component PN -> FlagInfo ->
6767
BuildState -> BuildState
68-
scopedExtendOpen qpn@(Q pp pn) i gr fdeps fdefs s = extendOpen qpn gs s
68+
scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s
6969
where
7070
-- Qualify all package names
71-
--
72-
-- NOTE: We `fmap` over the setup dependencies to qualify the package name,
73-
-- BUT this is _only_ correct because the setup dependencies cannot have
74-
-- conditional sections (setup dependencies cannot depend on flags). IF
75-
-- setup dependencies _could_ depend on flags, then these flag names should
76-
-- NOT be qualified with @Q (Setup pn pp)@ but rather with @pp@: flag
77-
-- assignments are package wide, irrespective of whether or not we treat
78-
-- certain dependencies as independent or not.
79-
qfdeps = L.map (fmap (Q pp)) (nonSetupDeps fdeps)
80-
++ L.map (fmap (Q (Setup pn pp))) (setupDeps fdeps)
71+
qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps
8172
-- Introduce all package flags
8273
qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs
8374
-- Combine new package and flag goals
@@ -168,6 +159,7 @@ buildTree idx ind igs =
168159
, rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns)
169160
, open = P.fromList (L.map (\ qpn -> (topLevelGoal qpn, ())) qpns)
170161
, next = Goals
162+
, qualifyOptions = defaultQualifyOptions idx
171163
}
172164
where
173165
topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) [UserGoal]

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

Lines changed: 60 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE DeriveFunctor #-}
2+
{-# LANGUAGE RecordWildCards #-}
23
module Distribution.Client.Dependency.Modular.Dependency (
34
-- * Variables
45
Var(..)
@@ -18,6 +19,9 @@ module Distribution.Client.Dependency.Modular.Dependency (
1819
, FalseFlaggedDeps
1920
, Dep(..)
2021
, showDep
22+
, flattenFlaggedDeps
23+
, QualifyOptions(..)
24+
, qualifyDeps
2125
-- ** Setting/forgetting components
2226
, forgetCompOpenGoal
2327
, setCompFlaggedDeps
@@ -174,6 +178,17 @@ data FlaggedDep comp qpn =
174178
| Simple (Dep qpn) comp
175179
deriving (Eq, Show, Functor)
176180

181+
-- | Conversatively flatten out flagged dependencies
182+
--
183+
-- NOTE: We do not filter out duplicates.
184+
flattenFlaggedDeps :: FlaggedDeps Component qpn -> [(Dep qpn, Component)]
185+
flattenFlaggedDeps = concatMap aux
186+
where
187+
aux :: FlaggedDep Component qpn -> [(Dep qpn, Component)]
188+
aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f
189+
aux (Stanza _ t) = flattenFlaggedDeps t
190+
aux (Simple d c) = [(d, c)]
191+
177192
type TrueFlaggedDeps qpn = FlaggedDeps Component qpn
178193
type FalseFlaggedDeps qpn = FlaggedDeps Component qpn
179194

@@ -191,6 +206,51 @@ showDep (Dep qpn (Constrained [(vr, Goal v _)])) =
191206
showDep (Dep qpn ci ) =
192207
showQPN qpn ++ showCI ci
193208

209+
-- | Options for goal qualification (used in 'qualifyDeps')
210+
--
211+
-- See also 'defaultQualifyOptions'
212+
data QualifyOptions = QO {
213+
-- | Do we have a version of base relying on another version of base?
214+
qoBaseShim :: Bool
215+
216+
-- Should dependencies of the setup script be treated as independent?
217+
, qoSetupIndependent :: Bool
218+
}
219+
deriving Show
220+
221+
-- | Apply built-in rules for package qualifiers
222+
--
223+
-- NOTE: It's the _dependencies_ of a package that may or may not be independent
224+
-- from the package itself. Package flag choices must of course be consistent.
225+
qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps Component PN -> FlaggedDeps Component QPN
226+
qualifyDeps QO{..} (Q pp' pn) = go
227+
where
228+
-- The Base qualifier does not get inherited
229+
pp :: PP
230+
pp = (if qoBaseShim then stripBase else id) pp'
231+
232+
go :: FlaggedDeps Component PN -> FlaggedDeps Component QPN
233+
go = map go1
234+
235+
go1 :: FlaggedDep Component PN -> FlaggedDep Component QPN
236+
go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f)
237+
go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t)
238+
go1 (Simple dep comp) = Simple (goD dep comp) comp
239+
240+
goD :: Dep PN -> Component -> Dep QPN
241+
goD dep comp
242+
| qBase dep = fmap (Q (Base pn pp)) dep
243+
| qSetup comp = fmap (Q (Setup pn pp)) dep
244+
| otherwise = fmap (Q pp ) dep
245+
246+
-- Should we qualify this goal with the 'Base' package path?
247+
qBase :: Dep PN -> Bool
248+
qBase (Dep dep _ci) = qoBaseShim && unPackageName dep == "base"
249+
250+
-- Should we qualify this goal with the 'Setup' packaeg path?
251+
qSetup :: Component -> Bool
252+
qSetup comp = qoSetupIndependent && comp == ComponentSetup
253+
194254
{-------------------------------------------------------------------------------
195255
Setting/forgetting the Component
196256
-------------------------------------------------------------------------------}

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

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -30,3 +30,18 @@ mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi)))
3030

3131
groupMap :: Ord a => [(a, b)] -> Map a [b]
3232
groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs)
33+
34+
defaultQualifyOptions :: Index -> QualifyOptions
35+
defaultQualifyOptions idx = QO {
36+
qoBaseShim = or [ dep == base
37+
| -- Find all versions of base ..
38+
Just is <- [M.lookup base idx]
39+
-- .. which are installed ..
40+
, (I _ver (Inst _), PInfo deps _flagNfo _fr) <- M.toList is
41+
-- .. and flatten all their dependencies ..
42+
, (Dep dep _ci, _comp) <- flattenFlaggedDeps deps
43+
]
44+
, qoSetupIndependent = True
45+
}
46+
where
47+
base = PackageName "base"

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

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -85,6 +85,7 @@ data ValidateState = VS {
8585
, vsLinks :: Map QPN LinkGroup
8686
, vsFlags :: FAssignment
8787
, vsStanzas :: SAssignment
88+
, vsQualifyOptions :: QualifyOptions
8889
}
8990
deriving Show
9091

@@ -116,11 +117,10 @@ validateLinking index = (`runReader` initVS) . cata go
116117

117118
-- Package choices
118119
goP :: QPN -> POption -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
119-
goP qpn@(Q pp pn) opt@(POption i _) r = do
120+
goP qpn@(Q _pp pn) opt@(POption i _) r = do
120121
vs <- ask
121122
let PInfo deps _ _ = vsIndex vs ! pn ! i
122-
qdeps = map (fmap (Q pp)) (nonSetupDeps deps)
123-
++ map (fmap (Q (Setup pn pp))) (setupDeps deps)
123+
qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps
124124
case execUpdateState (pickPOption qpn opt qdeps) vs of
125125
Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
126126
Right vs' -> local (const vs') r
@@ -147,6 +147,7 @@ validateLinking index = (`runReader` initVS) . cata go
147147
, vsLinks = M.empty
148148
, vsFlags = M.empty
149149
, vsStanzas = M.empty
150+
, vsQualifyOptions = defaultQualifyOptions index
150151
}
151152

152153
{-------------------------------------------------------------------------------
@@ -254,8 +255,7 @@ linkNewDeps var b = do
254255
vs <- get
255256
let (qpn@(Q pp pn), Just i) = varPI var
256257
PInfo deps _ _ = vsIndex vs ! pn ! i
257-
qdeps = map (fmap (Q pp)) (nonSetupDeps deps)
258-
++ map (fmap (Q (Setup pn pp))) (setupDeps deps)
258+
qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps
259259
lg = vsLinks vs ! qpn
260260
(parents, newDeps) = findNewDeps vs qdeps
261261
linkedTo = S.delete pp (lgMembers lg)

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

Lines changed: 19 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -69,15 +69,33 @@ instI _ = False
6969
-- | Package path.
7070
--
7171
-- Stored in reverse order
72-
data PP = Independent Int PP | Setup PN PP | None
72+
data PP =
73+
-- User-specified independent goal
74+
Independent Int PP
75+
-- Setup dependencies are always considered independent from their package
76+
| Setup PN PP
77+
-- Any dependency on base is considered independent (allows for base shims)
78+
| Base PN PP
79+
-- Unqualified
80+
| None
7381
deriving (Eq, Ord, Show)
7482

83+
-- | Strip any 'Base' qualifiers from a PP
84+
--
85+
-- (the Base qualifier does not get inherited)
86+
stripBase :: PP -> PP
87+
stripBase (Independent i pp) = Independent i (stripBase pp)
88+
stripBase (Setup pn pp) = Setup pn (stripBase pp)
89+
stripBase (Base _pn pp) = stripBase pp
90+
stripBase None = None
91+
7592
-- | String representation of a package path.
7693
--
7794
-- NOTE: This always ends in a period
7895
showPP :: PP -> String
7996
showPP (Independent i pp) = show i ++ "." ++ showPP pp
8097
showPP (Setup pn pp) = display pn ++ ".setup." ++ showPP pp
98+
showPP (Base pn pp) = display pn ++ "." ++ showPP pp
8199
showPP None = ""
82100

83101
-- | A qualified entity. Pairs a package path with the entity.
@@ -103,6 +121,5 @@ makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]
103121
, let pp = Independent i None
104122
]
105123

106-
107124
unQualify :: Q a -> a
108125
unQualify (Q _ x) = x

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

Lines changed: 11 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -77,7 +77,8 @@ import Distribution.Client.ComponentDeps (Component)
7777
data ValidateState = VS {
7878
index :: Index,
7979
saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies
80-
pa :: PreAssignment
80+
pa :: PreAssignment,
81+
qualifyOptions :: QualifyOptions
8182
}
8283

8384
type Validate = Reader ValidateState
@@ -120,15 +121,15 @@ validate = cata go
120121

121122
-- What to do for package nodes ...
122123
goP :: QPN -> QGoalReasonChain -> POption -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
123-
goP qpn@(Q pp pn) gr (POption i _) r = do
124+
goP qpn@(Q _pp pn) gr (POption i _) r = do
124125
PA ppa pfa psa <- asks pa -- obtain current preassignment
125126
idx <- asks index -- obtain the index
126127
svd <- asks saved -- obtain saved dependencies
128+
qo <- asks qualifyOptions
127129
-- obtain dependencies and index-dictated exclusions introduced by the choice
128130
let (PInfo deps _ mfr) = idx ! pn ! i
129131
-- qualify the deps in the current scope
130-
let qdeps = L.map (fmap (Q pp)) (nonSetupDeps deps)
131-
++ L.map (fmap (Q (Setup pn pp))) (setupDeps deps)
132+
let qdeps = qualifyDeps qo qpn deps
132133
-- the new active constraints are given by the instance we have chosen,
133134
-- plus the dependency information we have for that instance
134135
let goal = Goal (P qpn) gr
@@ -235,4 +236,9 @@ extractNewDeps v gr b fa sa = go
235236

236237
-- | Interface.
237238
validateTree :: Index -> Tree QGoalReasonChain -> Tree QGoalReasonChain
238-
validateTree idx t = runReader (validate t) (VS idx M.empty (PA M.empty M.empty M.empty))
239+
validateTree idx t = runReader (validate t) VS {
240+
index = idx
241+
, saved = M.empty
242+
, pa = PA M.empty M.empty M.empty
243+
, qualifyOptions = defaultQualifyOptions idx
244+
}

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

Lines changed: 46 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -79,6 +79,14 @@ tests = [
7979
, runTest $ mkTest db9 "setupDeps7" ["F", "G"] (Just [("A", 1), ("B", 1), ("B",2 ), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)])
8080
, runTest $ mkTest db10 "setupDeps8" ["C"] (Just [("C", 1)])
8181
]
82+
, testGroup "Base shim" [
83+
runTest $ mkTest db11 "baseShim1" ["A"] (Just [("A", 1)])
84+
, runTest $ mkTest db12 "baseShim2" ["A"] (Just [("A", 1)])
85+
, runTest $ mkTest db12 "baseShim3" ["B"] (Just [("B", 1)])
86+
, runTest $ mkTest db12 "baseShim4" ["C"] (Just [("A", 1), ("B", 1), ("C", 1)])
87+
, runTest $ mkTest db12 "baseShim5" ["D"] Nothing
88+
, runTest $ mkTest db12 "baseShim6" ["E"] (Just [("E", 1), ("syb", 2)])
89+
]
8290
]
8391
where
8492
indep test = test { testIndepGoals = True }
@@ -314,6 +322,44 @@ db10 =
314322
, Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]
315323
]
316324

325+
-- | Tests for dealing with base shims
326+
db11 :: ExampleDb
327+
db11 =
328+
let base3 = exInst "base" 3 "base-3-inst" [base4]
329+
base4 = exInst "base" 4 "base-4-inst" []
330+
in [
331+
Left base3
332+
, Left base4
333+
, Right $ exAv "A" 1 [ExFix "base" 3]
334+
]
335+
336+
-- | Slightly more realistic version of db11 where base-3 depends on syb
337+
-- This means that if a package depends on base-3 and on syb, then they MUST
338+
-- share the version of syb
339+
--
340+
-- * Package A relies on base-3 (which relies on base-4)
341+
-- * Package B relies on base-4
342+
-- * Package C relies on both A and B
343+
-- * Package D relies on base-3 and on syb-2, which is not possible because
344+
-- base-3 has a dependency on syb-1 (non-inheritance of the Base qualifier)
345+
-- * Package E relies on base-4 and on syb-2, which is fine.
346+
db12 :: ExampleDb
347+
db12 =
348+
let base3 = exInst "base" 3 "base-3-inst" [base4, syb1]
349+
base4 = exInst "base" 4 "base-4-inst" []
350+
syb1 = exInst "syb" 1 "syb-1-inst" [base4]
351+
in [
352+
Left base3
353+
, Left base4
354+
, Left syb1
355+
, Right $ exAv "syb" 2 [ExFix "base" 4]
356+
, Right $ exAv "A" 1 [ExFix "base" 3, ExAny "syb"]
357+
, Right $ exAv "B" 1 [ExFix "base" 4, ExAny "syb"]
358+
, Right $ exAv "C" 1 [ExAny "A", ExAny "B"]
359+
, Right $ exAv "D" 1 [ExFix "base" 3, ExFix "syb" 2]
360+
, Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2]
361+
]
362+
317363
{-------------------------------------------------------------------------------
318364
Example package database DSL
319365

0 commit comments

Comments
 (0)