Backport 3.12: Show installed versions when configuring fails

Cabal-syntax/Cabal-syntax.cabal

@@ -133,6 +133,7 @@ library
     Distribution.Types.ConfVar
     Distribution.Types.Dependency
     Distribution.Types.DependencyMap
+    Distribution.Types.DependencySatisfaction
     Distribution.Types.ExeDependency
     Distribution.Types.Executable
     Distribution.Types.Executable.Lens
@@ -156,6 +157,8 @@ library
     Distribution.Types.Library.Lens
     Distribution.Types.LibraryName
     Distribution.Types.LibraryVisibility
+    Distribution.Types.MissingDependency
+    Distribution.Types.MissingDependencyReason
     Distribution.Types.Mixin
     Distribution.Types.Module
     Distribution.Types.ModuleReexport

Cabal-syntax/src/Distribution/Compat/NonEmptySet.hs

@@ -12,6 +12,7 @@ module Distribution.Compat.NonEmptySet
 
     -- * Deletion
   , delete
+  , filter
 
     -- * Conversions
   , toNonEmpty
@@ -119,6 +120,9 @@ delete x (NES xs)
   where
     res = Set.delete x xs
 
+filter :: (a -> Bool) -> NonEmptySet a -> Set.Set a
+filter predicate (NES set) = Set.filter predicate set
+
 -------------------------------------------------------------------------------
 -- Conversions
 -------------------------------------------------------------------------------

Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs

@@ -56,12 +56,13 @@ import Distribution.System
 import Distribution.Types.Component
 import Distribution.Types.ComponentRequestedSpec
 import Distribution.Types.DependencyMap
+import Distribution.Types.DependencySatisfaction (DependencySatisfaction (..))
+import Distribution.Types.MissingDependency (MissingDependency (..))
 import Distribution.Types.PackageVersionConstraint
 import Distribution.Utils.Generic
 import Distribution.Utils.Path
 import Distribution.Version
 
-import qualified Data.Map.Lazy as Map
 import Data.Tree (Tree (Node))
 
 ------------------------------------------------------------------------------
@@ -144,15 +145,17 @@ parseCondition = condOr
 
 ------------------------------------------------------------------------------
 
--- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for
+-- | Result of dependency test. Isomorphic to @Maybe@ but renamed for
 --   clarity.
-data DepTestRslt d = DepOk | MissingDeps d
+data DepTestRslt
+  = DepOk
+  | MissingDeps [MissingDependency]
 
-instance Semigroup d => Monoid (DepTestRslt d) where
+instance Monoid DepTestRslt where
   mempty = DepOk
   mappend = (<>)
 
-instance Semigroup d => Semigroup (DepTestRslt d) where
+instance Semigroup DepTestRslt where
   DepOk <> x = x
   x <> DepOk = x
   (MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d')
@@ -190,13 +193,13 @@ resolveWithFlags
   -> [PackageVersionConstraint]
   -- ^ Additional constraints
   -> [CondTree ConfVar [Dependency] PDTagged]
-  -> ([Dependency] -> DepTestRslt [Dependency])
+  -> ([Dependency] -> DepTestRslt)
   -- ^ Dependency test function.
-  -> Either [Dependency] (TargetSet PDTagged, FlagAssignment)
+  -> Either [MissingDependency] (TargetSet PDTagged, FlagAssignment)
   -- ^ Either the missing dependencies (error case), or a pair of
   -- (set of build targets with dependencies, chosen flag assignments)
 resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
-  either (Left . fromDepMapUnion) Right $ explore (build mempty dom)
+  explore (build mempty dom)
   where
     -- simplify trees by (partially) evaluating all conditions and converting
     -- dependencies to dependency maps.
@@ -216,7 +219,7 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
     -- computation overhead in the successful case.
     explore
       :: Tree FlagAssignment
-      -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment)
+      -> Either [MissingDependency] (TargetSet PDTagged, FlagAssignment)
     explore (Node flags ts) =
       let targetSet =
             TargetSet $
@@ -229,7 +232,7 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
             DepOk
               | null ts -> Right (targetSet, flags)
               | otherwise -> tryAll $ map explore ts
-            MissingDeps mds -> Left (toDepMapUnion mds)
+            MissingDeps mds -> Left mds
 
     -- Builds a tree of all possible flag assignments.  Internal nodes
     -- have only partial assignments.
@@ -238,18 +241,18 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
     build assigned ((fn, vals) : unassigned) =
       Node assigned $ map (\v -> build (insertFlagAssignment fn v assigned) unassigned) vals
 
-    tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a
+    tryAll :: Monoid a => [Either a b] -> Either a b
     tryAll = foldr mp mz
 
     -- special version of `mplus' for our local purposes
-    mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a
+    mp :: Monoid a => Either a b -> Either a b -> Either a b
     mp m@(Right _) _ = m
     mp _ m@(Right _) = m
     mp (Left xs) (Left ys) = Left (xs <> ys)
 
     -- `mzero'
-    mz :: Either DepMapUnion a
-    mz = Left (DepMapUnion Map.empty)
+    mz :: Monoid a => Either a b
+    mz = Left mempty
 
     env :: FlagAssignment -> FlagName -> Either FlagName Bool
     env flags flag = (maybe (Left flag) Right . lookupFlagAssignment flag) flags
@@ -323,27 +326,6 @@ extractConditions f gpkg =
     , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg
     ]
 
--- | A map of package constraints that combines version ranges using 'unionVersionRanges'.
-newtype DepMapUnion = DepMapUnion {unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName)}
-
-instance Semigroup DepMapUnion where
-  DepMapUnion x <> DepMapUnion y =
-    DepMapUnion $
-      Map.unionWith unionVersionRanges' x y
-
-unionVersionRanges'
-  :: (VersionRange, NonEmptySet LibraryName)
-  -> (VersionRange, NonEmptySet LibraryName)
-  -> (VersionRange, NonEmptySet LibraryName)
-unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs')
-
-toDepMapUnion :: [Dependency] -> DepMapUnion
-toDepMapUnion ds =
-  DepMapUnion $ Map.fromListWith unionVersionRanges' [(p, (vr, cs)) | Dependency p vr cs <- ds]
-
-fromDepMapUnion :: DepMapUnion -> [Dependency]
-fromDepMapUnion m = [Dependency p vr cs | (p, (vr, cs)) <- Map.toList (unDepMapUnion m)]
-
 freeVars :: CondTree ConfVar c a -> [FlagName]
 freeVars t = [f | PackageFlag f <- freeVars' t]
   where
@@ -453,7 +435,7 @@ finalizePD
   :: FlagAssignment
   -- ^ Explicitly specified flag assignments
   -> ComponentRequestedSpec
-  -> (Dependency -> Bool)
+  -> (Dependency -> DependencySatisfaction)
   -- ^ Is a given dependency satisfiable from the set of
   -- available packages?  If this is unknown then use
   -- True.
@@ -465,7 +447,7 @@ finalizePD
   -- ^ Additional constraints
   -> GenericPackageDescription
   -> Either
-      [Dependency]
+      [MissingDependency]
       (PackageDescription, FlagAssignment)
   -- ^ Either missing dependencies or the resolved package
   -- description along with the flag assignments chosen.
@@ -526,7 +508,11 @@ finalizePD
           | otherwise -> [b, not b]
       -- flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices
       check ds =
-        let missingDeps = filter (not . satisfyDep) ds
+        let missingDeps =
+              [ MissingDependency dependency reason
+              | (dependency, Unsatisfied reason) <-
+                  map (\dependency -> (dependency, satisfyDep dependency)) ds
+              ]
          in if null missingDeps
               then DepOk
               else MissingDeps missingDeps

Cabal-syntax/src/Distribution/Pretty.hs

@@ -10,6 +10,8 @@ module Distribution.Pretty
   , showTokenStr
   , showFreeText
   , showFreeTextV3
+  , commaSpaceSep
+  , commaSep
 
     -- * Deprecated
   , Separator
@@ -118,3 +120,11 @@ lines_ s =
    in l : case s' of
         [] -> []
         (_ : s'') -> lines_ s''
+
+-- | Separate a list of documents by commas and spaces.
+commaSpaceSep :: Pretty a => [a] -> PP.Doc
+commaSpaceSep = PP.hsep . PP.punctuate PP.comma . map pretty
+
+-- | Separate a list of documents by commas.
+commaSep :: Pretty a => [a] -> PP.Doc
+commaSep = PP.hcat . PP.punctuate PP.comma . map pretty

Cabal-syntax/src/Distribution/Types/Dependency.hs

@@ -78,31 +78,21 @@ instance NFData Dependency where rnf = genericRnf
 -- "pkg"
 --
 -- >>> prettyShow $ Dependency (mkPackageName "pkg") anyVersion $ NES.insert (LSubLibName $ mkUnqualComponentName "sublib") mainLibSet
--- "pkg:{pkg, sublib}"
+-- "pkg:{pkg,sublib}"
 --
 -- >>> prettyShow $ Dependency (mkPackageName "pkg") anyVersion $ NES.singleton (LSubLibName $ mkUnqualComponentName "sublib")
 -- "pkg:sublib"
 --
 -- >>> prettyShow $ Dependency (mkPackageName "pkg") anyVersion $ NES.insert (LSubLibName $ mkUnqualComponentName "sublib-b") $ NES.singleton (LSubLibName $ mkUnqualComponentName "sublib-a")
--- "pkg:{sublib-a, sublib-b}"
+-- "pkg:{sublib-a,sublib-b}"
 instance Pretty Dependency where
-  pretty (Dependency name ver sublibs) = withSubLibs (pretty name) <+> pver
+  pretty (Dependency name ver sublibs) = prettyLibraryNames name (NES.toNonEmpty sublibs) <+> pver
     where
       -- TODO: change to isAnyVersion after #6736
       pver
         | isAnyVersionLight ver = PP.empty
         | otherwise = pretty ver
 
-      withSubLibs doc = case NES.toList sublibs of
-        [LMainLibName] -> doc
-        [LSubLibName uq] -> doc <<>> PP.colon <<>> pretty uq
-        _ -> doc <<>> PP.colon <<>> PP.braces prettySublibs
-
-      prettySublibs = PP.hsep $ PP.punctuate PP.comma $ prettySublib <$> NES.toList sublibs
-
-      prettySublib LMainLibName = PP.text $ unPackageName name
-      prettySublib (LSubLibName un) = PP.text $ unUnqualComponentName un
-
 -- |
 --
 -- >>> simpleParsec "mylib:sub" :: Maybe Dependency

Cabal-syntax/src/Distribution/Types/DependencySatisfaction.hs

@@ -0,0 +1,14 @@
+module Distribution.Types.DependencySatisfaction
+  ( DependencySatisfaction (..)
+  ) where
+
+import Distribution.Types.MissingDependencyReason (MissingDependencyReason)
+
+-- | Whether or not a dependency constraint is satisfied.
+data DependencySatisfaction
+  = -- | The dependency constraint is satisfied.
+    Satisfied
+  | -- | The dependency constraint is not satisfied.
+    --
+    -- Includes a reason for explanation.
+    Unsatisfied MissingDependencyReason

Cabal-syntax/src/Distribution/Types/LibraryName.hs

@@ -10,6 +10,7 @@ module Distribution.Types.LibraryName
   , libraryNameString
 
     -- * Pretty & Parse
+  , prettyLibraryNames
   , prettyLibraryNameComponent
   , parsecLibraryNameComponent
   ) where
@@ -21,6 +22,7 @@ import Distribution.Parsec
 import Distribution.Pretty
 import Distribution.Types.UnqualComponentName
 
+import qualified Data.List.NonEmpty as NEL
 import qualified Distribution.Compat.CharParsing as P
 import qualified Text.PrettyPrint as Disp
 
@@ -42,6 +44,22 @@ prettyLibraryNameComponent :: LibraryName -> Disp.Doc
 prettyLibraryNameComponent LMainLibName = Disp.text "lib"
 prettyLibraryNameComponent (LSubLibName str) = Disp.text "lib:" <<>> pretty str
 
+-- | Pretty print a 'LibraryName' after a package name.
+--
+-- Produces output like @foo@, @foo:bar@, or @foo:{bar,baz}@
+prettyLibraryNames :: Pretty a => a -> NonEmpty LibraryName -> Disp.Doc
+prettyLibraryNames package libraries =
+  let doc = pretty package
+
+      prettyComponent LMainLibName = pretty package
+      prettyComponent (LSubLibName component) = Disp.text $ unUnqualComponentName component
+
+      prettyComponents = commaSep $ prettyComponent <$> NEL.toList libraries
+   in case libraries of
+        LMainLibName :| [] -> doc
+        LSubLibName component :| [] -> doc <<>> Disp.colon <<>> pretty component
+        _ -> doc <<>> Disp.colon <<>> Disp.braces prettyComponents
+
 parsecLibraryNameComponent :: CabalParsing m => m LibraryName
 parsecLibraryNameComponent = do
   _ <- P.string "lib"

Cabal-syntax/src/Distribution/Types/MissingDependency.hs

@@ -0,0 +1,34 @@
+module Distribution.Types.MissingDependency
+  ( MissingDependency (..)
+  ) where
+
+import Distribution.Compat.Prelude
+import Distribution.Pretty
+import Distribution.Types.Dependency
+  ( Dependency
+  , simplifyDependency
+  )
+import Distribution.Types.LibraryName
+  ( prettyLibraryNames
+  )
+import Distribution.Types.MissingDependencyReason
+  ( MissingDependencyReason (..)
+  )
+
+import qualified Text.PrettyPrint as PP
+
+-- | A missing dependency and information on why it's missing.
+data MissingDependency = MissingDependency Dependency MissingDependencyReason
+  deriving (Show)
+
+instance Pretty MissingDependency where
+  pretty (MissingDependency dependency reason) =
+    let prettyReason =
+          case reason of
+            MissingLibrary libraries ->
+              PP.text "missing" <+> prettyLibraryNames PP.empty libraries
+            MissingPackage -> PP.text "missing"
+            MissingComponent name -> PP.text "missing component" <+> pretty name
+            WrongVersion versions ->
+              PP.text "installed:" <+> commaSpaceSep versions
+     in pretty (simplifyDependency dependency) <+> PP.parens prettyReason

Cabal-syntax/src/Distribution/Types/MissingDependencyReason.hs

@@ -0,0 +1,25 @@
+module Distribution.Types.MissingDependencyReason
+  ( MissingDependencyReason (..)
+  ) where
+
+import Data.List.NonEmpty (NonEmpty)
+import Distribution.Types.LibraryName (LibraryName)
+import Distribution.Types.PackageName (PackageName)
+import Distribution.Types.Version (Version)
+
+-- | A reason for a depency failing to solve.
+--
+-- This helps pinpoint dependencies that are installed with an incorrect
+-- version vs. dependencies that are not installed at all.
+data MissingDependencyReason
+  = -- | One or more libraries is missing.
+    MissingLibrary (NonEmpty LibraryName)
+  | -- | A package is not installed.
+    MissingPackage
+  | -- | A package is installed, but the versions don't match.
+    --
+    -- Contains the available versions.
+    WrongVersion [Version]
+  | -- | A component is not installed.
+    MissingComponent PackageName
+  deriving (Show)

Cabal-tests/tests/ParserTests/regressions/issue-5846.format

@@ -5,7 +5,7 @@ version:       5846
 library
     default-language: Haskell2010
     build-depends:
-        lib1:{a, b},
+        lib1:{a,b},
         lib2:c,
         lib3:d >=1,
-        lib4:{a, b} >=1
+        lib4:{a,b} >=1

Cabal/Cabal.cabal

@@ -241,6 +241,7 @@ library
     Distribution.Types.ConfVar,
     Distribution.Types.Dependency,
     Distribution.Types.DependencyMap,
+    Distribution.Types.DependencySatisfaction,
     Distribution.Types.ExeDependency,
     Distribution.Types.Executable,
     Distribution.Types.Executable.Lens,
@@ -264,6 +265,8 @@ library
     Distribution.Types.Library.Lens,
     Distribution.Types.LibraryName,
     Distribution.Types.LibraryVisibility,
+    Distribution.Types.MissingDependency,
+    Distribution.Types.MissingDependencyReason,
     Distribution.Types.Mixin,
     Distribution.Types.Module,
     Distribution.Types.ModuleReexport,