diff --git a/cabal-install/src/Distribution/Client/GenBounds.hs b/cabal-install/src/Distribution/Client/GenBounds.hs index 715425fc98f..d82387cc015 100644 --- a/cabal-install/src/Distribution/Client/GenBounds.hs +++ b/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. diff --git a/cabal-install/src/Distribution/Client/Utils.hs b/cabal-install/src/Distribution/Client/Utils.hs index 849bdd88140..c427c310370 100644 --- a/cabal-install/src/Distribution/Client/Utils.hs +++ b/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) diff --git a/cabal-testsuite/PackageTests/GenBounds/Issue6290/Main.hs b/cabal-testsuite/PackageTests/GenBounds/Issue6290/Main.hs new file mode 100644 index 00000000000..65734b97990 --- /dev/null +++ b/cabal-testsuite/PackageTests/GenBounds/Issue6290/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "Issue 6290." diff --git a/cabal-testsuite/PackageTests/GenBounds/Issue6290/cabal.out b/cabal-testsuite/PackageTests/GenBounds/Issue6290/cabal.out new file mode 100644 index 00000000000..08a8512a6df --- /dev/null +++ b/cabal-testsuite/PackageTests/GenBounds/Issue6290/cabal.out @@ -0,0 +1,3 @@ +# cabal gen-bounds +Resolving dependencies... +Congratulations, all your dependencies have upper bounds! diff --git a/cabal-testsuite/PackageTests/GenBounds/Issue6290/cabal.test.hs b/cabal-testsuite/PackageTests/GenBounds/Issue6290/cabal.test.hs new file mode 100644 index 00000000000..6340d52d3ec --- /dev/null +++ b/cabal-testsuite/PackageTests/GenBounds/Issue6290/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude + +main = cabalTest $ cabal "gen-bounds" [] diff --git a/cabal-testsuite/PackageTests/GenBounds/Issue6290/pkg.cabal b/cabal-testsuite/PackageTests/GenBounds/Issue6290/pkg.cabal new file mode 100644 index 00000000000..4fc3027ee80 --- /dev/null +++ b/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 diff --git a/cabal-testsuite/src/Test/Cabal/Prelude.hs b/cabal-testsuite/src/Test/Cabal/Prelude.hs index 355a2a9de1e..2ebe7e5b5cb 100644 --- a/cabal-testsuite/src/Test/Cabal/Prelude.hs +++ b/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"