Move --allow-{newer,older} back to ./Setup.hs

Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs

@@ -29,8 +29,8 @@ tests = testGroup "Distribution.Utils.Structured"
     , testCase "GenericPackageDescription" $
       md5Check (Proxy :: Proxy GenericPackageDescription) 0xc7d1064aaf2c9bcf92c3d7f23e6d7e94
     , testCase "LocalBuildInfo" $
-      md5Check (Proxy :: Proxy LocalBuildInfo) 0x0324f420f9fb98417098127a414cc7c0
-#endif
+      md5Check (Proxy :: Proxy LocalBuildInfo) 0xf6adad996a4bd3746405c2b7abf49fc6
+#endif 
     ]
 
 -- -------------------------------------------------------------------- --

Cabal/Cabal.cabal

@@ -60,6 +60,7 @@ library
     ghc-options: -Wnoncanonical-monadfail-instances
 
   exposed-modules:
+    Distribution.AllowNewer
     Distribution.Backpack.Configure
     Distribution.Backpack.ComponentsGraph
     Distribution.Backpack.ConfiguredComponent
@@ -140,6 +141,7 @@ library
     Distribution.Simple.UserHooks
     Distribution.Simple.Utils
     Distribution.TestSuite
+    Distribution.Types.AllowNewer
     Distribution.Types.AnnotatedId
     Distribution.Types.ComponentInclude
     Distribution.Types.DumpBuildInfo

Cabal/src/Distribution/AllowNewer.hs

@@ -0,0 +1,71 @@
+-----------------------------------------------------------------------------
+
+-- | Utilities to relax version bounds on dependencies
+module Distribution.AllowNewer
+  ( relaxPackageDeps
+  , RelaxKind (..)
+  ) where
+
+import Distribution.Compat.Prelude
+
+import Distribution.Package
+  ( Package (..)
+  , packageName
+  )
+import qualified Distribution.PackageDescription as PD
+import qualified Distribution.PackageDescription.Configuration as PD
+import Distribution.Types.Dependency
+import Distribution.Version
+
+import qualified Data.Map as Map
+import Distribution.Types.AllowNewer
+
+data RelaxKind = RelaxLower | RelaxUpper
+
+-- | Relax the dependencies of this package if needed.
+--
+-- Helper function used by 'removeBounds'
+relaxPackageDeps
+  :: RelaxKind
+  -> RelaxDeps
+  -> PD.GenericPackageDescription
+  -> PD.GenericPackageDescription
+relaxPackageDeps _ rd gpd | not (isRelaxDeps rd) = gpd -- subsumed by no-op case in 'removeBounds'
+relaxPackageDeps relKind RelaxDepsAll gpd = PD.transformAllBuildDepends relaxAll gpd
+  where
+    relaxAll :: Dependency -> Dependency
+    relaxAll (Dependency pkgName verRange cs) =
+      Dependency pkgName (removeBound relKind RelaxDepModNone verRange) cs
+relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd =
+  PD.transformAllBuildDepends relaxSome gpd
+  where
+    thisPkgName = packageName gpd
+    thisPkgId = packageId gpd
+    depsToRelax = Map.fromList $ mapMaybe f depsToRelax0
+
+    f :: RelaxedDep -> Maybe (RelaxDepSubject, RelaxDepMod)
+    f (RelaxedDep scope rdm p) = case scope of
+      RelaxDepScopeAll -> Just (p, rdm)
+      RelaxDepScopePackage p0
+        | p0 == thisPkgName -> Just (p, rdm)
+        | otherwise -> Nothing
+      RelaxDepScopePackageId p0
+        | p0 == thisPkgId -> Just (p, rdm)
+        | otherwise -> Nothing
+
+    relaxSome :: Dependency -> Dependency
+    relaxSome d@(Dependency depName verRange cs)
+      | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax =
+          -- a '*'-subject acts absorbing, for consistency with
+          -- the 'Semigroup RelaxDeps' instance
+          Dependency depName (removeBound relKind relMod verRange) cs
+      | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax =
+          Dependency depName (removeBound relKind relMod verRange) cs
+      | otherwise = d -- no-op
+
+-- | Internal helper for 'relaxPackageDeps'
+removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange
+removeBound RelaxLower RelaxDepModNone = removeLowerBound
+removeBound RelaxUpper RelaxDepModNone = removeUpperBound
+removeBound RelaxLower RelaxDepModCaret = transformCaretLower
+removeBound RelaxUpper RelaxDepModCaret = transformCaretUpper

Cabal/src/Distribution/Simple/Configure.hs

@@ -162,9 +162,12 @@ import Text.PrettyPrint
   , ($+$)
   )
 
+import Data.Coerce (coerce)
 import qualified Data.Maybe as M
 import qualified Data.Set as Set
+import Distribution.AllowNewer (RelaxKind (..), relaxPackageDeps)
 import qualified Distribution.Compat.NonEmptySet as NES
+import Distribution.Types.AllowNewer (AllowNewer (..), AllowOlder (..))
 import Distribution.Types.AnnotatedId
 
 type UseExternalInternalDeps = Bool
@@ -1227,7 +1230,13 @@ configureFinalizedPackage
   satisfies
   comp
   compPlatform
-  pkg_descr0 = do
+  pkg_descr_before_relaxed_bounds = do
+    let
+      relax relax_kind getter = relaxPackageDeps relax_kind . fromMaybe mempty . coerce $ getter cfg
+      pkg_descr0 =
+        relax RelaxLower configAllowOlder
+          . relax RelaxUpper configAllowNewer
+          $ pkg_descr_before_relaxed_bounds
     (pkg_descr0', flags) <-
       case finalizePD
         (configConfigurationsFlags cfg)

Cabal/src/Distribution/Simple/Setup/Config.hs

@@ -62,6 +62,7 @@ import Distribution.Compat.Semigroup (Last' (..), Option' (..))
 import Distribution.Compat.Stack
 
 import Distribution.Simple.Setup.Common
+import Distribution.Types.AllowNewer (AllowNewer (..), AllowOlder (..), RelaxDeps (..))
 
 -- ------------------------------------------------------------
 
@@ -220,6 +221,12 @@ data ConfigFlags = ConfigFlags
   -- ^ Allow depending on private sublibraries. This is used by external
   -- tools (like cabal-install) so they can add multiple-public-libraries
   -- compatibility to older ghcs by checking visibility externally.
+  , configAllowNewer :: Maybe AllowNewer
+  -- ^ Ignore upper bounds on all or some dependencies.
+  -- Nothing means option not set.
+  , configAllowOlder :: Maybe AllowOlder
+  -- ^ Ignore lower bounds on all or some dependencies.
+  -- Nothing means option not set.
   }
   deriving (Generic, Read, Show, Typeable)
 
@@ -288,6 +295,8 @@ instance Eq ConfigFlags where
       && equal configDebugInfo
       && equal configDumpBuildInfo
       && equal configUseResponseFiles
+      && equal configAllowNewer
+      && equal configAllowOlder
     where
       equal f = on (==) f a b
 
@@ -342,6 +351,8 @@ defaultConfigFlags progDb =
     , configDebugInfo = Flag NoDebugInfo
     , configDumpBuildInfo = NoFlag
     , configUseResponseFiles = NoFlag
+    , configAllowNewer = Nothing
+    , configAllowOlder = Nothing
     }
 {- FOURMOLU_ENABLE -}
 
@@ -828,8 +839,58 @@ configureOptions showOrParseArgs =
           configAllowDependingOnPrivateLibs
           (\v flags -> flags{configAllowDependingOnPrivateLibs = v})
           trueArg
+       , option
+          ""
+          ["allow-older"]
+          ( "Ignore lower bounds in all dependencies or for the given DEPS."
+              ++ " DEPS is a comma or space separated list of DEP or PKG:DEP,"
+              ++ " where PKG or DEP can be *."
+          )
+          configAllowOlder
+          (\v flags -> flags{configAllowOlder = v})
+          ( optArg
+              "DEPS"
+              (fmap (Just . AllowOlder) parseRelaxDeps)
+              (Just $ AllowOlder RelaxDepsAll)
+              (relaxDepsPrinter . fmap unAllowOlder)
+          )
+       , option
+          ""
+          ["allow-newer"]
+          ( "Ignore upper bounds in all dependencies or for the given DEPS."
+              ++ " DEPS is a comma or space separated list of DEP or PKG:DEP,"
+              ++ " where PKG or DEP can be *."
+          )
+          configAllowNewer
+          (\v flags -> flags{configAllowNewer = v})
+          ( optArg
+              "DEPS"
+              (fmap (Just . AllowNewer) parseRelaxDeps)
+              (Just $ AllowNewer RelaxDepsAll)
+              (relaxDepsPrinter . fmap unAllowNewer)
+          )
        ]
   where
+    relaxDepsParser :: CabalParsing m => m RelaxDeps
+    relaxDepsParser = do
+      rs <- parsecOptCommaList parsec
+      if null rs
+        then -- This error is not displayed by the argument parser,
+        -- but its nice to have anyway.
+
+          fail $
+            "empty argument list is not allowed. "
+              ++ "Note: use --allow-newer/--allow-older without the equals sign to permit all "
+              ++ "packages to use newer versions."
+        else return . RelaxDepsSome $ rs
+
+    relaxDepsPrinter :: Maybe RelaxDeps -> [Maybe String]
+    relaxDepsPrinter Nothing = []
+    relaxDepsPrinter (Just RelaxDepsAll) = [Nothing]
+    relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . prettyShow) pkgs
+
+    parseRelaxDeps = parsecToReadE ("Not a valid list of DEPS: " ++) relaxDepsParser
+
     liftInstallDirs =
       liftOption configInstallDirs (\v flags -> flags{configInstallDirs = v})
 

cabal-install/src/Distribution/Client/Types/AllowNewer.hs → Cabal/src/Distribution/Types/AllowNewer.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 
-module Distribution.Client.Types.AllowNewer
+module Distribution.Types.AllowNewer
   ( AllowNewer (..)
   , AllowOlder (..)
   , RelaxDeps (..)
@@ -12,15 +12,15 @@ module Distribution.Client.Types.AllowNewer
   , isRelaxDeps
   ) where
 
-import Distribution.Client.Compat.Prelude
-import Prelude ()
+import Distribution.Compat.Prelude
 
-import Distribution.Parsec (parsecLeadingCommaNonEmpty)
+import Distribution.Parsec (CabalParsing, Parsec (parsec), parsecLeadingCommaNonEmpty)
 import Distribution.Types.PackageId (PackageId, PackageIdentifier (..))
 import Distribution.Types.PackageName (PackageName, mkPackageName)
 import Distribution.Types.Version (nullVersion)
 
 import qualified Distribution.Compat.CharParsing as P
+import Distribution.Pretty (Pretty (pretty))
 import qualified Text.PrettyPrint as Disp
 
 -- $setup

cabal-install/cabal-install.cabal

@@ -179,7 +179,6 @@ library
         Distribution.Client.TargetSelector
         Distribution.Client.Targets
         Distribution.Client.Types
-        Distribution.Client.Types.AllowNewer
         Distribution.Client.Types.BuildResults
         Distribution.Client.Types.ConfiguredId
         Distribution.Client.Types.ConfiguredPackage

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

@@ -84,15 +84,17 @@ import Distribution.Client.Setup
   , reportCommand
   , uploadCommand
   )
-import Distribution.Client.Types
+import Distribution.Types.AllowNewer
   ( AllowNewer (..)
   , AllowOlder (..)
-  , LocalRepo (..)
   , RelaxDeps (..)
+  , isRelaxDeps
+  )
+import Distribution.Client.Types
+  ( LocalRepo (..)
   , RemoteRepo (..)
   , RepoName (..)
   , emptyRemoteRepo
-  , isRelaxDeps
   , unRepoName
   )
 import Distribution.Client.Types.Credentials (Password (..), Username (..))
@@ -526,6 +528,8 @@ instance Semigroup SavedConfig where
           , configDumpBuildInfo = combine configDumpBuildInfo
           , configAllowDependingOnPrivateLibs =
               combine configAllowDependingOnPrivateLibs
+          , configAllowNewer = combineMonoid savedConfigureFlags configAllowNewer
+          , configAllowOlder = combineMonoid savedConfigureFlags configAllowOlder
           }
         where
           combine = combine' savedConfigureFlags
@@ -543,10 +547,6 @@ instance Semigroup SavedConfig where
           , -- TODO: NubListify
             configPreferences = lastNonEmpty configPreferences
           , configSolver = combine configSolver
-          , configAllowNewer =
-              combineMonoid savedConfigureExFlags configAllowNewer
-          , configAllowOlder =
-              combineMonoid savedConfigureExFlags configAllowOlder
           , configWriteGhcEnvironmentFilesPolicy =
               combine configWriteGhcEnvironmentFilesPolicy
           }
@@ -1103,14 +1103,12 @@ commentSavedConfig = do
                 }
           , savedInstallFlags = defaultInstallFlags
           , savedClientInstallFlags = defaultClientInstallFlags
-          , savedConfigureExFlags =
-              defaultConfigExFlags
-                { configAllowNewer = Just (AllowNewer mempty)
-                , configAllowOlder = Just (AllowOlder mempty)
-                }
+          , savedConfigureExFlags = defaultConfigExFlags
           , savedConfigureFlags =
               (defaultConfigFlags defaultProgramDb)
                 { configUserInstall = toFlag defaultUserInstall
+                , configAllowNewer = Just (AllowNewer mempty)
+                , configAllowOlder = Just (AllowOlder mempty)
                 }
           , savedUserInstallDirs = fmap toFlag userInstallDirs
           , savedGlobalInstallDirs = fmap toFlag globalInstallDirs
@@ -1231,12 +1229,7 @@ configFieldDescriptions src =
                               ++ name
                               ++ "' field is case sensitive, use 'True' or 'False'."
                 )
-      ]
-    ++ toSavedConfig
-      liftConfigExFlag
-      (configureExOptions ParseArgs src)
-      []
-      [ let pkgs =
+      , let pkgs =
               (Just . AllowOlder . RelaxDepsSome)
                 `fmap` parsecOptCommaList parsec
             parseAllowOlder =
@@ -1265,6 +1258,11 @@ configFieldDescriptions src =
               configAllowNewer
               (\v flags -> flags{configAllowNewer = v})
       ]
+    ++ toSavedConfig
+      liftConfigExFlag
+      (configureExOptions ParseArgs src)
+      []
+      []
     ++ toSavedConfig
       liftInstallFlag
       (installOptions ParseArgs)

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

@@ -130,6 +130,7 @@ import Distribution.Version
   )
 
 import System.FilePath ((</>))
+import Distribution.Types.AllowNewer (AllowOlder(..), AllowNewer (..))
 
 -- | Choose the Cabal version such that the setup scripts compiled against this
 -- version will support the given command-line flags. Currently, it implements no
@@ -430,9 +431,9 @@ planLocalPackage
       resolverParams :: DepResolverParams
       resolverParams =
         removeLowerBounds
-          (fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags)
+          (fromMaybe (AllowOlder mempty) $ configAllowOlder configFlags)
           . removeUpperBounds
-            (fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags)
+            (fromMaybe (AllowNewer mempty) $ configAllowNewer configFlags)
           . addPreferences
             -- preferences from the config file or command line
             [ PackageVersionPreference name ver