Port solver fixes from master into 1.24

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)
@@ -280,10 +283,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)
@@ -337,7 +340,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(..)
@@ -553,25 +554,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,19 +63,23 @@ 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
-       -> Goal QPN
+       -> (PN -> VR  -> Bool) -- ^ is a given pkg-config requirement satisfiable
+       -> Var QPN
        -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment
-extend extSupported langSupported goal@(Goal var _) = foldM extendSingle
+extend extSupported langSupported pkgPresent var = foldM extendSingle
   where
 
     extendSingle :: PPreAssignment -> Dep QPN
                  -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment
     extendSingle a (Ext  ext )  =
       if extSupported  ext  then Right a
-                            else Left (toConflictSet goal, [Ext ext])
+                            else Left (varToConflictSet var, [Ext ext])
     extendSingle a (Lang lang)  =
       if langSupported lang then Right a
-                            else Left (toConflictSet goal, [Lang lang])
+                            else Left (varToConflictSet var, [Lang lang])
+    extendSingle a (Pkg pn vr)  =
+      if pkgPresent pn vr then Right a
+                          else Left (varToConflictSet var, [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
@@ -85,9 +90,9 @@ extend extSupported langSupported goal@(Goal var _) = foldM extendSingle
     -- making a choice pkg == instance, and pkg => pkg == instance is a part
     -- of the conflict, then this info is clear from the context and does not
     -- have to be repeated.
-    simplify v (Fixed _ (Goal var' _)) c | v == var && var' == var = [c]
-    simplify v c (Fixed _ (Goal var' _)) | v == var && var' == var = [c]
-    simplify _ c                       d                           = [c, d]
+    simplify v (Fixed _ var') c | v == var && var' == var = [c]
+    simplify v c (Fixed _ var') | v == var && var' == var = [c]
+    simplify _ c              d                           = [c, d]
 
 -- | Delivers an ordered list of fully configured packages.
 --

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

@@ -61,12 +61,13 @@ 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
 
 -- | Given the current scope, qualify all the package names in the given set of
 -- dependencies and then extend the set of open goals accordingly.
-scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps Component PN -> FlagInfo ->
+scopedExtendOpen :: QPN -> I -> QGoalReason -> FlaggedDeps Component PN -> FlagInfo ->
                     BuildState -> BuildState
 scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s
   where
@@ -96,13 +97,13 @@ scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s
 data BuildType =
     Goals                                  -- ^ build a goal choice node
   | OneGoal (OpenGoal ())                  -- ^ build a node for this goal
-  | Instance QPN I PInfo QGoalReasonChain  -- ^ build a tree for a concrete instance
+  | Instance QPN I PInfo QGoalReason  -- ^ build a tree for a concrete instance
   deriving Show
 
-build :: BuildState -> Tree QGoalReasonChain
+build :: BuildState -> Tree QGoalReason
 build = ana go
   where
-    go :: BuildState -> TreeF QGoalReasonChain BuildState
+    go :: BuildState -> TreeF QGoalReason BuildState
 
     -- If we have a choice between many goals, we just record the choice in
     -- the tree. We select each open goal in turn, and before we descend, remove
@@ -121,9 +122,16 @@ 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) }) =
+      -- If the package does not exist in the index, we construct an emty PChoiceF node for it
+      -- After all, we have no choices here. Alternatively, we could immediately construct
+      -- a Fail node here, but that would complicate the construction of conflict sets.
+      -- We will probably want to give this case special treatment when generating error
+      -- messages though.
       case M.lookup pn idx of
-        Nothing  -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn)
+        Nothing  -> PChoiceF qpn gr (P.fromList [])
         Just pis -> PChoiceF qpn gr (P.fromList (L.map (\ (i, info) ->
                                                            (POption i Nothing, bs { next = Instance qpn i info gr }))
                                                          (M.toList pis)))
@@ -135,8 +143,8 @@ build = ana go
     -- TODO: Should we include the flag default in the tree?
     go bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
       FChoiceF qfn gr (w || trivial) m (P.fromList (reorder b
-        [(True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True  : gr)) t) bs) { next = Goals }),
-         (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })]))
+        [(True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }),
+         (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })]))
       where
         reorder True  = id
         reorder False = reverse
@@ -149,22 +157,22 @@ build = ana go
 
     go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
       SChoiceF qsn gr trivial (P.fromList
-        [(False,                                                                  bs  { next = Goals }),
-         (True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })])
+        [(False,                                                             bs  { next = Goals }),
+         (True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])
       where
         trivial = L.null t
 
     -- For a particular instance, we change the state: we update the scope,
     -- and furthermore we update the set of goals.
     --
     -- TODO: We could inline this above.
-    go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) gr }) =
-      go ((scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs)
+    go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) _gr }) =
+      go ((scopedExtendOpen qpn i (PDependency (PI qpn i)) fdeps fdefs bs)
              { next = Goals })
 
 -- | Interface to the tree builder. Just takes an index and a list of package names,
 -- and computes the initial state and then the tree from there.
-buildTree :: Index -> Bool -> [PN] -> Tree QGoalReasonChain
+buildTree :: Index -> Bool -> [PN] -> Tree QGoalReason
 buildTree idx ind igs =
     build BS {
         index = idx
@@ -174,7 +182,7 @@ buildTree idx ind igs =
       , qualifyOptions = defaultQualifyOptions idx
       }
   where
-    topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) [UserGoal]
+    topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) UserGoal
 
     qpns | ind       = makeIndependent igs
          | otherwise = L.map (Q (PP DefaultNamespace Unqualified)) igs

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

@@ -0,0 +1,74 @@
+{-# LANGUAGE CPP #-}
+-- | Conflict sets
+--
+-- Intended for double import
+--
+-- > import Distribution.Client.Dependency.Modular.ConflictSet (ConflictSet)
+-- > import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS
+module Distribution.Client.Dependency.Modular.ConflictSet (
+    ConflictSet -- opaque
+  , showCS
+    -- Set-like operations
+  , toList
+  , union
+  , unions
+  , insert
+  , empty
+  , singleton
+  , member
+  , filter
+  , fromList
+  ) where
+
+import Prelude hiding (filter)
+import Data.List (intercalate)
+import Data.Set (Set)
+import qualified Data.Set as S
+
+import Distribution.Client.Dependency.Modular.Package
+import Distribution.Client.Dependency.Modular.Var
+
+-- | The set of variables involved in a solver conflict
+--
+-- Since these variables should be preprocessed in some way, this type is
+-- kept abstract.
+newtype ConflictSet qpn = CS { fromConflictSet :: Set (Var qpn) }
+  deriving (Eq, Ord, Show)
+
+showCS :: ConflictSet QPN -> String
+showCS = intercalate ", " . map showVar . toList
+
+{-------------------------------------------------------------------------------
+  Set-like operations
+-------------------------------------------------------------------------------}
+
+toList :: ConflictSet qpn -> [Var qpn]
+toList = S.toList . fromConflictSet
+
+union :: Ord qpn => ConflictSet qpn -> ConflictSet qpn -> ConflictSet qpn
+union (CS a) (CS b) = CS (a `S.union` b)
+
+unions :: Ord qpn => [ConflictSet qpn] -> ConflictSet qpn
+unions = CS . S.unions . map fromConflictSet
+
+insert :: Ord qpn => Var qpn -> ConflictSet qpn -> ConflictSet qpn
+insert var (CS set) = CS (S.insert (simplifyVar var) set)
+
+empty :: ConflictSet qpn
+empty = CS S.empty
+
+singleton :: Var qpn -> ConflictSet qpn
+singleton = CS . S.singleton . simplifyVar
+
+member :: Ord qpn => Var qpn -> ConflictSet qpn -> Bool
+member var (CS set) = S.member (simplifyVar var) set
+
+#if MIN_VERSION_containers(0,5,0)
+filter :: (Var qpn -> Bool) -> ConflictSet qpn -> ConflictSet qpn
+#else
+filter :: Ord qpn => (Var qpn -> Bool) -> ConflictSet qpn -> ConflictSet qpn
+#endif
+filter p (CS set) = CS $ S.filter p set
+
+fromList :: Ord qpn => [Var qpn] -> ConflictSet qpn
+fromList = CS . S.fromList . map simplifyVar