From 8cc3241c33a0926e287ae5b53303d2e3f5098765 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?I=C3=B1aki=20Garc=C3=ADa=20Etxebarria?= Date: Sun, 3 Jan 2016 11:21:07 +0100 Subject: [PATCH] Make the solver aware of pkg-config constraints When solving, we now discard plans that would involve packages with a pkgconfig-depends constraint which is not satisfiable with the current set of installed packages (as listed by pkg-config --list-all). This fixes https://github.com/haskell/cabal/issues/3016. It is possible (in principle, although it should be basically impossible in practice) that "pkg-config --modversion pkg1 pkg2... pkgN" fails to execute for various reasons, in particular because N is too large, so the command line becomes too long for the operating system limits. If this happens, revert to the previous behavior of accepting any install plan, regardless of any pkgconfig-depends constraints. --- .../Distribution/Client/Configure.hs | 10 +- .../Distribution/Client/Dependency.hs | 8 +- .../Distribution/Client/Dependency/Modular.hs | 4 +- .../Client/Dependency/Modular/Assignment.hs | 6 +- .../Client/Dependency/Modular/Builder.hs | 3 + .../Client/Dependency/Modular/Dependency.hs | 8 ++ .../Dependency/Modular/IndexConversion.hs | 1 + .../Client/Dependency/Modular/Linking.hs | 2 + .../Client/Dependency/Modular/Solver.hs | 7 +- .../Client/Dependency/Modular/Validate.hs | 17 +++- .../Distribution/Client/Dependency/TopDown.hs | 2 +- .../Distribution/Client/Dependency/Types.hs | 3 + cabal-install/Distribution/Client/Fetch.hs | 10 +- cabal-install/Distribution/Client/Freeze.hs | 10 +- cabal-install/Distribution/Client/Install.hs | 19 ++-- .../Distribution/Client/PkgConfigDb.hs | 99 +++++++++++++++++++ cabal-install/cabal-install.cabal | 1 + .../Client/Dependency/Modular/DSL.hs | 38 ++++--- .../Client/Dependency/Modular/Solver.hs | 53 +++++++--- 19 files changed, 245 insertions(+), 56 deletions(-) create mode 100644 cabal-install/Distribution/Client/PkgConfigDb.hs diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs index 4f27911e9e1..2ffde465d5e 100644 --- a/cabal-install/Distribution/Client/Configure.hs +++ b/cabal-install/Distribution/Client/Configure.hs @@ -27,6 +27,7 @@ import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.IndexUtils as IndexUtils ( getSourcePackages, getInstalledPackages ) import Distribution.Client.PackageIndex ( PackageIndex, elemByPackageName ) +import Distribution.Client.PkgConfigDb (PkgConfigDb, readPkgConfigDb) import Distribution.Client.Setup ( ConfigExFlags(..), configureCommand, filterConfigureFlags ) import Distribution.Client.Types as Source @@ -106,11 +107,12 @@ configure verbosity packageDBs repos comp platform conf installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf sourcePkgDb <- getSourcePackages verbosity repos + pkgConfigDb <- readPkgConfigDb verbosity conf checkConfigExFlags verbosity installedPkgIndex (packageIndex sourcePkgDb) configExFlags progress <- planLocalPackage verbosity comp platform configFlags configExFlags - installedPkgIndex sourcePkgDb + installedPkgIndex sourcePkgDb pkgConfigDb notice verbosity "Resolving dependencies..." maybePlan <- foldProgress logMsg (return . Left) (return . Right) @@ -263,10 +265,10 @@ planLocalPackage :: Verbosity -> Compiler -> ConfigFlags -> ConfigExFlags -> InstalledPackageIndex -> SourcePackageDb + -> PkgConfigDb -> IO (Progress String String InstallPlan) planLocalPackage verbosity comp platform configFlags configExFlags - installedPkgIndex - (SourcePackageDb _ packagePrefs) = do + installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerInfo comp) @@ -320,7 +322,7 @@ planLocalPackage verbosity comp platform configFlags configExFlags (SourcePackageDb mempty packagePrefs) [SpecificSourcePackage localPkg] - return (resolveDependencies platform (compilerInfo comp) solver resolverParams) + return (resolveDependencies platform (compilerInfo comp) pkgConfigDb solver resolverParams) -- | Call an installer for an 'SourcePackage' but override the configure diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs index 8f20e7a4f9c..a4d87537d94 100644 --- a/cabal-install/Distribution/Client/Dependency.hs +++ b/cabal-install/Distribution/Client/Dependency.hs @@ -68,6 +68,7 @@ import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.PkgConfigDb (PkgConfigDb) import Distribution.Client.Types ( SourcePackageDb(SourcePackageDb), SourcePackage(..) , ConfiguredPackage(..), ConfiguredId(..), enableStanzas ) @@ -533,25 +534,26 @@ runSolver Modular = modularResolver -- resolveDependencies :: Platform -> CompilerInfo + -> PkgConfigDb -> Solver -> DepResolverParams -> Progress String String InstallPlan --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages -resolveDependencies platform comp _solver params +resolveDependencies platform comp _pkgConfigDB _solver params | null (depResolverTargets params) = return (validateSolverResult platform comp indGoals []) where indGoals = depResolverIndependentGoals params -resolveDependencies platform comp solver params = +resolveDependencies platform comp pkgConfigDB solver params = Step (showDepResolverParams finalparams) $ fmap (validateSolverResult platform comp indGoals) $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls shadowing strFlags maxBkjumps) platform comp installedPkgIndex sourcePkgIndex - preferences constraints targets + pkgConfigDB preferences constraints targets where finalparams @ (DepResolverParams diff --git a/cabal-install/Distribution/Client/Dependency/Modular.hs b/cabal-install/Distribution/Client/Dependency/Modular.hs index 4f356dcf173..912ee763977 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular.hs @@ -34,10 +34,10 @@ import Distribution.System -- | Ties the two worlds together: classic cabal-install vs. the modular -- solver. Performs the necessary translations before and after. modularResolver :: SolverConfig -> DependencyResolver -modularResolver sc (Platform arch os) cinfo iidx sidx pprefs pcs pns = +modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns = fmap (uncurry postprocess) $ -- convert install plan logToProgress (maxBackjumps sc) $ -- convert log format into progress format - solve sc cinfo idx pprefs gcs pns + solve sc cinfo idx pkgConfigDB pprefs gcs pns where -- Indices have to be converted into solver-specific uniform index. idx = convPIs os arch cinfo (shadowPkgs sc) (strongFlags sc) iidx sidx diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs b/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs index 1ece3213439..2cfca311646 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs @@ -65,9 +65,10 @@ data PreAssignment = PA PPreAssignment FAssignment SAssignment -- or the successfully extended assignment. extend :: (Extension -> Bool) -- ^ is a given extension supported -> (Language -> Bool) -- ^ is a given language supported + -> (PN -> VR -> Bool) -- ^ is a given pkg-config requirement satisfiable -> Goal QPN -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment -extend extSupported langSupported goal@(Goal var _) = foldM extendSingle +extend extSupported langSupported pkgPresent goal@(Goal var _) = foldM extendSingle where extendSingle :: PPreAssignment -> Dep QPN @@ -78,6 +79,9 @@ extend extSupported langSupported goal@(Goal var _) = foldM extendSingle extendSingle a (Lang lang) = if langSupported lang then Right a else Left (toConflictSet goal, [Lang lang]) + extendSingle a (Pkg pn vr) = + if pkgPresent pn vr then Right a + else Left (toConflictSet goal, [Pkg pn vr]) extendSingle a (Dep qpn ci) = let ci' = M.findWithDefault (Constrained []) qpn a in case (\ x -> M.insert qpn x a) <$> merge ci' ci of diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs index cf18d1018aa..29d4e38ad12 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs @@ -61,6 +61,7 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs -- code above is correct; insert/adjust have different arg order go g o ( (OpenGoal (Simple (Ext _ext ) _) _gr) : ngs) = go g o ngs go g o ( (OpenGoal (Simple (Lang _lang)_) _gr) : ngs) = go g o ngs + go g o ( (OpenGoal (Simple (Pkg _pn _vr)_) _gr) : ngs)= go g o ngs cons' = P.cons . forgetCompOpenGoal @@ -121,6 +122,8 @@ build = ana go error "Distribution.Client.Dependency.Modular.Builder: build.go called with Ext goal" go (BS { index = _ , next = OneGoal (OpenGoal (Simple (Lang _ ) _) _ ) }) = error "Distribution.Client.Dependency.Modular.Builder: build.go called with Lang goal" + go (BS { index = _ , next = OneGoal (OpenGoal (Simple (Pkg _ _ ) _) _ ) }) = + error "Distribution.Client.Dependency.Modular.Builder: build.go called with Pkg goal" go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _) _) gr) }) = case M.lookup pn idx of Nothing -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn) diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs index b62ee98ee7c..214e13c5810 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs @@ -208,6 +208,7 @@ type FalseFlaggedDeps qpn = FlaggedDeps Component qpn data Dep qpn = Dep qpn (CI qpn) -- dependency on a package | Ext Extension -- dependency on a language extension | Lang Language -- dependency on a language version + | Pkg PN VR -- dependency on a pkg-config package deriving (Eq, Show, Functor) showDep :: Dep QPN -> String @@ -220,6 +221,9 @@ showDep (Dep qpn ci ) = showQPN qpn ++ showCI ci showDep (Ext ext) = "requires " ++ display ext showDep (Lang lang) = "requires " ++ display lang +showDep (Pkg pn vr) = "requires pkg-config package " + ++ display pn ++ display vr + ++ ", not found in the pkg-config database" -- | Options for goal qualification (used in 'qualifyDeps') -- @@ -263,6 +267,7 @@ qualifyDeps QO{..} (Q pp' pn) = go qBase (Dep dep _ci) = qoBaseShim && unPackageName dep == "base" qBase (Ext _) = False qBase (Lang _) = False + qBase (Pkg _ _) = False -- Should we qualify this goal with the 'Setup' packaeg path? qSetup :: Component -> Bool @@ -393,6 +398,7 @@ instance ResetGoal Dep where resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci) resetGoal _ (Ext ext) = Ext ext resetGoal _ (Lang lang) = Lang lang + resetGoal _ (Pkg pn vr) = Pkg pn vr instance ResetGoal Goal where resetGoal = const @@ -431,6 +437,8 @@ close (OpenGoal (Simple (Ext _) _) _ ) = error "Distribution.Client.Dependency.Modular.Dependency.close: called on Ext goal" close (OpenGoal (Simple (Lang _) _) _ ) = error "Distribution.Client.Dependency.Modular.Dependency.close: called on Lang goal" +close (OpenGoal (Simple (Pkg _ _) _) _ ) = + error "Distribution.Client.Dependency.Modular.Dependency.close: called on Pkg goal" close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr close (OpenGoal (Stanza qsn _) gr) = Goal (S qsn) gr diff --git a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs index 5e39c996237..515e1ff3c4e 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs @@ -149,6 +149,7 @@ convCondTree os arch cinfo pi@(PI pn _) fds p comp getInfo (CondNode info ds bra | p info = L.map (\d -> D.Simple (convDep pn d) comp) ds -- unconditional package dependencies ++ L.map (\e -> D.Simple (Ext e) comp) (PD.allExtensions bi) -- unconditional extension dependencies ++ L.map (\l -> D.Simple (Lang l) comp) (PD.allLanguages bi) -- unconditional language dependencies + ++ L.map (\(Dependency pkn vr) -> D.Simple (Pkg pkn vr) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies ++ concatMap (convBranch os arch cinfo pi fds p comp getInfo) branches | otherwise = [] where diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs index 0b0a5ef6038..1bc1c7abf9e 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs @@ -278,6 +278,8 @@ linkDeps parents pp' = mapM_ go -- No choice is involved, just checking, so there is nothing to link. go (Simple (Ext _) _) = return () go (Simple (Lang _) _) = return () + -- Similarly for pkg-config constraints + go (Simple (Pkg _ _) _) = return () go (Flagged fn _ t f) = do vs <- get case M.lookup fn (vsFlags vs) of diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs index a1b2df646b5..a69c8c257d9 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs @@ -7,6 +7,8 @@ import Data.Map as M import Distribution.Compiler (CompilerInfo) +import Distribution.Client.PkgConfigDb (PkgConfigDb) + import Distribution.Client.Dependency.Types import Distribution.Client.Dependency.Modular.Assignment @@ -34,11 +36,12 @@ data SolverConfig = SolverConfig { solve :: SolverConfig -> -- solver parameters CompilerInfo -> Index -> -- all available packages as an index + PkgConfigDb -> (PN -> PackagePreferences) -> -- preferences Map PN [LabeledPackageConstraint] -> -- global constraints [PN] -> -- global goals Log Message (Assignment, RevDepMap) -solve sc cinfo idx userPrefs userConstraints userGoals = +solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = explorePhase $ heuristicsPhase $ preferencesPhase $ @@ -60,7 +63,7 @@ solve sc cinfo idx userPrefs userConstraints userGoals = P.enforcePackageConstraints userConstraints . P.enforceSingleInstanceRestriction . validateLinking idx . - validateTree cinfo idx + validateTree cinfo idx pkgConfigDB prunePhase = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) . -- packages that can never be "upgraded": P.requireInstalled (`elem` [ PackageName "base" diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs index 8c583cd182b..3bbcbab3fd3 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs @@ -25,8 +25,10 @@ import Distribution.Client.Dependency.Modular.Index import Distribution.Client.Dependency.Modular.Package import qualified Distribution.Client.Dependency.Modular.PSQ as P import Distribution.Client.Dependency.Modular.Tree +import Distribution.Client.Dependency.Modular.Version (VR) import Distribution.Client.ComponentDeps (Component) +import Distribution.Client.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) -- In practice, most constraints are implication constraints (IF we have made -- a number of choices, THEN we also have to ensure that). We call constraints @@ -82,6 +84,7 @@ import Distribution.Client.ComponentDeps (Component) data ValidateState = VS { supportedExt :: Extension -> Bool, supportedLang :: Language -> Bool, + presentPkgs :: PN -> VR -> Bool, index :: Index, saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies pa :: PreAssignment, @@ -132,6 +135,7 @@ validate = cata go PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages + pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs idx <- asks index -- obtain the index svd <- asks saved -- obtain saved dependencies qo <- asks qualifyOptions @@ -144,7 +148,7 @@ validate = cata go let goal = Goal (P qpn) gr let newactives = Dep qpn (Fixed i goal) : L.map (resetGoal goal) (extractDeps pfa psa qdeps) -- We now try to extend the partial assignment with the new active constraints. - let mnppa = extend extSupported langSupported goal ppa newactives + let mnppa = extend extSupported langSupported pkgPresent goal ppa newactives -- In case we continue, we save the scoped dependencies let nsvd = M.insert qpn qdeps svd case mfr of @@ -162,6 +166,7 @@ validate = cata go PA ppa pfa psa <- asks pa -- obtain current preassignment 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 -- 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 @@ -176,7 +181,7 @@ validate = cata go -- we have chosen a new flag. let newactives = extractNewDeps (F qfn) gr b npfa psa qdeps -- As in the package case, we try to extend the partial assignment. - case extend extSupported langSupported (Goal (F qfn) gr) ppa newactives of + case extend extSupported langSupported pkgPresent (Goal (F qfn) gr) ppa newactives of Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found Right nppa -> local (\ s -> s { pa = PA nppa npfa psa }) r @@ -186,6 +191,7 @@ validate = cata go PA ppa pfa psa <- asks pa -- obtain current preassignment 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 -- 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 @@ -200,7 +206,7 @@ validate = cata go -- we have chosen a new flag. let newactives = extractNewDeps (S qsn) gr b pfa npsa qdeps -- As in the package case, we try to extend the partial assignment. - case extend extSupported langSupported (Goal (S qsn) gr) ppa newactives of + case extend extSupported langSupported pkgPresent (Goal (S qsn) gr) ppa newactives of Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found Right nppa -> local (\ s -> s { pa = PA nppa pfa npsa }) r @@ -248,14 +254,15 @@ extractNewDeps v gr b fa sa = go Just False -> [] -- | Interface. -validateTree :: CompilerInfo -> Index -> Tree QGoalReasonChain -> Tree QGoalReasonChain -validateTree cinfo idx t = runReader (validate t) VS { +validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree QGoalReasonChain -> Tree QGoalReasonChain +validateTree cinfo idx pkgConfigDb t = runReader (validate t) VS { supportedExt = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported (\ es -> let s = S.fromList es in \ x -> S.member x s) (compilerInfoExtensions cinfo) , supportedLang = maybe (const True) (flip L.elem) -- use list lookup because language list is small and no Ord instance (compilerInfoLanguages cinfo) + , presentPkgs = pkgConfigPkgIsPresent pkgConfigDb , index = idx , saved = M.empty , pa = PA M.empty M.empty M.empty diff --git a/cabal-install/Distribution/Client/Dependency/TopDown.hs b/cabal-install/Distribution/Client/Dependency/TopDown.hs index e7bb9f1077b..f789885ed36 100644 --- a/cabal-install/Distribution/Client/Dependency/TopDown.hs +++ b/cabal-install/Distribution/Client/Dependency/TopDown.hs @@ -249,7 +249,7 @@ search configure pref constraints = -- the standard 'DependencyResolver' interface. -- topDownResolver :: DependencyResolver -topDownResolver platform cinfo installedPkgIndex sourcePkgIndex +topDownResolver platform cinfo installedPkgIndex sourcePkgIndex _pkgConfigDB preferences constraints targets = mapMessages $ topDownResolver' platform cinfo diff --git a/cabal-install/Distribution/Client/Dependency/Types.hs b/cabal-install/Distribution/Client/Dependency/Types.hs index 9b643cfe5a8..a4045db7022 100644 --- a/cabal-install/Distribution/Client/Dependency/Types.hs +++ b/cabal-install/Distribution/Client/Dependency/Types.hs @@ -48,6 +48,8 @@ import Data.Monoid ( Monoid(..) ) #endif +import Distribution.Client.PkgConfigDb + ( PkgConfigDb ) import Distribution.Client.Types ( OptionalStanza(..), SourcePackage(..), ConfiguredPackage ) @@ -109,6 +111,7 @@ type DependencyResolver = Platform -> CompilerInfo -> InstalledPackageIndex -> PackageIndex.PackageIndex SourcePackage + -> PkgConfigDb -> (PackageName -> PackagePreferences) -> [LabeledPackageConstraint] -> [PackageName] diff --git a/cabal-install/Distribution/Client/Fetch.hs b/cabal-install/Distribution/Client/Fetch.hs index 541e33d60ba..8ac14ea79da 100644 --- a/cabal-install/Distribution/Client/Fetch.hs +++ b/cabal-install/Distribution/Client/Fetch.hs @@ -24,6 +24,8 @@ import Distribution.Client.IndexUtils as IndexUtils import Distribution.Client.HttpUtils ( configureTransport, HttpTransport(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.PkgConfigDb + ( PkgConfigDb, readPkgConfigDb ) import Distribution.Client.Setup ( GlobalFlags(..), FetchFlags(..) ) @@ -84,6 +86,7 @@ fetch verbosity packageDBs repos comp platform conf installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf sourcePkgDb <- getSourcePackages verbosity repos + pkgConfigDb <- readPkgConfigDb verbosity conf transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags)) @@ -94,7 +97,7 @@ fetch verbosity packageDBs repos comp platform conf pkgs <- planPackages verbosity comp platform fetchFlags - installedPkgIndex sourcePkgDb pkgSpecifiers + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs if null pkgs' @@ -120,10 +123,11 @@ planPackages :: Verbosity -> FetchFlags -> InstalledPackageIndex -> SourcePackageDb + -> PkgConfigDb -> [PackageSpecifier SourcePackage] -> IO [SourcePackage] planPackages verbosity comp platform fetchFlags - installedPkgIndex sourcePkgDb pkgSpecifiers + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers | includeDependencies = do solver <- chooseSolver verbosity @@ -131,7 +135,7 @@ planPackages verbosity comp platform fetchFlags notice verbosity "Resolving dependencies..." installPlan <- foldProgress logMsg die return $ resolveDependencies - platform (compilerInfo comp) + platform (compilerInfo comp) pkgConfigDb solver resolverParams diff --git a/cabal-install/Distribution/Client/Freeze.hs b/cabal-install/Distribution/Client/Freeze.hs index 470e27a1d8e..18b2a382463 100644 --- a/cabal-install/Distribution/Client/Freeze.hs +++ b/cabal-install/Distribution/Client/Freeze.hs @@ -27,6 +27,8 @@ import Distribution.Client.IndexUtils as IndexUtils import Distribution.Client.InstallPlan ( InstallPlan, PlanPackage ) import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.PkgConfigDb + ( PkgConfigDb, readPkgConfigDb ) import Distribution.Client.Setup ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) ) import Distribution.Client.HttpUtils @@ -89,6 +91,7 @@ freeze verbosity packageDBs repos comp platform conf mSandboxPkgInfo installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf sourcePkgDb <- getSourcePackages verbosity repos + pkgConfigDb <- readPkgConfigDb verbosity conf transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags)) @@ -101,7 +104,7 @@ freeze verbosity packageDBs repos comp platform conf mSandboxPkgInfo sanityCheck pkgSpecifiers pkgs <- planPackages verbosity comp platform mSandboxPkgInfo freezeFlags - installedPkgIndex sourcePkgDb pkgSpecifiers + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers if null pkgs then notice verbosity $ "No packages to be frozen. " @@ -131,10 +134,11 @@ planPackages :: Verbosity -> FreezeFlags -> InstalledPackageIndex -> SourcePackageDb + -> PkgConfigDb -> [PackageSpecifier SourcePackage] -> IO [PlanPackage] planPackages verbosity comp platform mSandboxPkgInfo freezeFlags - installedPkgIndex sourcePkgDb pkgSpecifiers = do + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do solver <- chooseSolver verbosity (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp) @@ -142,7 +146,7 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags installPlan <- foldProgress logMsg die return $ resolveDependencies - platform (compilerInfo comp) + platform (compilerInfo comp) pkgConfigDb solver resolverParams diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index cefb978c053..6646cd8085d 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -147,6 +147,8 @@ import Distribution.PackageDescription , FlagName(..), FlagAssignment ) import Distribution.PackageDescription.Configuration ( finalizePackageDescription ) +import Distribution.Client.PkgConfigDb + ( PkgConfigDb, readPkgConfigDb ) import Distribution.ParseUtils ( showPWarning ) import Distribution.Version @@ -232,6 +234,7 @@ install verbosity packageDBs repos comp platform conf useSandbox mSandboxPkgInfo -- TODO: Make InstallContext a proper data type with documented fields. -- | Common context for makeInstallPlan and processInstallPlan. type InstallContext = ( InstalledPackageIndex, SourcePackageDb + , PkgConfigDb , [UserTarget], [PackageSpecifier SourcePackage] , HttpTransport ) @@ -260,6 +263,7 @@ makeInstallContext verbosity installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf sourcePkgDb <- getSourcePackages verbosity repos + pkgConfigDb <- readPkgConfigDb verbosity conf checkConfigExFlags verbosity installedPkgIndex (packageIndex sourcePkgDb) configExFlags transport <- configureTransport verbosity @@ -283,7 +287,7 @@ makeInstallContext verbosity userTargets return (userTargets, pkgSpecifiers) - return (installedPkgIndex, sourcePkgDb, userTargets + return (installedPkgIndex, sourcePkgDb, pkgConfigDb, userTargets ,pkgSpecifiers, transport) -- | Make an install plan given install context and install arguments. @@ -293,7 +297,7 @@ makeInstallPlan verbosity (_, _, comp, platform, _, _, mSandboxPkgInfo, _, configFlags, configExFlags, installFlags, _) - (installedPkgIndex, sourcePkgDb, + (installedPkgIndex, sourcePkgDb, pkgConfigDb, _, pkgSpecifiers, _) = do solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags)) @@ -301,7 +305,7 @@ makeInstallPlan verbosity notice verbosity "Resolving dependencies..." return $ planPackages comp platform mSandboxPkgInfo solver configFlags configExFlags installFlags - installedPkgIndex sourcePkgDb pkgSpecifiers + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers -- | Given an install plan, perform the actual installations. processInstallPlan :: Verbosity -> InstallArgs -> InstallContext @@ -309,7 +313,7 @@ processInstallPlan :: Verbosity -> InstallArgs -> InstallContext -> IO () processInstallPlan verbosity args@(_,_, _, _, _, _, _, _, _, _, installFlags, _) - (installedPkgIndex, sourcePkgDb, + (installedPkgIndex, sourcePkgDb, _, userTargets, pkgSpecifiers, _) installPlan = do checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb installFlags pkgSpecifiers @@ -335,14 +339,15 @@ planPackages :: Compiler -> InstallFlags -> InstalledPackageIndex -> SourcePackageDb + -> PkgConfigDb -> [PackageSpecifier SourcePackage] -> Progress String String InstallPlan planPackages comp platform mSandboxPkgInfo solver configFlags configExFlags installFlags - installedPkgIndex sourcePkgDb pkgSpecifiers = + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = resolveDependencies - platform (compilerInfo comp) + platform (compilerInfo comp) pkgConfigDb solver resolverParams @@ -710,7 +715,7 @@ reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String reportPlanningFailure verbosity (_, _, comp, platform, _, _, _ ,_, configFlags, _, installFlags, _) - (_, sourcePkgDb, _, pkgSpecifiers, _) + (_, sourcePkgDb, _, _, pkgSpecifiers, _) message = do when reportFailure $ do diff --git a/cabal-install/Distribution/Client/PkgConfigDb.hs b/cabal-install/Distribution/Client/PkgConfigDb.hs new file mode 100644 index 00000000000..d83c754c16a --- /dev/null +++ b/cabal-install/Distribution/Client/PkgConfigDb.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.PkgConfigDb +-- Copyright : (c) Iñaki García Etxebarria 2016 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Read the list of packages available to pkg-config. +----------------------------------------------------------------------------- +module Distribution.Client.PkgConfigDb + ( + PkgConfigDb + , readPkgConfigDb + , pkgConfigDbFromList + , pkgConfigPkgIsPresent + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + +import Control.Exception (IOException, handle) +import Data.Char (isSpace) +import qualified Data.Map as M +import Data.Version (parseVersion) +import Text.ParserCombinators.ReadP (readP_to_S) + +import Distribution.Package + ( PackageName(..) ) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Version + ( Version, VersionRange, withinRange ) + +import Distribution.Simple.Program + ( ProgramConfiguration, pkgConfigProgram, getProgramOutput, + requireProgram ) +import Distribution.Simple.Utils + ( warn ) + +-- | The list of packages installed in the system visible to +-- @pkg-config@. This is an opaque datatype, to be constructed with +-- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`. +data PkgConfigDb = PkgConfigDb (M.Map PackageName (Maybe Version)) + -- ^ If an entry is `Nothing`, this means that the + -- package seems to be present, but we don't know the + -- exact version (because parsing of the version + -- number failed). + | NoPkgConfigDb + -- ^ For when we could not run pkg-config successfully. + deriving (Show) + +-- | Query pkg-config for the list of installed packages, together +-- with their versions. Return a `PkgConfigDb` encapsulating this +-- information. +readPkgConfigDb :: Verbosity -> ProgramConfiguration -> IO PkgConfigDb +readPkgConfigDb verbosity conf = handle ioErrorHandler $ do + (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram conf + pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] + -- The output of @pkg-config --list-all@ also includes a description + -- for each package, which we do not need. + let pkgNames = map (takeWhile (not . isSpace)) pkgList + pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig ("--modversion" : pkgNames) + (return . pkgConfigDbFromList . zip pkgNames) pkgVersions + where + -- For when pkg-config invocation fails (possibly because of a + -- too long command line). + ioErrorHandler :: IOException -> IO PkgConfigDb + ioErrorHandler e = do + warn verbosity ("Failed to query pkg-config, Cabal will continue without solving for pkg-config constraints: " ++ show e) + return NoPkgConfigDb + +-- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs. +pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb +pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs + where + convert :: (String, String) -> (PackageName, Maybe Version) + convert (n,vs) = (PackageName n, + case (reverse . readP_to_S parseVersion) vs of + (v, "") : _ -> Just v + _ -> Nothing -- Version not (fully) understood. + ) + +-- | Check whether a given package range is satisfiable in the given +-- @pkg-config@ database. +pkgConfigPkgIsPresent :: PkgConfigDb -> PackageName -> VersionRange -> Bool +pkgConfigPkgIsPresent (PkgConfigDb db) pn vr = + case M.lookup pn db of + Nothing -> False -- Package not present in the DB. + Just Nothing -> True -- Package present, but version unknown. + Just (Just v) -> withinRange v vr +-- If we could not read the pkg-config database successfully we allow +-- the check to succeed. The plan found by the solver may fail to be +-- executed later on, but we have no grounds for rejecting the plan at +-- this stage. +pkgConfigPkgIsPresent NoPkgConfigDb _ _ = True diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 26b89353f15..74fd0d3816a 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -131,6 +131,7 @@ executable cabal Distribution.Client.PackageIndex Distribution.Client.PackageUtils Distribution.Client.ParseUtils + Distribution.Client.PkgConfigDb Distribution.Client.PlanIndex Distribution.Client.Run Distribution.Client.Sandbox diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs index a5345fe7083..75c09d435f0 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs @@ -35,6 +35,7 @@ import Distribution.Client.Dependency.Types import Distribution.Client.Types import qualified Distribution.Client.InstallPlan as CI.InstallPlan import qualified Distribution.Client.PackageIndex as CI.PackageIndex +import qualified Distribution.Client.PkgConfigDb as PC import qualified Distribution.Client.ComponentDeps as CD {------------------------------------------------------------------------------- @@ -104,6 +105,9 @@ data ExampleDependency = -- | Dependency on a language version | ExLang Language + -- | Dependency on a pkg-config package + | ExPkg (ExamplePkgName, ExamplePkgVersion) + data ExampleAvailable = ExAv { exAvName :: ExamplePkgName @@ -141,7 +145,7 @@ exDbPkgs = map (either exInstName exAvName) exAvSrcPkg :: ExampleAvailable -> SourcePackage exAvSrcPkg ex = - let (libraryDeps, testSuites, exts, mlang) = splitTopLevel (CD.libraryDeps (exAvDeps ex)) + let (libraryDeps, testSuites, exts, mlang, pcpkgs) = splitTopLevel (CD.libraryDeps (exAvDeps ex)) in SourcePackage { packageInfoId = exAvPkgId ex , packageSource = LocalTarballPackage "<>" @@ -160,7 +164,7 @@ exAvSrcPkg ex = } , C.genPackageFlags = concatMap extractFlags (CD.libraryDeps (exAvDeps ex)) - , C.condLibrary = Just $ mkCondTree (extsLib exts <> langLib mlang) libraryDeps + , C.condLibrary = Just $ mkCondTree (extsLib exts <> langLib mlang <> pcpkgLib pcpkgs) libraryDeps , C.condExecutables = [] , C.condTestSuites = map (\(t, deps) -> (t, mkCondTree mempty deps)) testSuites @@ -175,22 +179,26 @@ exAvSrcPkg ex = , [(ExampleTestName, [ExampleDependency])] , [Extension] , Maybe Language + , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config ) splitTopLevel [] = - ([], [], [], Nothing) + ([], [], [], Nothing, []) splitTopLevel (ExTest t a:deps) = - let (other, testSuites, exts, lang) = splitTopLevel deps - in (other, (t, a):testSuites, exts, lang) + let (other, testSuites, exts, lang, pcpkgs) = splitTopLevel deps + in (other, (t, a):testSuites, exts, lang, pcpkgs) splitTopLevel (ExExt ext:deps) = - let (other, testSuites, exts, lang) = splitTopLevel deps - in (other, testSuites, ext:exts, lang) + let (other, testSuites, exts, lang, pcpkgs) = splitTopLevel deps + in (other, testSuites, ext:exts, lang, pcpkgs) splitTopLevel (ExLang lang:deps) = case splitTopLevel deps of - (other, testSuites, exts, Nothing) -> (other, testSuites, exts, Just lang) + (other, testSuites, exts, Nothing, pcpkgs) -> (other, testSuites, exts, Just lang, pcpkgs) _ -> error "Only 1 Language dependency is supported" + splitTopLevel (ExPkg pkg:deps) = + let (other, testSuites, exts, lang, pcpkgs) = splitTopLevel deps + in (other, testSuites, exts, lang, pkg:pcpkgs) splitTopLevel (dep:deps) = - let (other, testSuites, exts, lang) = splitTopLevel deps - in (dep:other, testSuites, exts, lang) + let (other, testSuites, exts, lang, pcpkgs) = splitTopLevel deps + in (dep:other, testSuites, exts, lang, pcpkgs) -- Extract the total set of flags used extractFlags :: ExampleDependency -> [C.Flag] @@ -206,6 +214,7 @@ exAvSrcPkg ex = extractFlags (ExTest _ a) = concatMap extractFlags a extractFlags (ExExt _) = [] extractFlags (ExLang _) = [] + extractFlags (ExPkg _) = [] mkCondTree :: Monoid a => a -> [ExampleDependency] -> DependencyTree a mkCondTree x deps = @@ -271,6 +280,10 @@ exAvSrcPkg ex = langLib (Just lang) = mempty { C.libBuildInfo = mempty { C.defaultLanguage = Just lang } } langLib _ = mempty + -- A 'C.Library' with just the given pkgconfig-depends in its 'BuildInfo' + pcpkgLib :: [(ExamplePkgName, ExamplePkgVersion)] -> C.Library + pcpkgLib ds = mempty { C.libBuildInfo = mempty { C.pkgconfigDepends = [mkDirect (n, (Just v)) | (n,v) <- ds] } } + exAvPkgId :: ExampleAvailable -> C.PackageIdentifier exAvPkgId ex = C.PackageIdentifier { pkgName = C.PackageName (exAvName ex) @@ -302,12 +315,13 @@ exResolve :: ExampleDb -> [Extension] -- A compiler can support multiple languages. -> [Language] + -> PC.PkgConfigDb -> [ExamplePkgName] -> Bool -> ([String], Either String CI.InstallPlan.InstallPlan) -exResolve db exts langs targets indepGoals = runProgress $ +exResolve db exts langs pkgConfigDb targets indepGoals = runProgress $ resolveDependencies C.buildPlatform - compiler + compiler pkgConfigDb Modular params where diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs index e7692d41b7e..79af5d8d683 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs @@ -17,6 +17,7 @@ import Test.Tasty.Options import Language.Haskell.Extension (Extension(..), KnownExtension(..), Language(..)) -- cabal-install +import Distribution.Client.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList) import UnitTests.Distribution.Client.Dependency.Modular.DSL tests :: [TF.TestTree] @@ -85,6 +86,12 @@ tests = [ , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] Nothing , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (Just [("A",1),("B",1),("C",1)]) ] + , testGroup "Pkg-config dependencies" [ + runTest $ mkTestPCDepends [] dbPC1 "noPkgs" ["A"] Nothing + , runTest $ mkTestPCDepends [("pkgA", "0")] dbPC1 "tooOld" ["A"] Nothing + , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "1.0.0")] dbPC1 "pruneNotFound" ["C"] (Just [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "2.0.0")] dbPC1 "chooseNewest" ["C"] (Just [("A", 1), ("B", 2), ("C", 1)]) + ] ] where indep test = test { testIndepGoals = True } @@ -101,6 +108,7 @@ data SolverTest = SolverTest { , testDb :: ExampleDb , testSupportedExts :: [Extension] , testSupportedLangs :: [Language] + , testPkgConfigDb :: PkgConfigDb } mkTest :: ExampleDb @@ -108,7 +116,7 @@ mkTest :: ExampleDb -> [String] -> Maybe [(String, Int)] -> SolverTest -mkTest = mkTestExtLang [] [] +mkTest = mkTestExtLangPC [] [] [] mkTestExts :: [Extension] -> ExampleDb @@ -116,7 +124,7 @@ mkTestExts :: [Extension] -> [String] -> Maybe [(String, Int)] -> SolverTest -mkTestExts exts = mkTestExtLang exts [] +mkTestExts exts = mkTestExtLangPC exts [] [] mkTestLangs :: [Language] -> ExampleDb @@ -124,16 +132,25 @@ mkTestLangs :: [Language] -> [String] -> Maybe [(String, Int)] -> SolverTest -mkTestLangs = mkTestExtLang [] - -mkTestExtLang :: [Extension] - -> [Language] - -> ExampleDb - -> String - -> [String] - -> Maybe [(String, Int)] - -> SolverTest -mkTestExtLang exts langs db label targets result = SolverTest { +mkTestLangs langs = mkTestExtLangPC [] langs [] + +mkTestPCDepends :: [(String, String)] + -> ExampleDb + -> String + -> [String] + -> Maybe [(String, Int)] + -> SolverTest +mkTestPCDepends pkgConfigDb = mkTestExtLangPC [] [] pkgConfigDb + +mkTestExtLangPC :: [Extension] + -> [Language] + -> [(String, String)] + -> ExampleDb + -> String + -> [String] + -> Maybe [(String, Int)] + -> SolverTest +mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest { testLabel = label , testTargets = targets , testResult = result @@ -141,12 +158,13 @@ mkTestExtLang exts langs db label targets result = SolverTest { , testDb = db , testSupportedExts = exts , testSupportedLangs = langs + , testPkgConfigDb = pkgConfigDbFromList pkgConfigDb } runTest :: SolverTest -> TF.TestTree runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> testCase testLabel $ do - let (_msgs, result) = exResolve testDb testSupportedExts testSupportedLangs testTargets testIndepGoals + let (_msgs, result) = exResolve testDb testSupportedExts testSupportedLangs testPkgConfigDb testTargets testIndepGoals when showSolverLog $ mapM_ putStrLn _msgs case result of Left err -> assertBool ("Unexpected error:\n" ++ err) (isNothing testResult) @@ -403,6 +421,15 @@ dbLangs1 = [ , Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"] ] +-- | Package databases for testing @pkg-config@ dependencies. +dbPC1 :: ExampleDb +dbPC1 = [ + Right $ exAv "A" 1 [ExPkg ("pkgA", 1)] + , Right $ exAv "B" 1 [ExPkg ("pkgB", 1), ExAny "A"] + , Right $ exAv "B" 2 [ExPkg ("pkgB", 2), ExAny "A"] + , Right $ exAv "C" 1 [ExAny "B"] + ] + {------------------------------------------------------------------------------- Test options