Merge pull request #3023 from garetxe/master

Make the solver aware of pkg-config constraints

Author: 23Skidoo

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
          , RepoContext(..) )
@@ -110,11 +111,13 @@ configure verbosity packageDBs repoCtxt comp platform conf
 
   installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
   sourcePkgDb       <- getSourcePackages    verbosity repoCtxt
+  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)
@@ -269,10 +272,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)
@@ -326,7 +329,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

cabal-install/Distribution/Client/Dependency.hs

@@ -69,6 +69,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(..)
@@ -523,25 +524,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

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

cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs

@@ -27,6 +27,7 @@ import Distribution.Client.Dependency.Modular.Configured
 import Distribution.Client.Dependency.Modular.Dependency
 import Distribution.Client.Dependency.Modular.Flag
 import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Dependency.Modular.Version
 
 -- | A (partial) package assignment. Qualified package names
 -- are associated with instances.
@@ -62,9 +63,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
@@ -75,6 +77,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

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)

cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs

@@ -198,6 +198,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)
 
 showDep :: Dep QPN -> String
@@ -210,6 +211,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')
 --
@@ -253,6 +257,7 @@ qualifyDeps QO{..} (Q pp' pn) = go
     goD :: Dep PN -> Component -> Dep QPN
     goD (Ext  ext)    _    = Ext  ext
     goD (Lang lang)   _    = Lang lang
+    goD (Pkg pkn vr)  _    = Pkg pkn vr
     goD (Dep  dep ci) comp
       | qBase  dep  = Dep (Q (Base  pn pp) dep) (fmap (Q pp) ci)
       | qSetup comp = Dep (Q (Setup pn pp) dep) (fmap (Q pp) ci)
@@ -337,6 +342,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
@@ -376,6 +382,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
 

cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs

@@ -143,6 +143,7 @@ convCondTree os arch cinfo pi@(PI pn _) fds comp getInfo (CondNode info ds branc
                  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 comp getInfo) branches
   where
     bi = getInfo info

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

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
@@ -60,11 +62,12 @@ data SolverConfig = SolverConfig {
 solve :: SolverConfig ->                      -- ^ solver parameters
          CompilerInfo ->
          Index ->                             -- ^ all available packages as an index
+         PkgConfigDb ->                       -- ^ available pkg-config pkgs
          (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     $
   detectCyclesPhase$
   heuristicsPhase  $
@@ -86,7 +89,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"

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