Commit 6efb5e23 authored by kristenk's avatar kristenk Committed by Mikhail Glushenkov
Browse files

Solver: Enforce dependencies on libraries (fixes #779).

This commit generalizes the fix for issue #4781
(e86f8389) by tracking dependencies on
components instead of dependencies on executables.  That means that the solver
always checks whether a package contains a library before using it to satisfy a
build-depends dependency.  If a version of a package doesn't contain a library,
the solver can try other versions.  Associating each dependency with a component
also moves towards the design for component-based dependency solving described
in issue #4087.
parent 1743a4d8
...@@ -72,7 +72,7 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs ...@@ -72,7 +72,7 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
-- the later addition will have better dependency information. -- the later addition will have better dependency information.
go g o ((Stanza sn@(SN qpn _) t) : ngs) = go g o ((Stanza sn@(SN qpn _) t) : ngs) =
go g (StanzaGoal sn t (flagGR qpn) : o) ngs go g (StanzaGoal sn t (flagGR qpn) : o) ngs
go g o ((Simple (LDep dr (Dep _ qpn _)) c) : ngs) go g o ((Simple (LDep dr (Dep (PkgComponent qpn _) _)) c) : ngs)
| qpn == qpn' = | qpn == qpn' =
-- We currently only add a self-dependency to the graph if it is -- We currently only add a self-dependency to the graph if it is
-- between a package and its setup script. The edge creates a cycle -- between a package and its setup script. The edge creates a cycle
......
...@@ -16,6 +16,8 @@ module Distribution.Solver.Modular.Dependency ( ...@@ -16,6 +16,8 @@ module Distribution.Solver.Modular.Dependency (
, FlaggedDep(..) , FlaggedDep(..)
, LDep(..) , LDep(..)
, Dep(..) , Dep(..)
, PkgComponent(..)
, ExposedComponent(..)
, DependencyReason(..) , DependencyReason(..)
, showDependencyReason , showDependencyReason
, flattenFlaggedDeps , flattenFlaggedDeps
...@@ -112,12 +114,22 @@ data LDep qpn = LDep (DependencyReason qpn) (Dep qpn) ...@@ -112,12 +114,22 @@ data LDep qpn = LDep (DependencyReason qpn) (Dep qpn)
-- | A dependency (constraint) associates a package name with a constrained -- | A dependency (constraint) associates a package name with a constrained
-- instance. It can also represent other types of dependencies, such as -- instance. It can also represent other types of dependencies, such as
-- dependencies on language extensions. -- dependencies on language extensions.
data Dep qpn = Dep (Maybe UnqualComponentName) qpn CI -- ^ dependency on a package (possibly for executable) data Dep qpn = Dep (PkgComponent qpn) CI -- ^ dependency on a package component
| Ext Extension -- ^ dependency on a language extension | Ext Extension -- ^ dependency on a language extension
| Lang Language -- ^ dependency on a language version | Lang Language -- ^ dependency on a language version
| Pkg PkgconfigName VR -- ^ dependency on a pkg-config package | Pkg PkgconfigName VR -- ^ dependency on a pkg-config package
deriving Functor deriving Functor
-- | An exposed component within a package. This type is used to represent
-- build-depends and build-tool-depends dependencies.
data PkgComponent qpn = PkgComponent qpn ExposedComponent
deriving (Eq, Ord, Functor, Show)
-- | A component that can be depended upon by another package, i.e., a library
-- or an executable.
data ExposedComponent = ExposedLib | ExposedExe UnqualComponentName
deriving (Eq, Ord, Show)
-- | The reason that a dependency is active. It identifies the package and any -- | The reason that a dependency is active. It identifies the package and any
-- flag and stanza choices that introduced the dependency. It contains -- flag and stanza choices that introduced the dependency. It contains
-- everything needed for creating ConflictSets or describing conflicts in solver -- everything needed for creating ConflictSets or describing conflicts in solver
...@@ -169,7 +181,7 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go ...@@ -169,7 +181,7 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go
-- Suppose package B has a setup dependency on package A. -- Suppose package B has a setup dependency on package A.
-- This will be recorded as something like -- This will be recorded as something like
-- --
-- > LDep (DependencyReason "B") (Dep Nothing "A" (Constrained AnyVersion)) -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" ExposedLib) (Constrained AnyVersion))
-- --
-- Observe that when we qualify this dependency, we need to turn that -- Observe that when we qualify this dependency, we need to turn that
-- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier
...@@ -181,11 +193,12 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go ...@@ -181,11 +193,12 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go
goD (Ext ext) _ = Ext ext goD (Ext ext) _ = Ext ext
goD (Lang lang) _ = Lang lang goD (Lang lang) _ = Lang lang
goD (Pkg pkn vr) _ = Pkg pkn vr goD (Pkg pkn vr) _ = Pkg pkn vr
goD (Dep mExe dep ci) comp goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ =
| isJust mExe = Dep mExe (Q (PackagePath ns (QualExe pn dep)) dep) ci Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci
| qBase dep = Dep mExe (Q (PackagePath ns (QualBase pn )) dep) ci goD (Dep dep@(PkgComponent qpn ExposedLib) ci) comp
| qSetup comp = Dep mExe (Q (PackagePath ns (QualSetup pn )) dep) ci | qBase qpn = Dep (Q (PackagePath ns (QualBase pn)) <$> dep) ci
| otherwise = Dep mExe (Q (PackagePath ns inheritedQ ) dep) ci | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci
| otherwise = Dep (Q (PackagePath ns inheritedQ ) <$> dep) ci
-- If P has a setup dependency on Q, and Q has a regular dependency on R, then -- If P has a setup dependency on Q, and Q has a regular dependency on R, then
-- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup
......
...@@ -13,7 +13,6 @@ import Distribution.Solver.Modular.Dependency ...@@ -13,7 +13,6 @@ import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Tree import Distribution.Solver.Modular.Tree
import Distribution.Types.UnqualComponentName
-- | An index contains information about package instances. This is a nested -- | An index contains information about package instances. This is a nested
-- dictionary. Package names are mapped to instances, which in turn is mapped -- dictionary. Package names are mapped to instances, which in turn is mapped
...@@ -21,12 +20,12 @@ import Distribution.Types.UnqualComponentName ...@@ -21,12 +20,12 @@ import Distribution.Types.UnqualComponentName
type Index = Map PN (Map I PInfo) type Index = Map PN (Map I PInfo)
-- | Info associated with a package instance. -- | Info associated with a package instance.
-- Currently, dependencies, executable names, flags and failure reasons. -- Currently, dependencies, component names, flags and failure reasons.
-- Packages that have a failure reason recorded for them are disabled -- Packages that have a failure reason recorded for them are disabled
-- globally, for reasons external to the solver. We currently use this -- globally, for reasons external to the solver. We currently use this
-- for shadowing which essentially is a GHC limitation, and for -- for shadowing which essentially is a GHC limitation, and for
-- installed packages that are broken. -- installed packages that are broken.
data PInfo = PInfo (FlaggedDeps PN) [UnqualComponentName] FlagInfo (Maybe FailReason) data PInfo = PInfo (FlaggedDeps PN) [ExposedComponent] FlagInfo (Maybe FailReason)
mkIndex :: [(PN, I, PInfo)] -> Index mkIndex :: [(PN, I, PInfo)] -> Index
mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))
...@@ -40,9 +39,9 @@ defaultQualifyOptions idx = QO { ...@@ -40,9 +39,9 @@ defaultQualifyOptions idx = QO {
| -- Find all versions of base .. | -- Find all versions of base ..
Just is <- [M.lookup base idx] Just is <- [M.lookup base idx]
-- .. which are installed .. -- .. which are installed ..
, (I _ver (Inst _), PInfo deps _exes _flagNfo _fr) <- M.toList is , (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is
-- .. and flatten all their dependencies .. -- .. and flatten all their dependencies ..
, (LDep _ (Dep _is_exe dep _ci), _comp) <- flattenFlaggedDeps deps , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps
] ]
, qoSetupIndependent = True , qoSetupIndependent = True
} }
......
...@@ -72,7 +72,8 @@ convIPI' (ShadowPkgs sip) idx = ...@@ -72,7 +72,8 @@ convIPI' (ShadowPkgs sip) idx =
where where
-- shadowing is recorded in the package info -- shadowing is recorded in the package info
shadow (pn, i, PInfo fdeps exes fds _) | sip = (pn, i, PInfo fdeps exes fds (Just Shadowed)) shadow (pn, i, PInfo fdeps comps fds _)
| sip = (pn, i, PInfo fdeps comps fds (Just Shadowed))
shadow x = x shadow x = x
-- | Extract/recover the the package ID from an installed package info, and convert it to a solver's I. -- | Extract/recover the the package ID from an installed package info, and convert it to a solver's I.
...@@ -87,7 +88,7 @@ convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) ...@@ -87,7 +88,7 @@ convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo)
convIP idx ipi = convIP idx ipi =
case mapM (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of case mapM (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of
Nothing -> (pn, i, PInfo [] [] M.empty (Just Broken)) Nothing -> (pn, i, PInfo [] [] M.empty (Just Broken))
Just fds -> (pn, i, PInfo fds [] M.empty Nothing) Just fds -> (pn, i, PInfo fds [ExposedLib] M.empty Nothing)
where where
(pn, i) = convId ipi (pn, i) = convId ipi
-- 'sourceLibName' is unreliable, but for now we only really use this for -- 'sourceLibName' is unreliable, but for now we only really use this for
...@@ -133,7 +134,7 @@ convIPId dr comp idx ipid = ...@@ -133,7 +134,7 @@ convIPId dr comp idx ipid =
case SI.lookupUnitId idx ipid of case SI.lookupUnitId idx ipid of
Nothing -> Nothing Nothing -> Nothing
Just ipi -> let (pn, i) = convId ipi Just ipi -> let (pn, i) = convId ipi
in Just (D.Simple (LDep dr (Dep Nothing pn (Fixed i))) comp) in Just (D.Simple (LDep dr (Dep (PkgComponent pn ExposedLib) (Fixed i))) comp)
-- NB: something we pick up from the -- NB: something we pick up from the
-- InstalledPackageIndex is NEVER an executable -- InstalledPackageIndex is NEVER an executable
...@@ -223,7 +224,7 @@ convGPD os arch cinfo strfl solveExes pn ...@@ -223,7 +224,7 @@ convGPD os arch cinfo strfl solveExes pn
fr | reqSpecVer > maxSpecVer = Just (UnsupportedSpecVer reqSpecVer) fr | reqSpecVer > maxSpecVer = Just (UnsupportedSpecVer reqSpecVer)
| otherwise = Nothing | otherwise = Nothing
in in
PInfo flagged_deps (L.map fst exes) fds fr PInfo flagged_deps (L.map (ExposedExe . fst) exes ++ [ExposedLib | isJust mlib]) fds fr
-- | Create a flagged dependency tree from a list @fds@ of flagged -- | Create a flagged dependency tree from a list @fds@ of flagged
-- dependencies, using @f@ to form the tree node (@f@ will be -- dependencies, using @f@ to form the tree node (@f@ will be
...@@ -289,7 +290,7 @@ convCondTree flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes@(Solv ...@@ -289,7 +290,7 @@ convCondTree flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes@(Solv
bi = getInfo info bi = getInfo info
data SimpleFlaggedDepKey qpn = data SimpleFlaggedDepKey qpn =
SimpleFlaggedDepKey (Maybe UnqualComponentName) qpn Component SimpleFlaggedDepKey (PkgComponent qpn) Component
deriving (Eq, Ord) deriving (Eq, Ord)
data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR
...@@ -320,9 +321,9 @@ mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerge ...@@ -320,9 +321,9 @@ mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerge
=> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) => (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn)
-> FlaggedDep qpn -> FlaggedDep qpn
-> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) -> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn)
f (merged', unmerged') (D.Simple (LDep dr (Dep mExe qpn (Constrained vr))) comp) = f (merged', unmerged') (D.Simple (LDep dr (Dep dep (Constrained vr))) comp) =
( M.insertWith mergeValues ( M.insertWith mergeValues
(SimpleFlaggedDepKey mExe qpn comp) (SimpleFlaggedDepKey dep comp)
(SimpleFlaggedDepValue dr vr) (SimpleFlaggedDepValue dr vr)
merged' merged'
, unmerged') , unmerged')
...@@ -337,8 +338,8 @@ mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerge ...@@ -337,8 +338,8 @@ mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerge
toFlaggedDep :: SimpleFlaggedDepKey qpn toFlaggedDep :: SimpleFlaggedDepKey qpn
-> SimpleFlaggedDepValue qpn -> SimpleFlaggedDepValue qpn
-> FlaggedDep qpn -> FlaggedDep qpn
toFlaggedDep (SimpleFlaggedDepKey mExe qpn comp) (SimpleFlaggedDepValue dr vr) = toFlaggedDep (SimpleFlaggedDepKey dep comp) (SimpleFlaggedDepValue dr vr) =
D.Simple (LDep dr (Dep mExe qpn (Constrained vr))) comp D.Simple (LDep dr (Dep dep (Constrained vr))) comp
-- | Branch interpreter. Mutually recursive with 'convCondTree'. -- | Branch interpreter. Mutually recursive with 'convCondTree'.
-- --
...@@ -463,11 +464,10 @@ convBranch flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBr ...@@ -463,11 +464,10 @@ convBranch flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBr
-- Union the DependencyReasons, because the extracted dependency can be -- Union the DependencyReasons, because the extracted dependency can be
-- avoided by removing the dependency from either side of the -- avoided by removing the dependency from either side of the
-- conditional. -- conditional.
[ D.Simple (LDep (unionDRs vs1 vs2) (Dep mExe1 pn1 (Constrained $ vr1 .||. vr2))) comp [ D.Simple (LDep (unionDRs vs1 vs2) (Dep dep1 (Constrained $ vr1 .||. vr2))) comp
| D.Simple (LDep vs1 (Dep mExe1 pn1 (Constrained vr1))) _ <- ps | D.Simple (LDep vs1 (Dep dep1 (Constrained vr1))) _ <- ps
, D.Simple (LDep vs2 (Dep mExe2 pn2 (Constrained vr2))) _ <- ps' , D.Simple (LDep vs2 (Dep dep2 (Constrained vr2))) _ <- ps'
, pn1 == pn2 , dep1 == dep2
, mExe1 == mExe2
] ]
-- | Merge DependencyReasons by unioning their variables. -- | Merge DependencyReasons by unioning their variables.
...@@ -477,11 +477,11 @@ unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) = ...@@ -477,11 +477,11 @@ unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) =
-- | Convert a Cabal dependency on a library to a solver-specific dependency. -- | Convert a Cabal dependency on a library to a solver-specific dependency.
convLibDep :: DependencyReason PN -> Dependency -> LDep PN convLibDep :: DependencyReason PN -> Dependency -> LDep PN
convLibDep dr (Dependency pn vr) = LDep dr $ Dep Nothing pn (Constrained vr) convLibDep dr (Dependency pn vr) = LDep dr $ Dep (PkgComponent pn ExposedLib) (Constrained vr)
-- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency. -- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency.
convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN
convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (Just exe) pn (Constrained vr) convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (PkgComponent pn (ExposedExe exe)) (Constrained vr)
-- | Convert setup dependencies -- | Convert setup dependencies
convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN
......
...@@ -245,7 +245,7 @@ linkDeps target = \deps -> do ...@@ -245,7 +245,7 @@ linkDeps target = \deps -> do
go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState () go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ()
go1 dep rdep = case (dep, rdep) of go1 dep rdep = case (dep, rdep) of
(Simple (LDep dr1 (Dep _ qpn _)) _, ~(Simple (LDep dr2 (Dep _ qpn' _)) _)) -> do (Simple (LDep dr1 (Dep (PkgComponent qpn _) _)) _, ~(Simple (LDep dr2 (Dep (PkgComponent qpn' _) _)) _)) -> do
vs <- get vs <- get
let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs
lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs
......
...@@ -109,8 +109,8 @@ showFR _ (UnsupportedLanguage lang) = " (conflict: requires " ++ display l ...@@ -109,8 +109,8 @@ showFR _ (UnsupportedLanguage lang) = " (conflict: requires " ++ display l
showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ display pn ++ display vr ++ ", not found in the pkg-config database)" showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ display pn ++ display vr ++ ", not found in the pkg-config database)"
showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")" showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")"
showFR _ (ConflictingConstraints d1 d2) = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")" showFR _ (ConflictingConstraints d1 d2) = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")"
showFR _ (NewPackageIsMissingRequiredExe exe dr) = " (does not contain executable " ++ unUnqualComponentName exe ++ ", which is required by " ++ showDependencyReason dr ++ ")" showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")"
showFR _ (PackageRequiresMissingExe qpn exe) = " (requires executable " ++ unUnqualComponentName exe ++ " from " ++ showQPN qpn ++ ", but the executable does not exist)" showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)"
showFR _ CannotInstall = " (only already installed instances can be used)" showFR _ CannotInstall = " (only already installed instances can be used)"
showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)"
showFR _ Shadowed = " (shadowed by another installed package with same version)" showFR _ Shadowed = " (shadowed by another installed package with same version)"
...@@ -132,17 +132,21 @@ showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CH ...@@ -132,17 +132,21 @@ showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CH
showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")" showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"
showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"
showExposedComponent :: ExposedComponent -> String
showExposedComponent ExposedLib = "library"
showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'"
constraintSource :: ConstraintSource -> String constraintSource :: ConstraintSource -> String
constraintSource src = "constraint from " ++ showConstraintSource src constraintSource src = "constraint from " ++ showConstraintSource src
showConflictingDep :: ConflictingDep -> String showConflictingDep :: ConflictingDep -> String
showConflictingDep (ConflictingDep dr mExe qpn ci) = showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =
let DependencyReason qpn' _ _ = dr let DependencyReason qpn' _ _ = dr
exeStr = case mExe of componentStr = case comp of
Just exe -> " (exe " ++ unUnqualComponentName exe ++ ")" ExposedExe exe -> " (exe " ++ unUnqualComponentName exe ++ ")"
Nothing -> "" ExposedLib -> ""
in case ci of in case ci of
Fixed i -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++ Fixed i -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++
showQPN qpn ++ exeStr ++ "==" ++ showI i showQPN qpn ++ componentStr ++ "==" ++ showI i
Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++ Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++
exeStr ++ showVR vr componentStr ++ showVR vr
...@@ -31,7 +31,6 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W ...@@ -31,7 +31,6 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W
import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.Flag import Distribution.Solver.Types.Flag
import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PackagePath
import Distribution.Types.UnqualComponentName
import Language.Haskell.Extension (Extension, Language) import Language.Haskell.Extension (Extension, Language)
type Weight = Double type Weight = Double
...@@ -101,8 +100,8 @@ data FailReason = UnsupportedExtension Extension ...@@ -101,8 +100,8 @@ data FailReason = UnsupportedExtension Extension
| MissingPkgconfigPackage PkgconfigName VR | MissingPkgconfigPackage PkgconfigName VR
| NewPackageDoesNotMatchExistingConstraint ConflictingDep | NewPackageDoesNotMatchExistingConstraint ConflictingDep
| ConflictingConstraints ConflictingDep ConflictingDep | ConflictingConstraints ConflictingDep ConflictingDep
| NewPackageIsMissingRequiredExe UnqualComponentName (DependencyReason QPN) | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN)
| PackageRequiresMissingExe QPN UnqualComponentName | PackageRequiresMissingComponent QPN ExposedComponent
| CannotInstall | CannotInstall
| CannotReinstall | CannotReinstall
| Shadowed | Shadowed
...@@ -123,7 +122,7 @@ data FailReason = UnsupportedExtension Extension ...@@ -123,7 +122,7 @@ data FailReason = UnsupportedExtension Extension
deriving (Eq, Show) deriving (Eq, Show)
-- | Information about a dependency involved in a conflict, for error messages. -- | Information about a dependency involved in a conflict, for error messages.
data ConflictingDep = ConflictingDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI
deriving (Eq, Show) deriving (Eq, Show)
-- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' -- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c'
......
...@@ -37,7 +37,6 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W ...@@ -37,7 +37,6 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W
import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)
import Distribution.Types.UnqualComponentName
#ifdef DEBUG_CONFLICT_SETS #ifdef DEBUG_CONFLICT_SETS
import GHC.Stack (CallStack) import GHC.Stack (CallStack)
...@@ -108,13 +107,13 @@ data ValidateState = VS { ...@@ -108,13 +107,13 @@ data ValidateState = VS {
pa :: PreAssignment, pa :: PreAssignment,
-- Map from package name to the executables that are provided by the chosen -- Map from package name to the components that are provided by the chosen
-- instance of that package. -- instance of that package.
availableExes :: Map QPN [UnqualComponentName], availableComponents :: Map QPN [ExposedComponent],
-- Map from package name to the executables that are required from that -- Map from package name to the components that are required from that
-- package. -- package.
requiredExes :: Map QPN ExeDeps, requiredComponents :: Map QPN ComponentDependencyReasons,
qualifyOptions :: QualifyOptions qualifyOptions :: QualifyOptions
} }
...@@ -133,12 +132,12 @@ data PreAssignment = PA PPreAssignment FAssignment SAssignment ...@@ -133,12 +132,12 @@ data PreAssignment = PA PPreAssignment FAssignment SAssignment
-- are associated with MergedPkgDeps. -- are associated with MergedPkgDeps.
type PPreAssignment = Map QPN MergedPkgDep type PPreAssignment = Map QPN MergedPkgDep
-- | A dependency on a package, including its DependencyReason. -- | A dependency on a component, including its DependencyReason.
data PkgDep = PkgDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI data PkgDep = PkgDep (DependencyReason QPN) (PkgComponent QPN) CI
-- | Map from executable name to one of the reasons that the executable is -- | Map from component name to one of the reasons that the component is
-- required. -- required.
type ExeDeps = Map UnqualComponentName (DependencyReason QPN) type ComponentDependencyReasons = Map ExposedComponent (DependencyReason QPN)
-- | MergedPkgDep records constraints about the instances that can still be -- | MergedPkgDep records constraints about the instances that can still be
-- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a -- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a
...@@ -146,15 +145,15 @@ type ExeDeps = Map UnqualComponentName (DependencyReason QPN) ...@@ -146,15 +145,15 @@ type ExeDeps = Map UnqualComponentName (DependencyReason QPN)
-- them. It also records whether a package is a build-tool dependency, for each -- them. It also records whether a package is a build-tool dependency, for each
-- reason that it was introduced. -- reason that it was introduced.
-- --
-- It is important to store the executable name with the version constraint, for -- It is important to store the component name with the version constraint, for
-- error messages, because whether something is a build-tool dependency affects -- error messages, because whether something is a build-tool dependency affects
-- its qualifier, which affects which constraint is applied. -- its qualifier, which affects which constraint is applied.
data MergedPkgDep = data MergedPkgDep =
MergedDepFixed (Maybe UnqualComponentName) (DependencyReason QPN) I MergedDepFixed ExposedComponent (DependencyReason QPN) I
| MergedDepConstrained [VROrigin] | MergedDepConstrained [VROrigin]
-- | Version ranges paired with origins. -- | Version ranges paired with origins.
type VROrigin = (VR, Maybe UnqualComponentName, DependencyReason QPN) type VROrigin = (VR, ExposedComponent, DependencyReason QPN)
-- | The information needed to create a 'Fail' node. -- | The information needed to create a 'Fail' node.
type Conflict = (ConflictSet, FailReason) type Conflict = (ConflictSet, FailReason)
...@@ -204,11 +203,11 @@ validate = cata go ...@@ -204,11 +203,11 @@ validate = cata go
pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs
idx <- asks index -- obtain the index idx <- asks index -- obtain the index
svd <- asks saved -- obtain saved dependencies svd <- asks saved -- obtain saved dependencies
aExes <- asks availableExes aComps <- asks availableComponents
rExes <- asks requiredExes rComps <- asks requiredComponents
qo <- asks qualifyOptions qo <- asks qualifyOptions
-- obtain dependencies and index-dictated exclusions introduced by the choice -- obtain dependencies and index-dictated exclusions introduced by the choice
let (PInfo deps exes _ mfr) = idx ! pn ! i let (PInfo deps comps _ mfr) = idx ! pn ! i
-- qualify the deps in the current scope -- qualify the deps in the current scope
let qdeps = qualifyDeps qo qpn deps let qdeps = qualifyDeps qo qpn deps
-- the new active constraints are given by the instance we have chosen, -- the new active constraints are given by the instance we have chosen,
...@@ -223,20 +222,20 @@ validate = cata go ...@@ -223,20 +222,20 @@ validate = cata go
Just fr -> -- The index marks this as an invalid choice. We can stop. Just fr -> -- The index marks this as an invalid choice. We can stop.
return (Fail (varToConflictSet (P qpn)) fr) return (Fail (varToConflictSet (P qpn)) fr)
Nothing -> Nothing ->
let newDeps :: Either Conflict (PPreAssignment, Map QPN ExeDeps) let newDeps :: Either Conflict (PPreAssignment, Map QPN ComponentDependencyReasons)
newDeps = do newDeps = do
nppa <- mnppa nppa <- mnppa
rExes' <- extendRequiredExes aExes rExes newactives rComps' <- extendRequiredComponents aComps rComps newactives
checkExesInNewPackage rExes qpn exes checkComponentsInNewPackage rComps qpn comps
return (nppa, rExes') return (nppa, rComps')
in case newDeps of in case newDeps of
Left (c, fr) -> -- We have an inconsistency. We can stop. Left (c, fr) -> -- We have an inconsistency. We can stop.
return (Fail c fr) return (Fail c fr)
Right (nppa, rExes') -> -- We have an updated partial assignment for the recursive validation. Right (nppa, rComps') -> -- We have an updated partial assignment for the recursive validation.
local (\ s -> s { pa = PA nppa pfa psa local (\ s -> s { pa = PA nppa pfa psa
, saved = nsvd , saved = nsvd
, availableExes = M.insert qpn exes aExes , availableComponents = M.insert qpn comps aComps
, requiredExes = rExes' , requiredComponents = rComps'
}) r }) r
-- What to do for flag nodes ... -- What to do for flag nodes ...
...@@ -247,8 +246,8 @@ validate = cata go ...@@ -247,8 +246,8 @@ validate = cata go
langSupported <- asks supportedLang -- obtain the supported languages langSupported <- asks supportedLang -- obtain the supported languages
pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs
svd <- asks saved -- obtain saved dependencies svd <- asks saved -- obtain saved dependencies
aExes <- asks availableExes aComps <- asks availableComponents
rExes <- asks requiredExes rComps <- asks requiredComponents
-- Note that there should be saved dependencies for the package in question, -- Note that there should be saved dependencies for the package in question,
-- because while building, we do not choose flags before we see the packages -- because while building, we do not choose flags before we see the packages
-- that define them. -- that define them.
...@@ -261,13 +260,13 @@ validate = cata go ...@@ -261,13 +260,13 @@ validate = cata go
-- We now try to get the new active dependencies we might learn about because -- We now try to get the new active dependencies we might learn about because
-- we have chosen a new flag. -- we have chosen a new flag.
let newactives = extractNewDeps (F qfn) b npfa psa qdeps let newactives = extractNewDeps (F qfn) b npfa psa qdeps
mNewRequiredExes = extendRequiredExes aExes rExes newactives mNewRequiredComps = extendRequiredComponents aComps rComps newactives
-- As in the package case, we try to extend the partial assignment. -- As in the package case, we try to extend the partial assignment.
let mnppa = extend extSupported langSupported pkgPresent newactives ppa let mnppa = extend extSupported langSupported pkgPresent newactives ppa
case liftM2 (,) mnppa mNewRequiredExes of