Fix #6290: gen-bounds: do not report empty set of generated bounds

Author: andreasabel

cabal-install/src/Distribution/Client/GenBounds.hs

@@ -19,7 +19,7 @@ import Prelude ()
 import Distribution.Client.Compat.Prelude
 
 import Distribution.Client.Utils
-         ( incVersion )
+         ( hasElem, incVersion )
 import Distribution.Client.Freeze
          ( getFreezePkgs )
 import Distribution.Client.Setup
@@ -106,33 +106,29 @@ genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeF
     case epd of
       Left _ -> putStrLn "finalizePD failed"
       Right (pd,_) -> do
-        let needBounds = filter (not . hasUpperBound . depVersion) $
+       let needBounds = map depName $ filter (not . hasUpperBound . depVersion) $
                          enabledBuildDepends pd defaultComponentRequestedSpec
 
-        if (null needBounds)
-          then putStrLn
-               "Congratulations, all your dependencies have upper bounds!"
-          else go needBounds
-  where
-     go needBounds = do
        pkgs  <- getFreezePkgs
                   verbosity packageDBs repoCtxt comp platform progdb
                   globalFlags freezeFlags
 
-       putStrLn boundsNeededMsg
-
-       let isNeeded pkg = unPackageName (packageName pkg)
-                          `elem` map depName needBounds
+       let isNeeded = hasElem needBounds . unPackageName . packageName
        let thePkgs = filter isNeeded pkgs
 
        let padTo = maximum $ map (length . unPackageName . packageName) pkgs
-       traverse_ (putStrLn . (++",") . showBounds padTo) thePkgs
 
-     depName :: Dependency -> String
-     depName (Dependency pn _ _) = unPackageName pn
+       if null thePkgs then putStrLn
+         "Congratulations, all your dependencies have upper bounds!"
+        else do
+         putStrLn boundsNeededMsg
+         traverse_ (putStrLn . (++",") . showBounds padTo) thePkgs
+
+depName :: Dependency -> String
+depName (Dependency pn _ _) = unPackageName pn
 
-     depVersion :: Dependency -> VersionRange
-     depVersion (Dependency _ vr _) = vr
+depVersion :: Dependency -> VersionRange
+depVersion (Dependency _ vr _) = vr
 
 -- | The message printed when some dependencies are found to be lacking proper
 -- PVP-mandated bounds.

cabal-install/src/Distribution/Client/Utils.hs

@@ -28,6 +28,7 @@ module Distribution.Client.Utils
   , listFilesRecursive
   , listFilesInside
   , safeRead
+  , hasElem
   ) where
 
 import Prelude ()
@@ -73,7 +74,7 @@ import Data.Time.Calendar (toGregorian)
 import qualified System.Directory as Dir
 import qualified System.IO.Error as IOError
 #endif
-
+import qualified Data.Set as Set
 
 -- | Generic merging utility. For sorted input lists this is a full outer join.
 --
@@ -478,3 +479,9 @@ safeRead :: Read a => String -> Maybe a
 safeRead s
   | [(x, "")] <- reads s = Just x
   | otherwise = Nothing
+
+
+-- | @hasElem xs x = elem x xs@ except that @xs@ is turned into a 'Set' first.
+--   Use underapplied to speed up subsequent lookups, e.g. @filter (hasElem xs) ys@.
+hasElem :: Ord a => [a] -> a -> Bool
+hasElem xs = (`Set.member` Set.fromList xs)

cabal-testsuite/PackageTests/GenBounds/Issue6290/Main.hs

@@ -0,0 +1,3 @@
+module Main where
+
+main = putStrLn "Issue 6290."

cabal-testsuite/PackageTests/GenBounds/Issue6290/cabal.out

@@ -0,0 +1,2 @@
+# cabal gen-bounds
+Resolving dependencies...

cabal-testsuite/PackageTests/GenBounds/Issue6290/cabal.test.hs

@@ -0,0 +1,3 @@
+import Test.Cabal.Prelude
+
+main = cabalTest $ cabal "gen-bounds" []

cabal-testsuite/PackageTests/GenBounds/Issue6290/pkg.cabal

@@ -0,0 +1,11 @@
+cabal-version:       2.4
+name:                pkg
+version:             0.0.0.0
+
+library lib
+  build-depends:
+    base >= 4 && < 5
+
+executable exec
+  main-is:       Main.hs
+  build-depends: lib

cabal-testsuite/src/Test/Cabal/Prelude.hs

@@ -287,6 +287,7 @@ cabalGArgs global_args cmd args input = do
               , "man"
               , "v1-freeze"
               , "check"
+              , "gen-bounds"
               , "get", "unpack"
               , "info"
               , "init"