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

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
-- the later addition will have better dependency information.
go g o ((Stanza sn@(SN qpn _) t) : 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' =
-- 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
......
......@@ -16,6 +16,8 @@ module Distribution.Solver.Modular.Dependency (
, FlaggedDep(..)
, LDep(..)
, Dep(..)
, PkgComponent(..)
, ExposedComponent(..)
, DependencyReason(..)
, showDependencyReason
, flattenFlaggedDeps
......@@ -112,12 +114,22 @@ data LDep qpn = LDep (DependencyReason qpn) (Dep qpn)
-- | A dependency (constraint) associates a package name with a constrained
-- instance. It can also represent other types of dependencies, such as
-- 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
| Lang Language -- ^ dependency on a language version
| Pkg PkgconfigName VR -- ^ dependency on a pkg-config package
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
-- flag and stanza choices that introduced the dependency. It contains
-- everything needed for creating ConflictSets or describing conflicts in solver
......@@ -169,7 +181,7 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go
-- Suppose package B has a setup dependency on package A.
-- 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
-- @"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
goD (Ext ext) _ = Ext ext
goD (Lang lang) _ = Lang lang
goD (Pkg pkn vr) _ = Pkg pkn vr
goD (Dep mExe dep ci) comp
| isJust mExe = Dep mExe (Q (PackagePath ns (QualExe pn dep)) dep) ci
| qBase dep = Dep mExe (Q (PackagePath ns (QualBase pn )) dep) ci
| qSetup comp = Dep mExe (Q (PackagePath ns (QualSetup pn )) dep) ci
| otherwise = Dep mExe (Q (PackagePath ns inheritedQ ) dep) ci
goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ =
Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci
goD (Dep dep@(PkgComponent qpn ExposedLib) ci) comp
| qBase qpn = Dep (Q (PackagePath ns (QualBase pn)) <$> 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
-- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup
......
......@@ -13,7 +13,6 @@ import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Tree
import Distribution.Types.UnqualComponentName
-- | An index contains information about package instances. This is a nested
-- dictionary. Package names are mapped to instances, which in turn is mapped
......@@ -21,12 +20,12 @@ import Distribution.Types.UnqualComponentName
type Index = Map PN (Map I PInfo)
-- | 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
-- globally, for reasons external to the solver. We currently use this
-- for shadowing which essentially is a GHC limitation, and for
-- 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 xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))
......@@ -40,9 +39,9 @@ defaultQualifyOptions idx = QO {
| -- Find all versions of base ..
Just is <- [M.lookup base idx]
-- .. 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 ..
, (LDep _ (Dep _is_exe dep _ci), _comp) <- flattenFlaggedDeps deps
, (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps
]
, qoSetupIndependent = True
}
......
......@@ -72,7 +72,8 @@ convIPI' (ShadowPkgs sip) idx =
where
-- 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
-- | 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)
convIP idx ipi =
case mapM (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of
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
(pn, i) = convId ipi
-- 'sourceLibName' is unreliable, but for now we only really use this for
......@@ -133,7 +134,7 @@ convIPId dr comp idx ipid =
case SI.lookupUnitId idx ipid of
Nothing -> Nothing
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
-- InstalledPackageIndex is NEVER an executable
......@@ -223,7 +224,7 @@ convGPD os arch cinfo strfl solveExes pn
fr | reqSpecVer > maxSpecVer = Just (UnsupportedSpecVer reqSpecVer)
| otherwise = Nothing
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
-- 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
bi = getInfo info
data SimpleFlaggedDepKey qpn =
SimpleFlaggedDepKey (Maybe UnqualComponentName) qpn Component
SimpleFlaggedDepKey (PkgComponent qpn) Component
deriving (Eq, Ord)
data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR
......@@ -320,9 +321,9 @@ mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerge
=> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn)
-> FlaggedDep 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
(SimpleFlaggedDepKey mExe qpn comp)
(SimpleFlaggedDepKey dep comp)
(SimpleFlaggedDepValue dr vr)
merged'
, unmerged')
......@@ -337,8 +338,8 @@ mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerge
toFlaggedDep :: SimpleFlaggedDepKey qpn
-> SimpleFlaggedDepValue qpn
-> FlaggedDep qpn
toFlaggedDep (SimpleFlaggedDepKey mExe qpn comp) (SimpleFlaggedDepValue dr vr) =
D.Simple (LDep dr (Dep mExe qpn (Constrained vr))) comp
toFlaggedDep (SimpleFlaggedDepKey dep comp) (SimpleFlaggedDepValue dr vr) =
D.Simple (LDep dr (Dep dep (Constrained vr))) comp
-- | Branch interpreter. Mutually recursive with 'convCondTree'.
--
......@@ -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
-- avoided by removing the dependency from either side of the
-- conditional.
[ D.Simple (LDep (unionDRs vs1 vs2) (Dep mExe1 pn1 (Constrained $ vr1 .||. vr2))) comp
| D.Simple (LDep vs1 (Dep mExe1 pn1 (Constrained vr1))) _ <- ps
, D.Simple (LDep vs2 (Dep mExe2 pn2 (Constrained vr2))) _ <- ps'
, pn1 == pn2
, mExe1 == mExe2
[ D.Simple (LDep (unionDRs vs1 vs2) (Dep dep1 (Constrained $ vr1 .||. vr2))) comp
| D.Simple (LDep vs1 (Dep dep1 (Constrained vr1))) _ <- ps
, D.Simple (LDep vs2 (Dep dep2 (Constrained vr2))) _ <- ps'
, dep1 == dep2
]
-- | Merge DependencyReasons by unioning their variables.
......@@ -477,11 +477,11 @@ unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) =
-- | Convert a Cabal dependency on a library to a solver-specific dependency.
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.
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
convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN
......
......@@ -245,7 +245,7 @@ linkDeps target = \deps -> do
go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ()
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
let 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
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 _ (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 _ (PackageRequiresMissingExe qpn exe) = " (requires executable " ++ unUnqualComponentName exe ++ " from " ++ showQPN qpn ++ ", but the executable does not exist)"
showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")"
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 _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)"
showFR _ Shadowed = " (shadowed by another installed package with same version)"
......@@ -132,17 +132,21 @@ showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CH
showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"
showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"
showExposedComponent :: ExposedComponent -> String
showExposedComponent ExposedLib = "library"
showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'"
constraintSource :: ConstraintSource -> String
constraintSource src = "constraint from " ++ showConstraintSource src
showConflictingDep :: ConflictingDep -> String
showConflictingDep (ConflictingDep dr mExe qpn ci) =
showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =
let DependencyReason qpn' _ _ = dr
exeStr = case mExe of
Just exe -> " (exe " ++ unUnqualComponentName exe ++ ")"
Nothing -> ""
componentStr = case comp of
ExposedExe exe -> " (exe " ++ unUnqualComponentName exe ++ ")"
ExposedLib -> ""
in case ci of
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 ++
exeStr ++ showVR vr
componentStr ++ showVR vr
......@@ -31,7 +31,6 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.Flag
import Distribution.Solver.Types.PackagePath
import Distribution.Types.UnqualComponentName
import Language.Haskell.Extension (Extension, Language)
type Weight = Double
......@@ -101,8 +100,8 @@ data FailReason = UnsupportedExtension Extension
| MissingPkgconfigPackage PkgconfigName VR
| NewPackageDoesNotMatchExistingConstraint ConflictingDep
| ConflictingConstraints ConflictingDep ConflictingDep
| NewPackageIsMissingRequiredExe UnqualComponentName (DependencyReason QPN)
| PackageRequiresMissingExe QPN UnqualComponentName
| NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN)
| PackageRequiresMissingComponent QPN ExposedComponent
| CannotInstall
| CannotReinstall
| Shadowed
......@@ -123,7 +122,7 @@ data FailReason = UnsupportedExtension Extension
deriving (Eq, Show)
-- | 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)
-- | 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
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)
import Distribution.Types.UnqualComponentName
#ifdef DEBUG_CONFLICT_SETS
import GHC.Stack (CallStack)
......@@ -108,13 +107,13 @@ data ValidateState = VS {
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.
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.
requiredExes :: Map QPN ExeDeps,
requiredComponents :: Map QPN ComponentDependencyReasons,
qualifyOptions :: QualifyOptions
}
......@@ -133,12 +132,12 @@ data PreAssignment = PA PPreAssignment FAssignment SAssignment
-- are associated with MergedPkgDeps.
type PPreAssignment = Map QPN MergedPkgDep
-- | A dependency on a package, including its DependencyReason.
data PkgDep = PkgDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI
-- | A dependency on a component, including its DependencyReason.
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.
type ExeDeps = Map UnqualComponentName (DependencyReason QPN)
type ComponentDependencyReasons = Map ExposedComponent (DependencyReason QPN)
-- | MergedPkgDep records constraints about the instances that can still be
-- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a
......@@ -146,15 +145,15 @@ type ExeDeps = Map UnqualComponentName (DependencyReason QPN)
-- them. It also records whether a package is a build-tool dependency, for each
-- 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
-- its qualifier, which affects which constraint is applied.
data MergedPkgDep =
MergedDepFixed (Maybe UnqualComponentName) (DependencyReason QPN) I
MergedDepFixed ExposedComponent (DependencyReason QPN) I
| MergedDepConstrained [VROrigin]
-- | 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.
type Conflict = (ConflictSet, FailReason)
......@@ -204,11 +203,11 @@ validate = cata go
pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs
idx <- asks index -- obtain the index
svd <- asks saved -- obtain saved dependencies
aExes <- asks availableExes
rExes <- asks requiredExes
aComps <- asks availableComponents
rComps <- asks requiredComponents
qo <- asks qualifyOptions
-- 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
let qdeps = qualifyDeps qo qpn deps
-- the new active constraints are given by the instance we have chosen,
......@@ -223,20 +222,20 @@ validate = cata go
Just fr -> -- The index marks this as an invalid choice. We can stop.
return (Fail (varToConflictSet (P qpn)) fr)
Nothing ->
let newDeps :: Either Conflict (PPreAssignment, Map QPN ExeDeps)
let newDeps :: Either Conflict (PPreAssignment, Map QPN ComponentDependencyReasons)
newDeps = do
nppa <- mnppa
rExes' <- extendRequiredExes aExes rExes newactives
checkExesInNewPackage rExes qpn exes
return (nppa, rExes')
rComps' <- extendRequiredComponents aComps rComps newactives
checkComponentsInNewPackage rComps qpn comps
return (nppa, rComps')
in case newDeps of
Left (c, fr) -> -- We have an inconsistency. We can stop.
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
, saved = nsvd
, availableExes = M.insert qpn exes aExes
, requiredExes = rExes'
, availableComponents = M.insert qpn comps aComps
, requiredComponents = rComps'
}) r
-- What to do for flag nodes ...
......@@ -247,8 +246,8 @@ validate = cata go
langSupported <- asks supportedLang -- obtain the supported languages
pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs
svd <- asks saved -- obtain saved dependencies
aExes <- asks availableExes
rExes <- asks requiredExes
aComps <- asks availableComponents
rComps <- asks requiredComponents
-- 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
-- that define them.
......@@ -261,13 +260,13 @@ validate = cata go
-- We now try to get the new active dependencies we might learn about because
-- we have chosen a new flag.
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.
let mnppa = extend extSupported langSupported pkgPresent newactives ppa
case liftM2 (,) mnppa mNewRequiredExes of
case liftM2 (,) mnppa mNewRequiredComps of
Left (c, fr) -> return (Fail c fr) -- inconsistency found
Right (nppa, rExes') ->
local (\ s -> s { pa = PA nppa npfa psa, requiredExes = rExes' }) r
Right (nppa, rComps') ->
local (\ s -> s { pa = PA nppa npfa psa, requiredComponents = rComps' }) r
-- What to do for stanza nodes (similar to flag nodes) ...
goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
......@@ -277,8 +276,8 @@ validate = cata go
langSupported <- asks supportedLang -- obtain the supported languages
pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs
svd <- asks saved -- obtain saved dependencies
aExes <- asks availableExes
rExes <- asks requiredExes
aComps <- asks availableComponents
rComps <- asks requiredComponents
-- 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
-- that define them.
......@@ -291,24 +290,24 @@ validate = cata go
-- We now try to get the new active dependencies we might learn about because
-- we have chosen a new flag.
let newactives = extractNewDeps (S qsn) b pfa npsa qdeps
mNewRequiredExes = extendRequiredExes aExes rExes newactives
mNewRequiredComps = extendRequiredComponents aComps rComps newactives
-- As in the package case, we try to extend the partial assignment.
let mnppa = extend extSupported langSupported pkgPresent newactives ppa
case liftM2 (,) mnppa mNewRequiredExes of
case liftM2 (,) mnppa mNewRequiredComps of
Left (c, fr) -> return (Fail c fr) -- inconsistency found
Right (nppa, rExes') ->
local (\ s -> s { pa = PA nppa pfa npsa, requiredExes = rExes' }) r
Right (nppa, rComps') ->
local (\ s -> s { pa = PA nppa pfa npsa, requiredComponents = rComps' }) r
-- | Check that a newly chosen package instance contains all executables that
-- | Check that a newly chosen package instance contains all components that
-- are required from that package so far.
checkExesInNewPackage :: Map QPN ExeDeps
checkComponentsInNewPackage :: Map QPN ComponentDependencyReasons
-> QPN
-> [UnqualComponentName]
-> [ExposedComponent]
-> Either Conflict ()
checkExesInNewPackage required qpn providedExes =
case M.toList $ deleteKeys providedExes (M.findWithDefault M.empty qpn required) of
(missingExe, dr) : _ -> let cs = CS.insert (P qpn) $ dependencyReasonToCS dr
in Left (cs, NewPackageIsMissingRequiredExe missingExe dr)
checkComponentsInNewPackage required qpn providedComps =
case M.toList $ deleteKeys providedComps (M.findWithDefault M.empty qpn required) of
(missingComp, dr) : _ -> let cs = CS.insert (P qpn) $ dependencyReasonToCS dr
in Left (cs, NewPackageIsMissingRequiredComponent missingComp dr)
[] -> Right ()
where
deleteKeys :: Ord k => [k] -> Map k v -> Map k v
......@@ -386,18 +385,23 @@ extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle
extendSingle a (LDep dr (Pkg pn vr)) =
if pkgPresent pn vr then Right a
else Left (dependencyReasonToCS dr, MissingPkgconfigPackage pn vr)
extendSingle a (LDep dr (Dep mExe qpn ci)) =
extendSingle a (LDep dr (Dep dep@(PkgComponent qpn _) ci)) =
let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a
in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr mExe qpn ci) of
in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr dep ci) of
Left (c, (d, d')) -> Left (c, ConflictingConstraints d d')
Right x -> Right x
-- | Extend a package preassignment with a package choice. For example, when
-- the solver chooses foo-2.0, it tries to add the constraint foo==2.0.
--
-- TODO: The new constraint is implemented as a dependency from foo to foo's
-- library. That isn't correct, because foo might only be needed as a build
-- tool dependency. The implemention may need to change when we support
-- component-based dependency solving.
extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment
extendWithPackageChoice (PI qpn i) ppa =
let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa
newChoice = PkgDep (DependencyReason qpn M.empty S.empty) Nothing qpn (Fixed i)
newChoice = PkgDep (DependencyReason qpn M.empty S.empty) (PkgComponent qpn ExposedLib) (Fixed i)
in case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of
Left (c, (d, _d')) -> -- Don't include the package choice in the
-- FailReason, because it is redundant.
......@@ -426,60 +430,62 @@ merge ::
(?loc :: CallStack) =>
#endif
MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
merge (MergedDepFixed mExe1 vs1 i1) (PkgDep vs2 mExe2 p ci@(Fixed i2))
| i1 == i2 = Right $ MergedDepFixed mExe1 vs1 i1
merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i2))
| i1 == i2 = Right $ MergedDepFixed comp1 vs1 i1
| otherwise =
Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2
, ( ConflictingDep vs1 mExe1 p (Fixed i1)
, ConflictingDep vs2 mExe2 p ci ) )
, ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1)
, ConflictingDep vs2 (PkgComponent p comp2) ci ) )
merge (MergedDepFixed mExe1 vs1 i@(I v _)) (PkgDep vs2 mExe2 p ci@(Constrained vr))
| checkVR vr v = Right $ MergedDepFixed mExe1 vs1 i
merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr))
| checkVR vr v = Right $ MergedDepFixed comp1 vs1 i
| otherwise =
Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2
, ( ConflictingDep vs1 mExe1 p (Fixed i)
, ConflictingDep vs2 mExe2 p ci ) )
, ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i)
, ConflictingDep vs2 (PkgComponent p comp2) ci ) )
merge (MergedDepConstrained vrOrigins) (PkgDep vs2 mExe2 p ci@(Fixed i@(I v _))) =
merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I v _))) =
go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ...
where
go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
go [] = Right (MergedDepFixed mExe2 vs2 i)
go ((vr, mExe1, vs1) : vros)
go [] = Right (MergedDepFixed comp2 vs2 i)
go ((vr, comp1, vs1) : vros)
| checkVR vr v = go vros
| otherwise =
Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2
, ( ConflictingDep vs1 mExe1 p (Constrained vr)
, ConflictingDep vs2 mExe2 p ci ) )
, ( ConflictingDep vs1 (PkgComponent p comp1) (Constrained vr)
, ConflictingDep vs2 (PkgComponent p comp2) ci ) )
merge (MergedDepConstrained vrOrigins) (PkgDep vs2 mExe2 _ (Constrained vr)) =
merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent _ comp2) (Constrained vr)) =
Right (MergedDepConstrained $
-- TODO: This line appends the new version range, to preserve the order used
-- before a refactoring. Consider prepending the version range, if there is
-- no negative performance impact.
vrOrigins ++ [(vr, mExe2, vs2)])
vrOrigins ++ [(vr, comp2, vs2)])
-- | Takes a list of new dependencies and uses it to try to update the map of
-- known executable dependencies. It returns a failure when a new dependency
-- requires an executable that is missing from one of the previously chosen
-- known component dependencies. It returns a failure when a new dependency
-- requires a component that is missing from one of the previously chosen
-- packages.
extendRequiredExes :: Map QPN [UnqualComponentName]
-> Map QPN ExeDeps
extendRequiredComponents :: Map QPN [ExposedComponent]
-> Map QPN ComponentDependencyReasons
-> [LDep QPN]
-> Either Conflict (Map QPN ExeDeps)
extendRequiredExes available = foldM extendSingle
-> Either Conflict (Map QPN ComponentDependencyReasons)
extendRequiredComponents available = foldM extendSingle
where
extendSingle :: Map QPN ExeDeps -> LDep QPN -> Either Conflict (Map QPN ExeDeps)
extendSingle required (LDep dr (Dep (Just exe) qpn _)) =
let exeDeps = M.findWithDefault M.empty qpn required
in -- Only check for the existence of the exe if its package has already
-- been chosen.
extendSingle :: Map QPN ComponentDependencyReasons
-> LDep QPN
-> Either Conflict (Map QPN ComponentDependencyReasons)
extendSingle required (LDep dr (Dep (PkgComponent qpn comp) _)) =
let compDeps = M.findWithDefault M.empty qpn required
in -- Only check for the existence of the component if its package has
-- already been chosen.
case M.lookup qpn available of
Just exes
| L.notElem exe exes -> let cs = CS.insert (P qpn) (dependencyReasonToCS dr)
in Left (cs, PackageRequiresMissingExe qpn exe)
_ -> Right $ M.insertWith M.union