diff --git a/cabal-install/Distribution/Solver/Modular/Message.hs b/cabal-install/Distribution/Solver/Modular/Message.hs
index 1c307d5683c756add17750cadc48db758f1c6617..19bc078937128a4812407bc3ed1f3b8a18d43295 100644
--- a/cabal-install/Distribution/Solver/Modular/Message.hs
+++ b/cabal-install/Distribution/Solver/Modular/Message.hs
@@ -131,6 +131,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 _ 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)"
diff --git a/cabal-install/Distribution/Solver/Modular/Tree.hs b/cabal-install/Distribution/Solver/Modular/Tree.hs
index e654f5e453f7d2d5a408854d4d3272d8325d35b9..6ae1b22a967c5d8b104c084f2e35df4cef8a3225 100644
--- a/cabal-install/Distribution/Solver/Modular/Tree.hs
+++ b/cabal-install/Distribution/Solver/Modular/Tree.hs
@@ -100,6 +100,8 @@ data FailReason = UnsupportedExtension Extension
| MissingPkgconfigPackage PkgconfigName VR
| NewPackageDoesNotMatchExistingConstraint ConflictingDep
| ConflictingConstraints ConflictingDep ConflictingDep
+ | NewPackageIsMissingRequiredExe UnqualComponentName (DependencyReason QPN)
+ | PackageRequiresMissingExe QPN UnqualComponentName
| CannotInstall
| CannotReinstall
| Shadowed
diff --git a/cabal-install/Distribution/Solver/Modular/Validate.hs b/cabal-install/Distribution/Solver/Modular/Validate.hs
index 76dd6a988b0da7d6aac6660d25cd4dfe7c93721b..105162fe5a59df475ee6431b0f4edd691801b646 100644
--- a/cabal-install/Distribution/Solver/Modular/Validate.hs
+++ b/cabal-install/Distribution/Solver/Modular/Validate.hs
@@ -107,6 +107,15 @@ data ValidateState = VS {
saved :: Map QPN (FlaggedDeps QPN),
pa :: PreAssignment,
+
+ -- Map from package name to the executables that are provided by the chosen
+ -- instance of that package.
+ availableExes :: Map QPN [UnqualComponentName],
+
+ -- Map from package name to the executables that are required from that
+ -- package.
+ requiredExes :: Map QPN ExeDeps,
+
qualifyOptions :: QualifyOptions
}
@@ -127,17 +136,28 @@ type PPreAssignment = Map QPN MergedPkgDep
-- | A dependency on a package, including its DependencyReason.
data PkgDep = PkgDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI
+-- | Map from executable name to one of the reasons that the executable is
+-- required.
+type ExeDeps = Map UnqualComponentName (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
-- list of version ranges paired with the goals / variables that introduced
--- them. It also records whether a package is a build-tool dependency, for use
--- in log messages.
+-- 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
+-- 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
- | MergedDepConstrained (Maybe UnqualComponentName) [VROrigin]
+ | MergedDepConstrained [VROrigin]
-- | Version ranges paired with origins.
-type VROrigin = (VR, DependencyReason QPN)
+type VROrigin = (VR, Maybe UnqualComponentName, DependencyReason QPN)
+
+-- | The information needed to create a 'Fail' node.
+type Conflict = (ConflictSet, FailReason)
validate :: Tree d c -> Validate (Tree d c)
validate = cata go
@@ -184,9 +204,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
qo <- asks qualifyOptions
-- obtain dependencies and index-dictated exclusions introduced by the choice
- let (PInfo deps _ _ mfr) = idx ! pn ! i
+ let (PInfo deps exes _ 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,
@@ -200,11 +222,22 @@ validate = cata go
case mfr of
Just fr -> -- The index marks this as an invalid choice. We can stop.
return (Fail (varToConflictSet (P qpn)) fr)
- _ -> case mnppa of
- Left (c, fr) -> -- We have an inconsistency. We can stop.
- return (Fail c fr)
- Right nppa -> -- We have an updated partial assignment for the recursive validation.
- local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r
+ Nothing ->
+ let newDeps :: Either Conflict (PPreAssignment, Map QPN ExeDeps)
+ newDeps = do
+ nppa <- mnppa
+ rExes' <- extendRequiredExes aExes rExes newactives
+ checkExesInNewPackage rExes qpn exes
+ return (nppa, rExes')
+ 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.
+ local (\ s -> s { pa = PA nppa pfa psa
+ , saved = nsvd
+ , availableExes = M.insert qpn exes aExes
+ , requiredExes = rExes'
+ }) r
-- What to do for flag nodes ...
goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
@@ -213,7 +246,9 @@ validate = cata go
extSupported <- asks supportedExt -- obtain the supported extensions
langSupported <- asks supportedLang -- obtain the supported languages
pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs
- svd <- asks saved -- obtain saved dependencies
+ svd <- asks saved -- obtain saved dependencies
+ aExes <- asks availableExes
+ rExes <- asks requiredExes
-- 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.
@@ -226,10 +261,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
-- As in the package case, we try to extend the partial assignment.
- case extend extSupported langSupported pkgPresent newactives ppa of
- Left (c, fr) -> return (Fail c fr) -- inconsistency found
- Right nppa -> local (\ s -> s { pa = PA nppa npfa psa }) r
+ let mnppa = extend extSupported langSupported pkgPresent newactives ppa
+ case liftM2 (,) mnppa mNewRequiredExes of
+ Left (c, fr) -> return (Fail c fr) -- inconsistency found
+ Right (nppa, rExes') ->
+ local (\ s -> s { pa = PA nppa npfa psa, requiredExes = rExes' }) r
-- What to do for stanza nodes (similar to flag nodes) ...
goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
@@ -238,7 +276,9 @@ validate = cata go
extSupported <- asks supportedExt -- obtain the supported extensions
langSupported <- asks supportedLang -- obtain the supported languages
pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs
- svd <- asks saved -- obtain saved dependencies
+ svd <- asks saved -- obtain saved dependencies
+ aExes <- asks availableExes
+ rExes <- asks requiredExes
-- 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.
@@ -251,10 +291,28 @@ 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
-- As in the package case, we try to extend the partial assignment.
- case extend extSupported langSupported pkgPresent newactives ppa of
- Left (c, fr) -> return (Fail c fr) -- inconsistency found
- Right nppa -> local (\ s -> s { pa = PA nppa pfa npsa }) r
+ let mnppa = extend extSupported langSupported pkgPresent newactives ppa
+ case liftM2 (,) mnppa mNewRequiredExes of
+ Left (c, fr) -> return (Fail c fr) -- inconsistency found
+ Right (nppa, rExes') ->
+ local (\ s -> s { pa = PA nppa pfa npsa, requiredExes = rExes' }) r
+
+-- | Check that a newly chosen package instance contains all executables that
+-- are required from that package so far.
+checkExesInNewPackage :: Map QPN ExeDeps
+ -> QPN
+ -> [UnqualComponentName]
+ -> 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)
+ [] -> Right ()
+ where
+ deleteKeys :: Ord k => [k] -> Map k v -> Map k v
+ deleteKeys ks m = L.foldr M.delete m ks
-- | We try to extract as many concrete dependencies from the given flagged
-- dependencies as possible. We make use of all the flag knowledge we have
@@ -314,12 +372,11 @@ extend :: (Extension -> Bool) -- ^ is a given extension supported
-> (PkgconfigName -> VR -> Bool) -- ^ is a given pkg-config requirement satisfiable
-> [LDep QPN]
-> PPreAssignment
- -> Either (ConflictSet, FailReason) PPreAssignment
+ -> Either Conflict PPreAssignment
extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle ppa newactives
where
- extendSingle :: PPreAssignment -> LDep QPN
- -> Either (ConflictSet, FailReason) PPreAssignment
+ extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment
extendSingle a (LDep dr (Ext ext )) =
if extSupported ext then Right a
else Left (dependencyReasonToCS dr, UnsupportedExtension ext)
@@ -330,18 +387,16 @@ extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle
if pkgPresent pn vr then Right a
else Left (dependencyReasonToCS dr, MissingPkgconfigPackage pn vr)
extendSingle a (LDep dr (Dep mExe qpn ci)) =
- let mergedDep = M.findWithDefault (MergedDepConstrained Nothing []) qpn a
+ let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a
in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr mExe qpn 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.
-extendWithPackageChoice :: PI QPN
- -> PPreAssignment
- -> Either (ConflictSet, FailReason) PPreAssignment
+extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment
extendWithPackageChoice (PI qpn i) ppa =
- let mergedDep = M.findWithDefault (MergedDepConstrained Nothing []) qpn ppa
+ let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa
newChoice = PkgDep (DependencyReason qpn [] []) Nothing qpn (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
@@ -372,48 +427,60 @@ merge ::
#endif
MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
merge (MergedDepFixed mExe1 vs1 i1) (PkgDep vs2 mExe2 p ci@(Fixed i2))
- | i1 == i2 = Right $ MergedDepFixed (mergeExes mExe1 mExe2) vs1 i1
+ | i1 == i2 = Right $ MergedDepFixed mExe1 vs1 i1
| otherwise =
Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2
, ( ConflictingDep vs1 mExe1 p (Fixed i1)
, ConflictingDep vs2 mExe2 p ci ) )
merge (MergedDepFixed mExe1 vs1 i@(I v _)) (PkgDep vs2 mExe2 p ci@(Constrained vr))
- | checkVR vr v = Right $ MergedDepFixed (mergeExes mExe1 mExe2) vs1 i
+ | checkVR vr v = Right $ MergedDepFixed mExe1 vs1 i
| otherwise =
Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2
, ( ConflictingDep vs1 mExe1 p (Fixed i)
, ConflictingDep vs2 mExe2 p ci ) )
-merge (MergedDepConstrained mExe1 vrOrigins) (PkgDep vs2 mExe2 p ci@(Fixed i@(I v _))) =
+merge (MergedDepConstrained vrOrigins) (PkgDep vs2 mExe2 p 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 (mergeExes mExe1 mExe2) vs2 i)
- go ((vr, vs1) : vros)
+ go [] = Right (MergedDepFixed mExe2 vs2 i)
+ go ((vr, mExe1, 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 ) )
-merge (MergedDepConstrained mExe1 vrOrigins) (PkgDep vs2 mExe2 _ (Constrained vr)) =
- Right (MergedDepConstrained (mergeExes mExe1 mExe2) $
+merge (MergedDepConstrained vrOrigins) (PkgDep vs2 mExe2 _ (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, vs2)])
-
--- TODO: This function isn't correct, because cabal may need to build libs
--- and/or multiple exes for a package. The merged value is only used to
--- determine whether to print the name of an exe next to conflicts in log
--- message, though. It should be removed when component-based solving is
--- implemented.
-mergeExes :: Maybe UnqualComponentName
- -> Maybe UnqualComponentName
- -> Maybe UnqualComponentName
-mergeExes = (<|>)
+ vrOrigins ++ [(vr, mExe2, 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
+-- packages.
+extendRequiredExes :: Map QPN [UnqualComponentName]
+ -> Map QPN ExeDeps
+ -> [LDep QPN]
+ -> Either Conflict (Map QPN ExeDeps)
+extendRequiredExes 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.
+ 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 qpn (M.insert exe dr exeDeps) required
+ extendSingle required _ = Right required
-- | Interface.
validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c
@@ -428,5 +495,7 @@ validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS {
, index = idx
, saved = M.empty
, pa = PA M.empty M.empty M.empty
+ , availableExes = M.empty
+ , requiredExes = M.empty
, qualifyOptions = defaultQualifyOptions idx
}
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
index 129790309cf02902fcfce650cb7763cc86d732c7..e9dd57e7211a79d2cdecdd0ae2f36b9687e3db25 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
@@ -1239,7 +1239,7 @@ dbBJ8 = [
-------------------------------------------------------------------------------}
dbBuildTools1 :: ExampleDb
dbBuildTools1 = [
- Right $ exAv "alex" 1 [],
+ Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [],
Right $ exAv "A" 1 [ExBuildToolAny "alex"]
]
@@ -1253,8 +1253,8 @@ dbBuildTools2 = [
-- Test that we can solve for different versions of executables
dbBuildTools3 :: ExampleDb
dbBuildTools3 = [
- Right $ exAv "alex" 1 [],
- Right $ exAv "alex" 2 [],
+ Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [],
+ Right $ exAv "alex" 2 [] `withExe` ExExe "alex" [],
Right $ exAv "A" 1 [ExBuildToolFix "alex" 1],
Right $ exAv "B" 1 [ExBuildToolFix "alex" 2],
Right $ exAv "C" 1 [ExAny "A", ExAny "B"]
@@ -1263,7 +1263,7 @@ dbBuildTools3 = [
-- Test that exe is not related to library choices
dbBuildTools4 :: ExampleDb
dbBuildTools4 = [
- Right $ exAv "alex" 1 [ExFix "A" 1],
+ Right $ exAv "alex" 1 [ExFix "A" 1] `withExe` ExExe "alex" [],
Right $ exAv "A" 1 [],
Right $ exAv "A" 2 [],
Right $ exAv "B" 1 [ExBuildToolFix "alex" 1, ExFix "A" 2]
@@ -1272,8 +1272,8 @@ dbBuildTools4 = [
-- Test that build-tools on build-tools works
dbBuildTools5 :: ExampleDb
dbBuildTools5 = [
- Right $ exAv "alex" 1 [],
- Right $ exAv "happy" 1 [ExBuildToolAny "alex"],
+ Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [],
+ Right $ exAv "happy" 1 [ExBuildToolAny "alex"] `withExe` ExExe "happy" [],
Right $ exAv "A" 1 [ExBuildToolAny "happy"]
]