Skip to content

Commit c8f78a2

Browse files
andreabediniandreabedini
committed
wip
1 parent 79ff366 commit c8f78a2

File tree

18 files changed

+282
-231
lines changed

18 files changed

+282
-231
lines changed

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

Lines changed: 15 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -60,6 +60,9 @@ import Distribution.Pretty (Pretty (..))
6060
import Text.PrettyPrint (text, vcat, Doc, nest, ($+$))
6161
import Distribution.Solver.Types.OptionalStanza (showStanzas, optStanzaSetNull)
6262
import Distribution.Types.Flag (nullFlagAssignment)
63+
import Distribution.Solver.Types.Toolchain (Toolchain(..), Staged)
64+
import Distribution.Simple.Compiler (compilerInfo)
65+
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
6366

6467

6568
showCP :: CP QPN -> Doc
@@ -79,14 +82,19 @@ showCP (CP qpi fa es ds) =
7982
-- | Ties the two worlds together: classic cabal-install vs. the modular
8083
-- solver. Performs the necessary translations before and after.
8184
modularResolver :: SolverConfig -> DependencyResolver loc
82-
modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns = do
83-
(assignment, revdepmap) <- solve' sc cinfo idx pkgConfigDB pprefs gcs pns
85+
modularResolver sc toolchains' sidx pprefs pcs pns = do
86+
(assignment, revdepmap) <- solve' sc toolchains idx pprefs gcs pns
8487
let cp = toCPs assignment revdepmap
8588
Step (show (vcat (map showCP cp))) $
8689
return $ postprocess assignment revdepmap
8790
where
8891
-- Indices have to be converted into solver-specific uniform index.
89-
idx = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx
92+
idx = convPIs toolchains' gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx
93+
94+
-- idx = foldMap (\((Toolchain (Platform arch os) comp _progdb), iidx, _) ->
95+
-- convPIs os arch (compilerInfo comp) gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx
96+
-- ) toolchains'
97+
9098
-- Constraints have to be converted into a finite map indexed by PN.
9199
gcs = M.fromListWith (++) (map pair pcs)
92100
where
@@ -136,21 +144,21 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns
136144
-- complete, i.e., it shows the whole chain of dependencies from the user
137145
-- targets to the conflicting packages.
138146
solve' :: SolverConfig
139-
-> CompilerInfo
147+
-> Staged Toolchain
148+
-> Staged (Maybe PkgConfigDb)
140149
-> Index
141-
-> Maybe PkgConfigDb
142150
-> (PN -> PackagePreferences)
143151
-> Map PN [LabeledPackageConstraint]
144152
-> Set PN
145153
-> Progress String String (Assignment, RevDepMap)
146-
solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
154+
solve' sc toolchains pkgConfigDb idx pprefs gcs pns =
147155
toProgress $ retry (runSolver printFullLog sc) createErrorMsg
148156
where
149157
runSolver :: Bool -> SolverConfig
150158
-> RetryLog String SolverFailure (Assignment, RevDepMap)
151159
runSolver keepLog sc' =
152160
displayLogMessages keepLog $
153-
solve sc' cinfo idx pkgConfigDB pprefs gcs pns
161+
solve sc' toolchains pkgConfigDb idx pprefs gcs pns
154162

155163
createErrorMsg :: SolverFailure
156164
-> RetryLog String String (Assignment, RevDepMap)

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

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -29,7 +29,7 @@ convCP :: SI.InstalledPackageIndex ->
2929
convCP iidx sidx (CP qpi fa es ds) =
3030
case qpi of
3131
-- Installed
32-
(PI qpn (I _ (Inst pi))) ->
32+
(PI qpn (I _ _ (Inst pi))) ->
3333
PreExisting $
3434
InstSolverPackage {
3535
instSolverQPN = qpn,
@@ -38,7 +38,7 @@ convCP iidx sidx (CP qpi fa es ds) =
3838
instSolverPkgExeDeps = fmap snd ds'
3939
}
4040
-- "In repo" i.e. a source package
41-
(PI qpn@(Q _path pn) (I v InRepo)) ->
41+
(PI qpn@(Q _path pn) (I _ v InRepo)) ->
4242
let pi = PackageIdentifier pn v in
4343
Configured $
4444
SolverPackage {
@@ -54,7 +54,7 @@ convCP iidx sidx (CP qpi fa es ds) =
5454
ds' = fmap (partitionEithers . map convConfId) ds
5555

5656
convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -}
57-
convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) =
57+
convConfId (PI (Q (PackagePath _ q) pn) (I _ v loc)) =
5858
case loc of
5959
Inst pi ->
6060
Left (PreExistingId sourceId pi)

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -268,7 +268,7 @@ exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx
268268
-- Skipping it is an optimization. If false, it returns a new conflict set
269269
-- to be merged with the previous one.
270270
couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet
271-
couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts =
271+
couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I _ v _) _) conflicts =
272272
let (PInfo deps _ _ _) = idx M.! pn M.! i
273273
qdeps = qualifyDeps currentQPN deps
274274

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

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,14 @@ import Distribution.Solver.Modular.Flag
1818
import Distribution.Solver.Modular.Package
1919
import Distribution.Solver.Modular.Tree
2020

21+
newtype MonoidalMap k v = MonoidalMap (Map k v)
22+
23+
instance (Ord k, Semigroup v) => Semigroup (MonoidalMap k v) where
24+
(MonoidalMap l) <> (MonoidalMap r) = MonoidalMap (M.unionWith (<>) l r)
25+
26+
instance (Ord k, Monoid v) => Monoid (MonoidalMap k v) where
27+
mempty = mempty
28+
2129
-- | An index contains information about package instances. This is a nested
2230
-- dictionary. Package names are mapped to instances, which in turn is mapped
2331
-- to info.

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

Lines changed: 118 additions & 80 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
module Distribution.Solver.Modular.IndexConversion
2-
( convPIs
3-
) where
2+
( convPIs
3+
) where
44

55
import Distribution.Solver.Compat.Prelude
66
import Prelude ()
@@ -11,36 +11,38 @@ import qualified Distribution.Compat.NonEmptySet as NonEmptySet
1111
import qualified Data.Set as S
1212

1313
import qualified Distribution.InstalledPackageInfo as IPI
14-
import Distribution.Compiler
15-
import Distribution.Package -- from Cabal
16-
import Distribution.Simple.BuildToolDepends -- from Cabal
17-
import Distribution.Types.ExeDependency -- from Cabal
18-
import Distribution.Types.PkgconfigDependency -- from Cabal
19-
import Distribution.Types.ComponentName -- from Cabal
20-
import Distribution.Types.CondTree -- from Cabal
21-
import Distribution.Types.MungedPackageId -- from Cabal
22-
import Distribution.Types.MungedPackageName -- from Cabal
23-
import Distribution.PackageDescription -- from Cabal
24-
import Distribution.PackageDescription.Configuration
14+
import Distribution.Compiler
15+
import Distribution.Package
16+
import Distribution.Simple.BuildToolDepends
17+
import Distribution.Simple.Compiler (compilerInfo)
18+
import Distribution.Types.ExeDependency
19+
import Distribution.Types.PkgconfigDependency
20+
import Distribution.Types.ComponentName
21+
import Distribution.Types.CondTree
22+
import Distribution.Types.MungedPackageId
23+
import Distribution.Types.MungedPackageName
24+
import Distribution.PackageDescription
25+
import Distribution.PackageDescription.Configuration
2526
import qualified Distribution.Simple.PackageIndex as SI
26-
import Distribution.System
27+
import Distribution.System
2728

28-
import Distribution.Solver.Types.ComponentDeps
29-
( Component(..), componentNameToComponent )
29+
import Distribution.Solver.Types.ComponentDeps ( Component(..), componentNameToComponent )
3030
import Distribution.Solver.Types.Flag
3131
import Distribution.Solver.Types.LabeledPackageConstraint
3232
import Distribution.Solver.Types.OptionalStanza
3333
import Distribution.Solver.Types.PackageConstraint
3434
import qualified Distribution.Solver.Types.PackageIndex as CI
3535
import Distribution.Solver.Types.Settings
3636
import Distribution.Solver.Types.SourcePackage
37+
import Distribution.Solver.Types.Toolchain
38+
import qualified Distribution.Solver.Types.Stage as Stage
3739

38-
import Distribution.Solver.Modular.Dependency as D
39-
import Distribution.Solver.Modular.Flag as F
40-
import Distribution.Solver.Modular.Index
41-
import Distribution.Solver.Modular.Package
42-
import Distribution.Solver.Modular.Tree
43-
import Distribution.Solver.Modular.Version
40+
import Distribution.Solver.Modular.Dependency as D
41+
import Distribution.Solver.Modular.Flag as F
42+
import Distribution.Solver.Modular.Index
43+
import Distribution.Solver.Modular.Package
44+
import Distribution.Solver.Modular.Tree
45+
import Distribution.Solver.Modular.Version
4446

4547
-- | Convert both the installed package index and the source package
4648
-- index into one uniform solver index.
@@ -53,59 +55,75 @@ import Distribution.Solver.Modular.Version
5355
-- resolving these situations. However, the right thing to do is to
5456
-- fix the problem there, so for now, shadowing is only activated if
5557
-- explicitly requested.
56-
convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
57-
-> ShadowPkgs -> StrongFlags -> SolveExecutables
58-
-> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc)
59-
-> Index
60-
convPIs os arch comp constraints sip strfl solveExes iidx sidx =
61-
mkIndex $
62-
convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx
58+
convPIs
59+
:: Staged Toolchain
60+
-> Map PN [LabeledPackageConstraint]
61+
-> ShadowPkgs
62+
-> StrongFlags
63+
-> SolveExecutables
64+
-> Staged SI.InstalledPackageIndex
65+
-> CI.PackageIndex (SourcePackage loc)
66+
-> Index
67+
convPIs toolchains' constraints sip strfl solveExes iidx sidx =
68+
mkIndex $ convIPI' sip iidx ++ convSPI' toolchains' constraints strfl solveExes sidx
69+
-- [ foldMap
70+
-- (\(stage, idx) -> convIPI' stage sip idx)
71+
-- (tabulate iidx)
72+
-- , foldMap
73+
-- (\(stage, Toolchain{toolchainCompiler = comp, toolchainPlatform = Platform arch os}) ->
74+
-- convSPI' stage os arch comp constraints strfl solveExes sidx
75+
-- )
76+
-- toolchains'
77+
-- ]
6378

6479
-- | Convert a Cabal installed package index to the simpler,
6580
-- more uniform index format of the solver.
66-
convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)]
67-
convIPI' (ShadowPkgs sip) idx =
81+
convIPI' :: ShadowPkgs -> Staged SI.InstalledPackageIndex -> [(PN, I, PInfo)]
82+
convIPI' (ShadowPkgs sip) =
83+
Stage.foldMapWithKey (\stage idx ->
6884
-- apply shadowing whenever there are multiple installed packages with
6985
-- the same version
70-
[ maybeShadow (convIP idx pkg)
71-
-- IMPORTANT to get internal libraries. See
72-
-- Note [Index conversion with internal libraries]
73-
| (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx
74-
, (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ]
86+
[ maybeShadow (convIP stage idx pkg)
87+
| -- IMPORTANT to get internal libraries. See Note [Index conversion with internal libraries]
88+
(_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx
89+
, (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs
90+
])
7591
where
76-
7792
-- shadowing is recorded in the package info
7893
shadow (pn, i, PInfo fdeps comps fds _)
7994
| sip = (pn, i, PInfo fdeps comps fds (Just Shadowed))
80-
shadow x = x
95+
shadow x = x
8196

8297
-- | Extract/recover the package ID from an installed package info, and convert it to a solver's I.
83-
convId :: IPI.InstalledPackageInfo -> (PN, I)
84-
convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi)
85-
where MungedPackageId mpn ver = mungedId ipi
86-
-- HACK. See Note [Index conversion with internal libraries]
87-
pn = encodeCompatPackageName mpn
98+
convId :: Stage -> IPI.InstalledPackageInfo -> (PN, I)
99+
convId stage ipi = (pn, I stage ver $ Inst $ IPI.installedUnitId ipi)
100+
where
101+
MungedPackageId mpn ver = mungedId ipi
102+
-- HACK. See Note [Index conversion with internal libraries]
103+
pn = encodeCompatPackageName mpn
88104

89105
-- | Convert a single installed package into the solver-specific format.
90-
convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo)
91-
convIP idx ipi =
92-
case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of
93-
Left u -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u)))
94-
Right fds -> (pn, i, PInfo fds components M.empty Nothing)
95-
where
96-
-- TODO: Handle sub-libraries and visibility.
97-
components =
98-
M.singleton (ExposedLib LMainLibName)
99-
ComponentInfo {
100-
compIsVisible = IsVisible True
101-
, compIsBuildable = IsBuildable True
102-
}
103-
104-
(pn, i) = convId ipi
105-
106-
-- 'sourceLibName' is unreliable, but for now we only really use this for
107-
-- primary libs anyways
108-
comp = componentNameToComponent $ CLibName $ IPI.sourceLibName ipi
106+
convIP :: Stage -> SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo)
107+
convIP stage idx ipi =
108+
case traverse (convIPId stage (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of
109+
Left u -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u)))
110+
Right fds -> (pn, i, PInfo fds components M.empty Nothing)
111+
where
112+
-- TODO: Handle sub-libraries and visibility.
113+
components =
114+
M.singleton
115+
(ExposedLib LMainLibName)
116+
ComponentInfo
117+
{ compIsVisible = IsVisible True
118+
, compIsBuildable = IsBuildable True
119+
}
120+
121+
(pn, i) = convId stage ipi
122+
123+
-- 'sourceLibName' is unreliable, but for now we only really use this for
124+
-- primary libs anyways
125+
comp = componentNameToComponent $ CLibName $ IPI.sourceLibName ipi
126+
109127
-- TODO: Installed packages should also store their encapsulations!
110128

111129
-- Note [Index conversion with internal libraries]
@@ -141,31 +159,51 @@ convIP idx ipi =
141159
-- May return Nothing if the package can't be found in the index. That
142160
-- indicates that the original package having this dependency is broken
143161
-- and should be ignored.
144-
convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN)
145-
convIPId dr comp idx ipid =
162+
convIPId :: Stage -> DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN)
163+
convIPId stage dr comp idx ipid =
146164
case SI.lookupUnitId idx ipid of
147-
Nothing -> Left ipid
148-
Just ipi -> let (pn, i) = convId ipi
149-
name = ExposedLib LMainLibName -- TODO: Handle sub-libraries.
150-
in Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp)
151-
-- NB: something we pick up from the
152-
-- InstalledPackageIndex is NEVER an executable
165+
Nothing -> Left ipid
166+
Just ipi ->
167+
let (pn, i) = convId stage ipi
168+
name = ExposedLib LMainLibName -- TODO: Handle sub-libraries.
169+
in Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp)
170+
171+
-- NB: something we pick up from the
172+
-- InstalledPackageIndex is NEVER an executable
153173

154174
-- | Convert a cabal-install source package index to the simpler,
155175
-- more uniform index format of the solver.
156-
convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
157-
-> StrongFlags -> SolveExecutables
158-
-> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)]
159-
convSPI' os arch cinfo constraints strfl solveExes =
160-
L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages
176+
convSPI'
177+
:: Staged Toolchain
178+
-> Map PN [LabeledPackageConstraint]
179+
-> StrongFlags
180+
-> SolveExecutables
181+
-> CI.PackageIndex (SourcePackage loc)
182+
-> [(PN, I, PInfo)]
183+
convSPI' toolchains constraints strfl solveExes sidx =
184+
Stage.foldMapWithKey (\stage toolchain ->
185+
let
186+
Platform arch os = toolchainPlatform toolchain
187+
cinfo = compilerInfo (toolchainCompiler toolchain)
188+
in
189+
L.map (convSP stage os arch cinfo constraints strfl solveExes) (CI.allPackages sidx)
190+
) toolchains
161191

162192
-- | Convert a single source package into the solver-specific format.
163-
convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
164-
-> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo)
165-
convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
166-
let i = I pv InRepo
193+
convSP
194+
:: Stage
195+
-> OS
196+
-> Arch
197+
-> CompilerInfo
198+
-> Map PN [LabeledPackageConstraint]
199+
-> StrongFlags
200+
-> SolveExecutables
201+
-> SourcePackage loc
202+
-> (PN, I, PInfo)
203+
convSP stage os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
204+
let i = I stage pv InRepo
167205
pkgConstraints = fromMaybe [] $ M.lookup pn constraints
168-
in (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd)
206+
in (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd)
169207

170208
-- We do not use 'flattenPackageDescription' or 'finalizePD'
171209
-- from 'Distribution.PackageDescription.Configuration' here, because we

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

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,7 @@ import Distribution.Pretty (prettyShow)
2424

2525
import Distribution.Solver.Modular.Version
2626
import Distribution.Solver.Types.PackagePath
27+
import Distribution.Solver.Types.Stage (Stage)
2728

2829
-- | A package name.
2930
type PN = PackageName
@@ -50,13 +51,13 @@ data Loc = Inst PId | InRepo
5051
deriving (Eq, Ord, Show)
5152

5253
-- | Instance. A version number and a location.
53-
data I = I Ver Loc
54+
data I = I Stage Ver Loc
5455
deriving (Eq, Ord, Show)
5556

5657
-- | String representation of an instance.
5758
showI :: I -> String
58-
showI (I v InRepo) = showVer v
59-
showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid
59+
showI (I s v InRepo) = show s ++ ":" ++ showVer v
60+
showI (I s v (Inst uid)) = show s ++ ":" ++ showVer v ++ "/installed" ++ extractPackageAbiHash uid
6061
where
6162
extractPackageAbiHash xs =
6263
case first reverse $ break (=='-') $ reverse (prettyShow xs) of
@@ -72,7 +73,7 @@ showPI :: PI QPN -> String
7273
showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i
7374

7475
instI :: I -> Bool
75-
instI (I _ (Inst _)) = True
76+
instI (I _ _ (Inst _)) = True
7677
instI _ = False
7778

7879
-- | Qualify a target package with its own name so that its dependencies are not

0 commit comments

Comments
 (0)