Merge pull request #4527 from hvr/wip/issue-3581

Remove --allow-{newer,older} support from Cabal
haskell · May 19, 2017 · 99e70bd · 99e70bd
2 parents a04f378 + c038b52
commit 99e70bd
Show file tree

Hide file tree

Showing 22 changed files with 261 additions and 599 deletions.
diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs
@@ -53,7 +53,6 @@ module Distribution.Simple.Configure (configure,
                                       ConfigStateFileError(..),
                                       tryGetConfigStateFile,
                                       platformDefines,
-                                      relaxPackageDeps,
                                      )
     where
 
@@ -330,18 +329,7 @@ findDistPrefOrDefault = findDistPref defaultDistPref
 -- Returns the @.setup-config@ file.
 configure :: (GenericPackageDescription, HookedBuildInfo)
           -> ConfigFlags -> IO LocalBuildInfo
-configure (pkg_descr0', pbi) cfg = do
-    let pkg_descr0 =
-          -- Ignore '--allow-{older,newer}' when we're given
-          -- '--exact-configuration'.
-          if fromFlagOrDefault False (configExactConfiguration cfg)
-          then pkg_descr0'
-          else relaxPackageDeps removeLowerBound
-               (maybe RelaxDepsNone unAllowOlder $ configAllowOlder cfg) $
-               relaxPackageDeps removeUpperBound
-               (maybe RelaxDepsNone unAllowNewer $ configAllowNewer cfg)
-               pkg_descr0'
-
+configure (pkg_descr0, pbi) cfg = do
     -- Determine the component we are configuring, if a user specified
     -- one on the command line.  We use a fake, flattened version of
     -- the package since at this point, we're not really sure what
@@ -890,30 +878,6 @@ dependencySatisfiable
            -- name
            = Just (mkUnqualComponentName (unPackageName depName))
 
--- | Relax the dependencies of this package if needed.
-relaxPackageDeps :: (VersionRange -> VersionRange)
-                 -> RelaxDeps
-                 -> GenericPackageDescription -> GenericPackageDescription
-relaxPackageDeps _ RelaxDepsNone gpd = gpd
-relaxPackageDeps vrtrans RelaxDepsAll  gpd = transformAllBuildDepends relaxAll gpd
-  where
-    relaxAll = \(Dependency pkgName verRange) ->
-      Dependency pkgName (vrtrans verRange)
-relaxPackageDeps vrtrans (RelaxDepsSome allowNewerDeps') gpd =
-  transformAllBuildDepends relaxSome gpd
-  where
-    thisPkgName    = packageName gpd
-    allowNewerDeps = mapMaybe f allowNewerDeps'
-
-    f (Setup.RelaxedDep p) = Just p
-    f (Setup.RelaxedDepScoped scope p) | scope == thisPkgName = Just p
-                                       | otherwise            = Nothing
-
-    relaxSome = \d@(Dependency depName verRange) ->
-      if depName `elem` allowNewerDeps
-      then Dependency depName (vrtrans verRange)
-      else d
-
 -- | Finalize a generic package description.  The workhorse is
 -- 'finalizePD' but there's a bit of other nattering
 -- about necessary.

diff --git a/Cabal/Distribution/Simple/Setup.hs b/Cabal/Distribution/Simple/Setup.hs
@@ -37,8 +37,6 @@ module Distribution.Simple.Setup (
   GlobalFlags(..),   emptyGlobalFlags,   defaultGlobalFlags,   globalCommand,
   ConfigFlags(..),   emptyConfigFlags,   defaultConfigFlags,   configureCommand,
   configPrograms,
-  RelaxDeps(..),    RelaxedDep(..),  isRelaxDeps,
-  AllowNewer(..),   AllowOlder(..),
   configAbsolutePaths, readPackageDbList, showPackageDbList,
   CopyFlags(..),     emptyCopyFlags,     defaultCopyFlags,     copyCommand,
   InstallFlags(..),  emptyInstallFlags,  defaultInstallFlags,  installCommand,
@@ -273,92 +271,6 @@ instance Semigroup GlobalFlags where
 -- * Config flags
 -- ------------------------------------------------------------
 
--- | Generic data type for policy when relaxing bounds in dependencies.
--- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending
--- on whether or not you are relaxing an lower or upper bound
--- (respectively).
-data RelaxDeps =
-
-  -- | Default: honor the upper bounds in all dependencies, never choose
-  -- versions newer than allowed.
-  RelaxDepsNone
-
-  -- | Ignore upper bounds in dependencies on the given packages.
-  | RelaxDepsSome [RelaxedDep]
-
-  -- | Ignore upper bounds in dependencies on all packages.
-  | RelaxDepsAll
-  deriving (Eq, Read, Show, Generic)
-
--- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag)
-newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps }
-                   deriving (Eq, Read, Show, Generic)
-
--- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag)
-newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps }
-                   deriving (Eq, Read, Show, Generic)
-
--- | Dependencies can be relaxed either for all packages in the install plan, or
--- only for some packages.
-data RelaxedDep = RelaxedDep PackageName
-                | RelaxedDepScoped PackageName PackageName
-                deriving (Eq, Read, Show, Generic)
-
-instance Text RelaxedDep where
-  disp (RelaxedDep p0)          = disp p0
-  disp (RelaxedDepScoped p0 p1) = disp p0 Disp.<> Disp.colon Disp.<> disp p1
-
-  parse = scopedP Parse.<++ normalP
-    where
-      scopedP = RelaxedDepScoped `fmap` parse <* Parse.char ':' <*> parse
-      normalP = RelaxedDep       `fmap` parse
-
-instance Binary RelaxDeps
-instance Binary RelaxedDep
-instance Binary AllowNewer
-instance Binary AllowOlder
-
-instance Semigroup RelaxDeps where
-  RelaxDepsNone       <> r                   = r
-  l@RelaxDepsAll      <> _                   = l
-  l@(RelaxDepsSome _) <> RelaxDepsNone       = l
-  (RelaxDepsSome   _) <> r@RelaxDepsAll      = r
-  (RelaxDepsSome   a) <> (RelaxDepsSome b)   = RelaxDepsSome (a ++ b)
-
-instance Monoid RelaxDeps where
-  mempty  = RelaxDepsNone
-  mappend = (<>)
-
-instance Semigroup AllowNewer where
-  AllowNewer x <> AllowNewer y = AllowNewer (x <> y)
-
-instance Semigroup AllowOlder where
-  AllowOlder x <> AllowOlder y = AllowOlder (x <> y)
-
-instance Monoid AllowNewer where
-  mempty  = AllowNewer mempty
-  mappend = (<>)
-
-instance Monoid AllowOlder where
-  mempty  = AllowOlder mempty
-  mappend = (<>)
-
--- | Convert 'RelaxDeps' to a boolean.
-isRelaxDeps :: RelaxDeps -> Bool
-isRelaxDeps RelaxDepsNone     = False
-isRelaxDeps (RelaxDepsSome _) = True
-isRelaxDeps RelaxDepsAll      = True
-
-relaxDepsParser :: Parse.ReadP r (Maybe RelaxDeps)
-relaxDepsParser =
-  (Just . RelaxDepsSome) `fmap` Parse.sepBy1 parse (Parse.char ',')
-
-relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String]
-relaxDepsPrinter Nothing                     = []
-relaxDepsPrinter (Just RelaxDepsNone)        = []
-relaxDepsPrinter (Just RelaxDepsAll)         = [Nothing]
-relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . display) $ pkgs
-
 -- | Flags to @configure@ command.
 --
 -- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags'
@@ -442,11 +354,7 @@ data ConfigFlags = ConfigFlags {
     configFlagError :: Flag String,
       -- ^Halt and show an error message indicating an error in flag assignment
     configRelocatable :: Flag Bool, -- ^ Enable relocatable package built
-    configDebugInfo :: Flag DebugInfoLevel,  -- ^ Emit debug info.
-    configAllowOlder :: Maybe AllowOlder, -- ^ dual to 'configAllowNewer'
-    configAllowNewer :: Maybe AllowNewer
-    -- ^ Ignore upper bounds on all or some dependencies. Wrapped in 'Maybe' to
-    -- distinguish between "default" and "explicitly disabled".
+    configDebugInfo :: Flag DebugInfoLevel  -- ^ Emit debug info.
   }
   deriving (Generic, Read, Show)
 
@@ -548,8 +456,7 @@ defaultConfigFlags progDb = emptyConfigFlags {
     configExactConfiguration = Flag False,
     configFlagError    = NoFlag,
     configRelocatable  = Flag False,
-    configDebugInfo    = Flag NoDebugInfo,
-    configAllowNewer   = Nothing
+    configDebugInfo    = Flag NoDebugInfo
   }
 
 configureCommand :: ProgramDb -> CommandUI ConfigFlags
@@ -826,22 +733,6 @@ configureOptions showOrParseArgs =
          configLibCoverage (\v flags -> flags { configLibCoverage = v })
          (boolOpt [] [])
 
-      ,option [] ["allow-older"]
-       ("Ignore upper bounds in all dependencies or DEPS")
-       (fmap unAllowOlder . configAllowOlder)
-       (\v flags -> flags { configAllowOlder = fmap AllowOlder v})
-       (optArg "DEPS"
-        (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser)
-        (Just RelaxDepsAll) relaxDepsPrinter)
-
-      ,option [] ["allow-newer"]
-       ("Ignore upper bounds in all dependencies or DEPS")
-       (fmap unAllowNewer . configAllowNewer)
-       (\v flags -> flags { configAllowNewer = fmap AllowNewer v})
-       (optArg "DEPS"
-        (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser)
-        (Just RelaxDepsAll) relaxDepsPrinter)
-
       ,option "" ["exact-configuration"]
          "All direct dependencies and flags are provided on the command line."
          configExactConfiguration

diff --git a/Cabal/changelog b/Cabal/changelog
@@ -1,6 +1,7 @@
 -*-change-log-*-
 
 2.2.0.0 (current development version)
+	* Remove unused '--allow-newer'/'--allow-older' support (#4527)
 	* TODO
 
 2.0.0.0 Ryan Thomas <[email protected]> May 2017

diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs
@@ -45,7 +45,9 @@ module Distribution.Client.Config (
   ) where
 
 import Distribution.Client.Types
-         ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo )
+         ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo
+         , AllowOlder(..), AllowNewer(..), RelaxDeps(..)
+         )
 import Distribution.Client.BuildReports.Types
          ( ReportLevel(..) )
 import Distribution.Client.Setup
@@ -62,7 +64,6 @@ import Distribution.Simple.Compiler
          ( DebugInfoLevel(..), OptimisationLevel(..) )
 import Distribution.Simple.Setup
          ( ConfigFlags(..), configureOptions, defaultConfigFlags
-         , AllowNewer(..), AllowOlder(..), RelaxDeps(..)
          , HaddockFlags(..), haddockOptions, defaultHaddockFlags
          , installDirsOptions, optionDistPref
          , programDbPaths', programDbOptions
@@ -330,11 +331,7 @@ instance Semigroup SavedConfig where
         configLibCoverage         = combine configLibCoverage,
         configExactConfiguration  = combine configExactConfiguration,
         configFlagError           = combine configFlagError,
-        configRelocatable         = combine configRelocatable,
-        configAllowOlder          = combineMonoid savedConfigureFlags
-                                    configAllowOlder,
-        configAllowNewer          = combineMonoid savedConfigureFlags
-                                    configAllowNewer
+        configRelocatable         = combine configRelocatable
         }
         where
           combine        = combine'        savedConfigureFlags
@@ -347,7 +344,9 @@ instance Semigroup SavedConfig where
         configExConstraints = lastNonEmpty configExConstraints,
         -- TODO: NubListify
         configPreferences   = lastNonEmpty configPreferences,
-        configSolver        = combine configSolver
+        configSolver        = combine configSolver,
+        configAllowNewer    = combineMonoid savedConfigureExFlags configAllowNewer,
+        configAllowOlder    = combineMonoid savedConfigureExFlags configAllowOlder
         }
         where
           combine      = combine' savedConfigureExFlags
@@ -702,12 +701,13 @@ commentSavedConfig = do
             globalRemoteRepos = toNubList [defaultRemoteRepo]
             },
         savedInstallFlags      = defaultInstallFlags,
-        savedConfigureExFlags  = defaultConfigExFlags,
-        savedConfigureFlags    = (defaultConfigFlags defaultProgramDb) {
-            configUserInstall    = toFlag defaultUserInstall,
+        savedConfigureExFlags  = defaultConfigExFlags {
             configAllowNewer     = Just (AllowNewer RelaxDepsNone),
             configAllowOlder     = Just (AllowOlder RelaxDepsNone)
             },
+        savedConfigureFlags    = (defaultConfigFlags defaultProgramDb) {
+            configUserInstall    = toFlag defaultUserInstall
+            },
         savedUserInstallDirs   = fmap toFlag userInstallDirs,
         savedGlobalInstallDirs = fmap toFlag globalInstallDirs,
         savedUploadFlags       = commandDefaultFlags uploadCommand,
@@ -749,16 +749,7 @@ configFieldDescriptions src =
        [simpleField "compiler"
           (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)
           configHcFlavor (\v flags -> flags { configHcFlavor = v })
-       ,let pkgs = (Just . AllowOlder . RelaxDepsSome) `fmap` parseOptCommaList Text.parse
-            parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in
-        simpleField "allow-older"
-        (showRelaxDeps . fmap unAllowOlder) parseAllowOlder
-        configAllowOlder (\v flags -> flags { configAllowOlder = v })
-       ,let pkgs = (Just . AllowNewer . RelaxDepsSome) `fmap` parseOptCommaList Text.parse
-            parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in
-        simpleField "allow-newer"
-        (showRelaxDeps . fmap unAllowNewer) parseAllowNewer
-        configAllowNewer (\v flags -> flags { configAllowNewer = v })
+
         -- TODO: The following is a temporary fix. The "optimization"
         -- and "debug-info" fields are OptArg, and viewAsFieldDescr
         -- fails on that. Instead of a hand-written hackaged parser
@@ -815,7 +806,18 @@ configFieldDescriptions src =
 
   ++ toSavedConfig liftConfigExFlag
        (configureExOptions ParseArgs src)
-       [] []
+       []
+       [let pkgs = (Just . AllowOlder . RelaxDepsSome) `fmap` parseOptCommaList Text.parse
+            parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in
+        simpleField "allow-older"
+        (showRelaxDeps . fmap unAllowOlder) parseAllowOlder
+        configAllowOlder (\v flags -> flags { configAllowOlder = v })
+       ,let pkgs = (Just . AllowNewer . RelaxDepsSome) `fmap` parseOptCommaList Text.parse
+            parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in
+        simpleField "allow-newer"
+        (showRelaxDeps . fmap unAllowNewer) parseAllowNewer
+        configAllowNewer (\v flags -> flags { configAllowNewer = v })
+       ]
 
   ++ toSavedConfig liftInstallFlag
        (installOptions ParseArgs)

diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs
@@ -56,8 +56,8 @@ import Distribution.Simple.Compiler
 import Distribution.Simple.Program (ProgramDb)
 import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags )
 import Distribution.Simple.Setup
-         ( ConfigFlags(..), AllowNewer(..), AllowOlder(..), RelaxDeps(..)
-         , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault, isRelaxDeps )
+         ( ConfigFlags(..)
+         , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )
 import Distribution.Simple.PackageIndex
          ( InstalledPackageIndex, lookupPackageName )
 import Distribution.Package
@@ -90,21 +90,27 @@ import System.FilePath ( (</>) )
 
 -- | Choose the Cabal version such that the setup scripts compiled against this
 -- version will support the given command-line flags.
-chooseCabalVersion :: ConfigFlags -> Maybe Version -> VersionRange
-chooseCabalVersion configFlags maybeVersion =
+chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange
+chooseCabalVersion configExFlags maybeVersion =
   maybe defaultVersionRange thisVersion maybeVersion
   where
     -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed
     -- for '--allow-newer' to work.
     allowNewer = isRelaxDeps
-                 (maybe RelaxDepsNone unAllowNewer $ configAllowNewer configFlags)
+                 (maybe RelaxDepsNone unAllowNewer $ configAllowNewer configExFlags)
     allowOlder = isRelaxDeps
-                 (maybe RelaxDepsNone unAllowOlder $ configAllowOlder configFlags)
+                 (maybe RelaxDepsNone unAllowOlder $ configAllowOlder configExFlags)
 
     defaultVersionRange = if allowOlder || allowNewer
                           then orLaterVersion (mkVersion [1,19,2])
                           else anyVersion
 
+-- | Convert 'RelaxDeps' to a boolean.
+isRelaxDeps :: RelaxDeps -> Bool
+isRelaxDeps RelaxDepsNone     = False
+isRelaxDeps (RelaxDepsSome _) = True
+isRelaxDeps RelaxDepsAll      = True
+
 -- | Configure the package found in the local directory
 configure :: Verbosity
           -> PackageDBStack
@@ -169,7 +175,7 @@ configure verbosity packageDBs repoCtxt comp platform progdb
            (useDistPref defaultSetupScriptOptions)
            (configDistPref configFlags))
         (chooseCabalVersion
-           configFlags
+           configExFlags
            (flagToMaybe (configCabalVersion configExFlags)))
         Nothing
         False
@@ -319,9 +325,9 @@ planLocalPackage verbosity comp platform configFlags configExFlags
 
       resolverParams =
           removeLowerBounds
-          (fromMaybe (AllowOlder RelaxDepsNone) $ configAllowOlder configFlags)
+          (fromMaybe (AllowOlder RelaxDepsNone) $ configAllowOlder configExFlags)
         . removeUpperBounds
-          (fromMaybe (AllowNewer RelaxDepsNone) $ configAllowNewer configFlags)
+          (fromMaybe (AllowNewer RelaxDepsNone) $ configAllowNewer configExFlags)
 
         . addPreferences
             -- preferences from the config file or command line