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

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
@@ -40,7 +40,7 @@ import Distribution.Simple.PackageDescription
 import Distribution.Simple.Program
          ( ProgramDb )
 import Distribution.Simple.Utils
-         ( tryFindPackageDesc )
+         ( notice, tryFindPackageDesc )
 import Distribution.System
          ( Platform )
 import Distribution.Version
@@ -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 notice verbosity
+         "Congratulations, all your dependencies have upper bounds!"
+        else do
+         notice verbosity boundsNeededMsg
+         traverse_ (notice verbosity . (++",") . 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.
 --
@@ -145,9 +146,7 @@ withEnv :: String -> String -> IO a -> IO a
 withEnv k v m = do
   mb_old <- lookupEnv k
   setEnv k v
-  m `Exception.finally` (case mb_old of
-    Nothing -> unsetEnv k
-    Just old -> setEnv k old)
+  m `Exception.finally` setOrUnsetEnv k mb_old
 
 -- | Executes the action with a list of environment variables and
 -- corresponding overrides, where
@@ -160,15 +159,15 @@ withEnv k v m = do
 withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a
 withEnvOverrides overrides m = do
   mb_olds <- traverse lookupEnv envVars
-  traverse_ (uncurry update) overrides
-  m `Exception.finally` zipWithM_ update envVars mb_olds
+  traverse_ (uncurry setOrUnsetEnv) overrides
+  m `Exception.finally` zipWithM_ setOrUnsetEnv envVars mb_olds
    where
     envVars :: [String]
     envVars = map fst overrides
 
-    update :: String -> Maybe FilePath -> IO ()
-    update var Nothing    = unsetEnv var
-    update var (Just val) = setEnv var val
+setOrUnsetEnv :: String -> Maybe String -> IO ()
+setOrUnsetEnv var Nothing    = unsetEnv var
+setOrUnsetEnv var (Just val) = setEnv var val
 
 -- | Executes the action, increasing the PATH environment
 -- in some way
@@ -433,7 +432,7 @@ getCurrentYear = do
 -- | From System.Directory.Extra
 --   https://hackage.haskell.org/package/extra-1.7.9
 listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]
-listFilesInside test dir = ifM (notM $ test $ dropTrailingPathSeparator dir) (pure []) $ do
+listFilesInside test dir = ifNotM (test $ dropTrailingPathSeparator dir) (pure []) $ do
     (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir
     rest <- concatMapM (listFilesInside test) dirs
     pure $ files ++ rest
@@ -455,6 +454,11 @@ listContents dir = do
 ifM :: Monad m => m Bool -> m a -> m a -> m a
 ifM b t f = do b' <- b; if b' then t else f
 
+-- | 'ifM' with swapped branches:
+--   @ifNotM b t f = ifM (not <$> b) t f@
+ifNotM :: Monad m => m Bool -> m a -> m a -> m a
+ifNotM = flip . ifM
+
 -- | From Control.Monad.Extra
 --   https://hackage.haskell.org/package/extra-1.7.9
 concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
@@ -471,12 +475,18 @@ partitionM f (x:xs) = do
     (as,bs) <- partitionM f xs
     pure ([x | res]++as, [x | not res]++bs)
 
--- | From Control.Monad.Extra
---   https://hackage.haskell.org/package/extra-1.7.9
-notM :: Functor m => m Bool -> m Bool
-notM = fmap not
-
 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@.
+--   Only amortized when used several times!
+--
+--   Time complexity \(O((n+m) \log(n))\) for \(m\) lookups in a list of length \(n\).
+--   (Compare this to 'elem''s \(O(nm)\).)
+--
+--   This is [Agda.Utils.List.hasElem](https://hackage.haskell.org/package/Agda-2.6.2.2/docs/Agda-Utils-List.html#v:hasElem).
+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,3 @@
+# cabal gen-bounds
+Resolving dependencies...
+Congratulations, all your dependencies have upper bounds!

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"