Skip to content

Commit 009bcdb

Browse files
andreabediniandreabedini
committed
refactor: Move ConstraintSource back to cabal-install
Braching off the discussion at haskell#9578 (comment) The solver should not know anything about project configuration as it is only a cabal-install concept. The caller should instead be able to add arbitrary annotation to the global constraints it passes to the solver.
1 parent 0a16cf7 commit 009bcdb

31 files changed

+155
-153
lines changed

‎cabal-install-solver/cabal-install-solver.cabal‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -78,7 +78,6 @@ library
7878
Distribution.Solver.Modular.Version
7979
Distribution.Solver.Modular.WeightedPSQ
8080
Distribution.Solver.Types.ComponentDeps
81-
Distribution.Solver.Types.ConstraintSource
8281
Distribution.Solver.Types.DependencyResolver
8382
Distribution.Solver.Types.Flag
8483
Distribution.Solver.Types.InstalledPreference

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

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -58,7 +58,7 @@ import Distribution.Verbosity
5858

5959
-- | Ties the two worlds together: classic cabal-install vs. the modular
6060
-- solver. Performs the necessary translations before and after.
61-
modularResolver :: SolverConfig -> DependencyResolver loc
61+
modularResolver :: (Typeable cs, Show cs, Eq cs) => SolverConfig -> DependencyResolver loc cs
6262
modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =
6363
uncurry postprocess <$> -- convert install plan
6464
solve' sc cinfo idx pkgConfigDB pprefs gcs pns
@@ -113,12 +113,13 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns
113113
-- Using the full log from a rerun of the solver ensures that the log is
114114
-- complete, i.e., it shows the whole chain of dependencies from the user
115115
-- targets to the conflicting packages.
116-
solve' :: SolverConfig
116+
solve' :: (Typeable cs, Eq cs, Show cs)
117+
=> SolverConfig
117118
-> CompilerInfo
118119
-> Index
119120
-> PkgConfigDb
120121
-> (PN -> PackagePreferences)
121-
-> Map PN [LabeledPackageConstraint]
122+
-> Map PN [LabeledPackageConstraint cs]
122123
-> Set PN
123124
-> Progress String String (Assignment, RevDepMap)
124125
solve' sc cinfo idx pkgConfigDB pprefs gcs pns =

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

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -53,7 +53,7 @@ import Distribution.Solver.Modular.Version
5353
-- resolving these situations. However, the right thing to do is to
5454
-- fix the problem there, so for now, shadowing is only activated if
5555
-- explicitly requested.
56-
convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
56+
convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint cs]
5757
-> ShadowPkgs -> StrongFlags -> SolveExecutables
5858
-> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc)
5959
-> Index
@@ -153,14 +153,14 @@ convIPId dr comp idx ipid =
153153

154154
-- | Convert a cabal-install source package index to the simpler,
155155
-- more uniform index format of the solver.
156-
convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
156+
convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint cs]
157157
-> StrongFlags -> SolveExecutables
158158
-> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)]
159159
convSPI' os arch cinfo constraints strfl solveExes =
160160
L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages
161161

162162
-- | Convert a single source package into the solver-specific format.
163-
convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
163+
convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint cs]
164164
-> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo)
165165
convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
166166
let i = I pv InRepo
@@ -172,7 +172,7 @@ convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifi
172172
-- want to keep the condition tree, but simplify much of the test.
173173

174174
-- | Convert a generic package description to a solver-specific 'PInfo'.
175-
convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint]
175+
convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint cs]
176176
-> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription
177177
-> PInfo
178178
convGPD os arch cinfo constraints strfl solveExes pn
@@ -249,7 +249,7 @@ convGPD os arch cinfo constraints strfl solveExes pn
249249
testConditionForComponent :: OS
250250
-> Arch
251251
-> CompilerInfo
252-
-> [LabeledPackageConstraint]
252+
-> [LabeledPackageConstraint cs]
253253
-> (a -> Bool)
254254
-> CondTree ConfVar [Dependency] a
255255
-> Maybe Bool

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

Lines changed: 4 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,6 @@ import Distribution.Solver.Modular.Package
2828
import Distribution.Solver.Modular.Tree
2929
( FailReason(..), POption(..), ConflictingDep(..) )
3030
import Distribution.Solver.Modular.Version
31-
import Distribution.Solver.Types.ConstraintSource
3231
import Distribution.Solver.Types.PackagePath
3332
import Distribution.Solver.Types.Progress
3433
import Distribution.Types.LibraryName
@@ -311,10 +310,10 @@ showFR _ NotExplicit = " (not a user-provided goal nor ment
311310
showFR _ Shadowed = " (shadowed by another installed package with same version)"
312311
showFR _ (Broken u) = " (package is broken, missing dependency " ++ prettyShow u ++ ")"
313312
showFR _ UnknownPackage = " (unknown package)"
314-
showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")"
315-
showFR _ (GlobalConstraintInstalled src) = " (" ++ constraintSource src ++ " requires installed instance)"
316-
showFR _ (GlobalConstraintSource src) = " (" ++ constraintSource src ++ " requires source instance)"
317-
showFR _ (GlobalConstraintFlag src) = " (" ++ constraintSource src ++ " requires opposite flag selection)"
313+
showFR _ (GlobalConstraintVersion vr src) = " (constraint from " ++ show src ++ " requires " ++ prettyShow vr ++ ")"
314+
showFR _ (GlobalConstraintInstalled src) = " (constraint from " ++ show src ++ " requires installed instance)"
315+
showFR _ (GlobalConstraintSource src) = " (constraint from " ++ show src ++ " requires source instance)"
316+
showFR _ (GlobalConstraintFlag src) = " (constraint from " ++ show src ++ " requires opposite flag selection)"
318317
showFR _ ManualFlag = " (manual flag can only be changed explicitly)"
319318
showFR c Backjump = " (backjumping, conflict set: " ++ showConflictSet c ++ ")"
320319
showFR _ MultipleInstances = " (multiple instances)"
@@ -333,9 +332,6 @@ showExposedComponent (ExposedLib LMainLibName) = "library"
333332
showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'"
334333
showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'"
335334

336-
constraintSource :: ConstraintSource -> String
337-
constraintSource src = "constraint from " ++ showConstraintSource src
338-
339335
showConflictingDep :: ConflictingDep -> String
340336
showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =
341337
let DependencyReason qpn' _ _ = dr

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

Lines changed: 17 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -172,10 +172,11 @@ preferPackageStanzaPreferences pcs = go
172172
-- given instance for a P-node. Translates the constraint into a
173173
-- tree-transformer that either leaves the subtree untouched, or replaces it
174174
-- with an appropriate failure node.
175-
processPackageConstraintP :: forall d c. QPN
175+
processPackageConstraintP :: forall d c cs. (Eq cs, Show cs, Typeable cs)
176+
=> QPN
176177
-> ConflictSet
177178
-> I
178-
-> LabeledPackageConstraint
179+
-> LabeledPackageConstraint cs
179180
-> Tree d c
180181
-> Tree d c
181182
processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint scope prop) src) r =
@@ -186,24 +187,25 @@ processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint s
186187
go :: I -> PackageProperty -> Tree d c
187188
go (I v _) (PackagePropertyVersion vr)
188189
| checkVR vr v = r
189-
| otherwise = Fail c (GlobalConstraintVersion vr src)
190+
| otherwise = Fail c (GlobalConstraintVersion vr (SomeSrc src))
190191
go _ PackagePropertyInstalled
191192
| instI i = r
192-
| otherwise = Fail c (GlobalConstraintInstalled src)
193+
| otherwise = Fail c (GlobalConstraintInstalled (SomeSrc src))
193194
go _ PackagePropertySource
194195
| not (instI i) = r
195-
| otherwise = Fail c (GlobalConstraintSource src)
196+
| otherwise = Fail c (GlobalConstraintSource (SomeSrc src))
196197
go _ _ = r
197198

198199
-- | Helper function that tries to enforce a single package constraint on a
199200
-- given flag setting for an F-node. Translates the constraint into a
200201
-- tree-transformer that either leaves the subtree untouched, or replaces it
201202
-- with an appropriate failure node.
202-
processPackageConstraintF :: forall d c. QPN
203+
processPackageConstraintF :: forall d c cs . (Eq cs, Show cs, Typeable cs)
204+
=> QPN
203205
-> Flag
204206
-> ConflictSet
205207
-> Bool
206-
-> LabeledPackageConstraint
208+
-> LabeledPackageConstraint cs
207209
-> Tree d c
208210
-> Tree d c
209211
processPackageConstraintF qpn f c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r =
@@ -216,18 +218,19 @@ processPackageConstraintF qpn f c b' (LabeledPackageConstraint (PackageConstrain
216218
case lookupFlagAssignment f fa of
217219
Nothing -> r
218220
Just b | b == b' -> r
219-
| otherwise -> Fail c (GlobalConstraintFlag src)
221+
| otherwise -> Fail c (GlobalConstraintFlag (SomeSrc src))
220222
go _ = r
221223

222224
-- | Helper function that tries to enforce a single package constraint on a
223225
-- given flag setting for an F-node. Translates the constraint into a
224226
-- tree-transformer that either leaves the subtree untouched, or replaces it
225227
-- with an appropriate failure node.
226-
processPackageConstraintS :: forall d c. QPN
228+
processPackageConstraintS :: forall d c cs. (Typeable cs, Eq cs, Show cs)
229+
=> QPN
227230
-> OptionalStanza
228231
-> ConflictSet
229232
-> Bool
230-
-> LabeledPackageConstraint
233+
-> LabeledPackageConstraint cs
231234
-> Tree d c
232235
-> Tree d c
233236
processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r =
@@ -237,14 +240,15 @@ processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstrain
237240
where
238241
go :: PackageProperty -> Tree d c
239242
go (PackagePropertyStanzas ss) =
240-
if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src)
243+
if not b' && s `elem` ss then Fail c (GlobalConstraintFlag (SomeSrc src))
241244
else r
242245
go _ = r
243246

244247
-- | Traversal that tries to establish various kinds of user constraints. Works
245248
-- by selectively disabling choices that have been ruled out by global user
246249
-- constraints.
247-
enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]
250+
enforcePackageConstraints :: (Typeable cs, Eq cs, Show cs)
251+
=> M.Map PN [LabeledPackageConstraint cs]
248252
-> EndoTreeTrav d c
249253
enforcePackageConstraints pcs = go
250254
where
@@ -291,7 +295,7 @@ enforcePackageConstraints pcs = go
291295
--
292296
-- This function does not enforce any of the constraints, since that is done by
293297
-- 'enforcePackageConstraints'.
294-
enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> EndoTreeTrav d c
298+
enforceManualFlags :: M.Map PN [LabeledPackageConstraint cs] -> EndoTreeTrav d c
295299
enforceManualFlags pcs = go
296300
where
297301
go (FChoiceF qfn@(FN (Q _ pn) fn) rdm gr tr Manual d ts) =

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

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -88,12 +88,13 @@ newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool
8888
-- has been added relatively recently. Cycles are only removed directly
8989
-- before exploration.
9090
--
91-
solve :: SolverConfig -- ^ solver parameters
91+
solve :: (Eq cs, Show cs, Typeable cs)
92+
=> SolverConfig -- ^ solver parameters
9293
-> CompilerInfo
9394
-> Index -- ^ all available packages as an index
9495
-> PkgConfigDb -- ^ available pkg-config pkgs
9596
-> (PN -> PackagePreferences) -- ^ preferences
96-
-> M.Map PN [LabeledPackageConstraint] -- ^ global constraints
97+
-> M.Map PN [LabeledPackageConstraint cs] -- ^ global constraints
9798
-> S.Set PN -- ^ global goals
9899
-> RetryLog Message SolverFailure (Assignment, RevDepMap)
99100
solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =

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

Lines changed: 21 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,13 @@
11
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
2+
{-# LANGUAGE GADTs #-}
3+
24
module Distribution.Solver.Modular.Tree
35
( POption(..)
46
, Tree(..)
57
, TreeF(..)
68
, Weight
79
, FailReason(..)
10+
, SomeSrc(..)
811
, ConflictingDep(..)
912
, ana
1013
, cata
@@ -21,16 +24,16 @@ module Distribution.Solver.Modular.Tree
2124
import Control.Monad hiding (mapM, sequence)
2225
import Data.Foldable
2326
import Data.Traversable
27+
import Type.Reflection (Typeable, eqTypeRep, typeOf, (:~~:) (..))
2428
import Prelude hiding (foldr, mapM, sequence)
2529

2630
import Distribution.Solver.Modular.Dependency
2731
import Distribution.Solver.Modular.Flag
28-
import Distribution.Solver.Modular.Package
2932
import Distribution.Solver.Modular.PSQ (PSQ)
33+
import Distribution.Solver.Modular.Package
3034
import Distribution.Solver.Modular.Version
3135
import Distribution.Solver.Modular.WeightedPSQ (WeightedPSQ)
3236
import qualified Distribution.Solver.Modular.WeightedPSQ as W
33-
import Distribution.Solver.Types.ConstraintSource
3437
import Distribution.Solver.Types.Flag
3538
import Distribution.Solver.Types.PackagePath
3639
import Distribution.Types.PkgconfigVersionRange
@@ -115,10 +118,10 @@ data FailReason = UnsupportedExtension Extension
115118
| Shadowed
116119
| Broken UnitId
117120
| UnknownPackage
118-
| GlobalConstraintVersion VR ConstraintSource
119-
| GlobalConstraintInstalled ConstraintSource
120-
| GlobalConstraintSource ConstraintSource
121-
| GlobalConstraintFlag ConstraintSource
121+
| GlobalConstraintVersion VR SomeSrc
122+
| GlobalConstraintInstalled SomeSrc
123+
| GlobalConstraintSource SomeSrc
124+
| GlobalConstraintFlag SomeSrc
122125
| ManualFlag
123126
| MalformedFlagChoice QFN
124127
| MalformedStanzaChoice QSN
@@ -128,7 +131,18 @@ data FailReason = UnsupportedExtension Extension
128131
| DependenciesNotLinked String
129132
| CyclicDependencies
130133
| UnsupportedSpecVer Ver
131-
deriving (Eq, Show)
134+
deriving (Eq, Show)
135+
136+
data SomeSrc = forall src. (Typeable src, Eq src, Show src) => SomeSrc src
137+
138+
instance Eq SomeSrc where
139+
SomeSrc lhs == SomeSrc rhs =
140+
case eqTypeRep (typeOf lhs) (typeOf rhs) of
141+
Nothing -> False
142+
Just HRefl -> lhs == rhs
143+
144+
instance Show SomeSrc where
145+
showsPrec d (SomeSrc lhs) = showsPrec d lhs
132146

133147
-- | Information about a dependency involved in a conflict, for error messages.
134148
data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI

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

Lines changed: 0 additions & 78 deletions
This file was deleted.

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -26,12 +26,12 @@ import Distribution.System ( Platform )
2626
-- solving the package dependency problem and we want to make it easy to swap
2727
-- in alternatives.
2828
--
29-
type DependencyResolver loc = Platform
29+
type DependencyResolver loc cs = Platform
3030
-> CompilerInfo
3131
-> InstalledPackageIndex
3232
-> PackageIndex (SourcePackage loc)
3333
-> PkgConfigDb
3434
-> (PackageName -> PackagePreferences)
35-
-> [LabeledPackageConstraint]
35+
-> [LabeledPackageConstraint cs]
3636
-> Set PackageName
3737
-> Progress String String [ResolverPackage loc]

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

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -3,12 +3,11 @@ module Distribution.Solver.Types.LabeledPackageConstraint
33
, unlabelPackageConstraint
44
) where
55

6-
import Distribution.Solver.Types.ConstraintSource
76
import Distribution.Solver.Types.PackageConstraint
87

98
-- | 'PackageConstraint' labeled with its source.
10-
data LabeledPackageConstraint
11-
= LabeledPackageConstraint PackageConstraint ConstraintSource
9+
data LabeledPackageConstraint cs
10+
= LabeledPackageConstraint PackageConstraint cs
1211

13-
unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint
12+
unlabelPackageConstraint :: LabeledPackageConstraint cs -> PackageConstraint
1413
unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc

0 commit comments

Comments
 (0)