Generalise 'AllowNewer'-types' names

This also adds a not yet used `AllowOlder` newtype

This is a preparatory refactoring propsed in #3466 for supporting `--allow-older`

Cabal/Distribution/Simple/Configure.hs

@@ -324,7 +324,7 @@ configure (pkg_descr0', pbi) cfg = do
           if fromFlagOrDefault False (configExactConfiguration cfg)
           then pkg_descr0'
           else relaxPackageDeps
-               (fromMaybe AllowNewerNone $ configAllowNewer cfg)
+               (maybe RelaxDepsNone unAllowNewer $ configAllowNewer cfg)
                pkg_descr0'
 
     setupMessage verbosity "Configuring" (packageId pkg_descr0)
@@ -861,21 +861,21 @@ dependencySatisfiable
                       $ PackageIndex.lookupDependency internalPackageSet d
 
 -- | Relax the dependencies of this package if needed.
-relaxPackageDeps :: AllowNewer -> GenericPackageDescription
+relaxPackageDeps :: RelaxDeps -> GenericPackageDescription
                  -> GenericPackageDescription
-relaxPackageDeps AllowNewerNone gpd = gpd
-relaxPackageDeps AllowNewerAll  gpd = transformAllBuildDepends relaxAll gpd
+relaxPackageDeps RelaxDepsNone gpd = gpd
+relaxPackageDeps RelaxDepsAll  gpd = transformAllBuildDepends relaxAll gpd
   where
     relaxAll = \(Dependency pkgName verRange) ->
       Dependency pkgName (removeUpperBound verRange)
-relaxPackageDeps (AllowNewerSome allowNewerDeps') gpd =
+relaxPackageDeps (RelaxDepsSome allowNewerDeps') gpd =
   transformAllBuildDepends relaxSome gpd
   where
     thisPkgName    = packageName gpd
     allowNewerDeps = mapMaybe f allowNewerDeps'
 
-    f (Setup.AllowNewerDep p) = Just p
-    f (Setup.AllowNewerDepScoped scope p) | scope == thisPkgName = Just p
+    f (Setup.RelaxedDep p) = Just p
+    f (Setup.RelaxedDepScoped scope p) | scope == thisPkgName = Just p
                                           | otherwise            = Nothing
 
     relaxSome = \d@(Dependency depName verRange) ->

Cabal/Distribution/Simple/Setup.hs

@@ -35,7 +35,8 @@ module Distribution.Simple.Setup (
   GlobalFlags(..),   emptyGlobalFlags,   defaultGlobalFlags,   globalCommand,
   ConfigFlags(..),   emptyConfigFlags,   defaultConfigFlags,   configureCommand,
   configPrograms,
-  AllowNewer(..),    AllowNewerDep(..),  isAllowNewer,
+  RelaxDeps(..),    RelaxedDep(..),  isRelaxDeps,
+  AllowNewer(..),   AllowOlder(..),
   configAbsolutePaths, readPackageDbList, showPackageDbList,
   CopyFlags(..),     emptyCopyFlags,     defaultCopyFlags,     copyCommand,
   InstallFlags(..),  emptyInstallFlags,  defaultInstallFlags,  installCommand,
@@ -263,63 +264,87 @@ instance Semigroup GlobalFlags where
 -- 'build-depends: array >= 0.3 && < 0.5', are we allowed to relax the upper
 -- bound and choose a version of 'array' that is greater or equal to 0.5? By
 -- default the upper bounds are always strictly honored.
-data AllowNewer =
+data RelaxDeps =
 
   -- | Default: honor the upper bounds in all dependencies, never choose
   -- versions newer than allowed.
-  AllowNewerNone
+  RelaxDepsNone
 
   -- | Ignore upper bounds in dependencies on the given packages.
-  | AllowNewerSome [AllowNewerDep]
+  | RelaxDepsSome [RelaxedDep]
 
   -- | Ignore upper bounds in dependencies on all packages.
-  | AllowNewerAll
+  | 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 AllowNewerDep = AllowNewerDep PackageName
-                   | AllowNewerDepScoped PackageName PackageName
-                   deriving (Eq, Read, Show, Generic)
+data RelaxedDep = RelaxedDep PackageName
+                | RelaxedDepScoped PackageName PackageName
+                deriving (Eq, Read, Show, Generic)
 
-instance Text AllowNewerDep where
-  disp (AllowNewerDep p0)          = disp p0
-  disp (AllowNewerDepScoped p0 p1) = disp p0 Disp.<> Disp.colon Disp.<> disp p1
+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 = AllowNewerDepScoped `fmap` parse A.<* Parse.char ':' A.<*> parse
-      normalP = AllowNewerDep       `fmap` parse
+      scopedP = RelaxedDepScoped `fmap` parse A.<* Parse.char ':' A.<*> parse
+      normalP = RelaxedDep       `fmap` parse
 
+instance Binary RelaxDeps
+instance Binary RelaxedDep
 instance Binary AllowNewer
-instance Binary AllowNewerDep
+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 = (Semi.<>)
 
 instance Semigroup AllowNewer where
-  AllowNewerNone       <> r                    = r
-  l@AllowNewerAll      <> _                    = l
-  l@(AllowNewerSome _) <> AllowNewerNone       = l
-  (AllowNewerSome   _) <> r@AllowNewerAll      = r
-  (AllowNewerSome   a) <> (AllowNewerSome b)   = AllowNewerSome (a ++ b)
+  AllowNewer x <> AllowNewer y = AllowNewer (x <> y)
+
+instance Semigroup AllowOlder where
+  AllowOlder x <> AllowOlder y = AllowOlder (x <> y)
 
 instance Monoid AllowNewer where
-  mempty  = AllowNewerNone
+  mempty  = AllowNewer mempty
+  mappend = (Semi.<>)
+
+instance Monoid AllowOlder where
+  mempty  = AllowOlder mempty
   mappend = (Semi.<>)
 
--- | Convert 'AllowNewer' to a boolean.
-isAllowNewer :: AllowNewer -> Bool
-isAllowNewer AllowNewerNone     = False
-isAllowNewer (AllowNewerSome _) = True
-isAllowNewer AllowNewerAll      = True
+-- | Convert 'RelaxDeps' to a boolean.
+isRelaxDeps :: RelaxDeps -> Bool
+isRelaxDeps RelaxDepsNone     = False
+isRelaxDeps (RelaxDepsSome _) = True
+isRelaxDeps RelaxDepsAll      = True
 
-allowNewerParser :: Parse.ReadP r (Maybe AllowNewer)
-allowNewerParser =
-  (Just . AllowNewerSome) `fmap` Parse.sepBy1 parse (Parse.char ',')
+relaxDepsParser :: Parse.ReadP r (Maybe RelaxDeps)
+relaxDepsParser =
+  (Just . RelaxDepsSome) `fmap` Parse.sepBy1 parse (Parse.char ',')
 
-allowNewerPrinter :: (Maybe AllowNewer) -> [Maybe String]
-allowNewerPrinter Nothing                      = []
-allowNewerPrinter (Just AllowNewerNone)        = []
-allowNewerPrinter (Just AllowNewerAll)         = [Nothing]
-allowNewerPrinter (Just (AllowNewerSome pkgs)) = map (Just . display) $ pkgs
+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.
 --
@@ -690,10 +715,11 @@ configureOptions showOrParseArgs =
 
       ,option [] ["allow-newer"]
        ("Ignore upper bounds in all dependencies or DEPS")
-       configAllowNewer (\v flags -> flags { configAllowNewer = v})
+       (fmap unAllowNewer . configAllowNewer)
+       (\v flags -> flags { configAllowNewer = fmap AllowNewer v})
        (optArg "DEPS"
-        (readP_to_E ("Cannot parse the list of packages: " ++) allowNewerParser)
-        (Just AllowNewerAll) allowNewerPrinter)
+        (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."

cabal-install/Distribution/Client/Config.hs

@@ -62,7 +62,7 @@ import Distribution.Simple.Compiler
          ( DebugInfoLevel(..), OptimisationLevel(..) )
 import Distribution.Simple.Setup
          ( ConfigFlags(..), configureOptions, defaultConfigFlags
-         , AllowNewer(..)
+         , AllowNewer(..), RelaxDeps(..)
          , HaddockFlags(..), haddockOptions, defaultHaddockFlags
          , installDirsOptions, optionDistPref
          , programConfigurationPaths', programConfigurationOptions
@@ -631,7 +631,7 @@ commentSavedConfig = do
     savedConfigureExFlags  = defaultConfigExFlags,
     savedConfigureFlags    = (defaultConfigFlags defaultProgramConfiguration) {
       configUserInstall    = toFlag defaultUserInstall,
-      configAllowNewer     = Just AllowNewerNone
+      configAllowNewer     = Just (AllowNewer RelaxDepsNone)
     },
     savedUserInstallDirs   = fmap toFlag userInstallDirs,
     savedGlobalInstallDirs = fmap toFlag globalInstallDirs,
@@ -661,13 +661,13 @@ configFieldDescriptions src =
           (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)
           configHcFlavor (\v flags -> flags { configHcFlavor = v })
        ,let showAllowNewer Nothing               = mempty
-            showAllowNewer (Just AllowNewerNone) = Disp.text "False"
+            showAllowNewer (Just (AllowNewer RelaxDepsNone)) = Disp.text "False"
             showAllowNewer (Just _)              = Disp.text "True"
 
-            toAllowNewer True  = Just AllowNewerAll
-            toAllowNewer False = Just AllowNewerNone
+            toAllowNewer True  = Just (AllowNewer RelaxDepsAll)
+            toAllowNewer False = Just (AllowNewer RelaxDepsNone)
 
-            pkgs = (Just . AllowNewerSome) `fmap` parseOptCommaList Text.parse
+            pkgs = (Just . AllowNewer . RelaxDepsSome) `fmap` parseOptCommaList Text.parse
             parseAllowNewer = (toAllowNewer `fmap` Text.parse) Parse.<++ pkgs in
         simpleField "allow-newer"
         showAllowNewer parseAllowNewer

cabal-install/Distribution/Client/Configure.hs

@@ -48,7 +48,7 @@ import Distribution.Simple.Compiler
          ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack )
 import Distribution.Simple.Program (ProgramConfiguration )
 import Distribution.Simple.Setup
-         ( ConfigFlags(..), AllowNewer(..)
+         ( ConfigFlags(..), AllowNewer(..), RelaxDeps(..)
          , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )
 import Distribution.Simple.PackageIndex
          ( InstalledPackageIndex, lookupPackageName )
@@ -68,7 +68,7 @@ import Distribution.Version
 import Distribution.Simple.Utils as Utils
          ( warn, notice, debug, die )
 import Distribution.Simple.Setup
-         ( isAllowNewer )
+         ( isRelaxDeps )
 import Distribution.System
          ( Platform )
 import Distribution.Text ( display )
@@ -91,8 +91,8 @@ chooseCabalVersion configFlags maybeVersion =
   where
     -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed
     -- for '--allow-newer' to work.
-    allowNewer = isAllowNewer
-                 (fromMaybe AllowNewerNone $ configAllowNewer configFlags)
+    allowNewer = isRelaxDeps
+                 (maybe RelaxDepsNone unAllowNewer $ configAllowNewer configFlags)
 
     defaultVersionRange = if allowNewer
                           then orLaterVersion (Version [1,19,2] [])
@@ -307,7 +307,7 @@ planLocalPackage verbosity comp platform configFlags configExFlags
 
       resolverParams =
           removeUpperBounds
-          (fromMaybe AllowNewerNone $ configAllowNewer configFlags)
+          (maybe RelaxDepsNone unAllowNewer $ configAllowNewer configFlags)
 
         . addPreferences
             -- preferences from the config file or command line

cabal-install/Distribution/Client/Dependency.hs

@@ -107,7 +107,7 @@ import Distribution.Simple.Utils
 import Distribution.Simple.Configure
          ( relaxPackageDeps )
 import Distribution.Simple.Setup
-         ( AllowNewer(..) )
+         ( RelaxDeps(..) )
 import Distribution.Text
          ( display )
 import Distribution.Verbosity
@@ -414,8 +414,8 @@ hideBrokenInstalledPackages params =
 -- 'addSourcePackages'. Otherwise, the packages inserted by
 -- 'addSourcePackages' won't have upper bounds in dependencies relaxed.
 --
-removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams
-removeUpperBounds AllowNewerNone params = params
+removeUpperBounds :: RelaxDeps -> DepResolverParams -> DepResolverParams
+removeUpperBounds RelaxDepsNone params = params
 removeUpperBounds allowNewer     params =
     params {
       depResolverSourcePkgIndex = sourcePkgIndex'

cabal-install/Distribution/Client/Install.hs

@@ -130,7 +130,7 @@ import Distribution.Simple.PackageIndex (InstalledPackageIndex)
 import Distribution.Simple.Setup
          ( haddockCommand, HaddockFlags(..)
          , buildCommand, BuildFlags(..), emptyBuildFlags
-         , AllowNewer(..)
+         , AllowNewer(..), RelaxDeps(..)
          , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref )
 import qualified Distribution.Simple.Setup as Cabal
          ( Flag(..)
@@ -441,7 +441,7 @@ planPackages comp platform mSandboxPkgInfo solver
     maxBackjumps     = fromFlag (installMaxBackjumps      installFlags)
     upgradeDeps      = fromFlag (installUpgradeDeps       installFlags)
     onlyDeps         = fromFlag (installOnlyDeps          installFlags)
-    allowNewer       = fromMaybe AllowNewerNone (configAllowNewer configFlags)
+    allowNewer       = maybe RelaxDepsNone unAllowNewer (configAllowNewer configFlags)
 
 -- | Remove the provided targets from the install plan.
 pruneInstallPlan :: Package targetpkg

cabal-install/Distribution/Client/ProjectConfig.hs

@@ -75,7 +75,7 @@ import Distribution.Simple.Program
          ( ConfiguredProgram(..) )
 import Distribution.Simple.Setup
          ( Flag(Flag), toFlag, flagToMaybe, flagToList
-         , fromFlag, AllowNewer(..) )
+         , fromFlag, AllowNewer(..), RelaxDeps(..) )
 import Distribution.Client.Setup
          ( defaultSolver, defaultMaxBackjumps, )
 import Distribution.Simple.InstallDirs
@@ -209,7 +209,7 @@ resolveSolverSettings ProjectConfig{
 
     defaults = mempty {
        projectConfigSolver            = Flag defaultSolver,
-       projectConfigAllowNewer        = Just AllowNewerNone,
+       projectConfigAllowNewer        = Just (AllowNewer RelaxDepsNone),
        projectConfigMaxBackjumps      = Flag defaultMaxBackjumps,
        projectConfigReorderGoals      = Flag (ReorderGoals False),
        projectConfigCountConflicts    = Flag (CountConflicts True),

cabal-install/Distribution/Client/ProjectConfig/Legacy.hs

@@ -40,7 +40,7 @@ import Distribution.Simple.Setup
          , ConfigFlags(..), configureOptions
          , HaddockFlags(..), haddockOptions, defaultHaddockFlags
          , programConfigurationPaths', splitArgs
-         , AllowNewer(..) )
+         , AllowNewer(..), RelaxDeps(..) )
 import Distribution.Client.Setup
          ( GlobalFlags(..), globalCommand
          , ConfigExFlags(..), configureExOptions, defaultConfigExFlags
@@ -787,8 +787,9 @@ legacySharedConfigFieldDescrs =
       (\flags conf -> conf { legacyConfigureShFlags = flags })
   . addFields
       [ simpleField "allow-newer"
-        (maybe mempty dispAllowNewer) (fmap Just parseAllowNewer)
-        configAllowNewer (\v conf -> conf { configAllowNewer = v })
+        (maybe mempty dispRelaxDeps) (fmap Just parseRelaxDeps)
+        (fmap unAllowNewer . configAllowNewer)
+        (\v conf -> conf { configAllowNewer = fmap AllowNewer v })
       ]
   . filterFields ["verbose"]
   . commandOptionsToFields
@@ -836,17 +837,17 @@ legacySharedConfigFieldDescrs =
   where
     constraintSrc = ConstraintSourceProjectConfig "TODO"
 
-parseAllowNewer :: ReadP r AllowNewer
-parseAllowNewer =
-     ((const AllowNewerNone <$> (Parse.string "none" +++ Parse.string "None"))
-  +++ (const AllowNewerAll  <$> (Parse.string "all"  +++ Parse.string "All")))
-  <++ (      AllowNewerSome <$> parseOptCommaList parse)
-
-dispAllowNewer :: AllowNewer -> Doc
-dispAllowNewer  AllowNewerNone       = Disp.text "None"
-dispAllowNewer (AllowNewerSome pkgs) = Disp.fsep . Disp.punctuate Disp.comma
-                                                 . map disp $ pkgs
-dispAllowNewer  AllowNewerAll        = Disp.text "All"
+parseRelaxDeps :: ReadP r RelaxDeps
+parseRelaxDeps =
+     ((const RelaxDepsNone <$> (Parse.string "none" +++ Parse.string "None"))
+  +++ (const RelaxDepsAll  <$> (Parse.string "all"  +++ Parse.string "All")))
+  <++ (      RelaxDepsSome <$> parseOptCommaList parse)
+
+dispRelaxDeps :: RelaxDeps -> Doc
+dispRelaxDeps  RelaxDepsNone       = Disp.text "None"
+dispRelaxDeps (RelaxDepsSome pkgs) = Disp.fsep . Disp.punctuate Disp.comma
+                                               . map disp $ pkgs
+dispRelaxDeps  RelaxDepsAll        = Disp.text "All"
 
 
 legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig]

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -883,7 +883,7 @@ planPackages comp platform solver SolverSettings{..}
                                 then PreferAllLatest
                                 else PreferLatestForSelected)-}
 
-      . removeUpperBounds solverSettingAllowNewer
+      . removeUpperBounds (Cabal.unAllowNewer solverSettingAllowNewer)
 
       . addDefaultSetupDependencies (defaultSetupDeps comp platform
                                    . PD.packageDescription

cabal-install/Distribution/Client/Setup.hs

@@ -371,7 +371,7 @@ filterConfigureFlags flags cabalLibVersion
       configConstraints = [],
       -- Passing '--allow-newer' to Setup.hs is unnecessary, we use
       -- '--exact-configuration' instead.
-      configAllowNewer  = Just Cabal.AllowNewerNone
+      configAllowNewer  = Just (Cabal.AllowNewer Cabal.RelaxDepsNone)
       }
 
     -- Cabal < 1.23 doesn't know about '--profiling-detail'.

cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs

@@ -587,14 +587,20 @@ instance Arbitrary StrongFlags where
     arbitrary = StrongFlags <$> arbitrary
 
 instance Arbitrary AllowNewer where
-    arbitrary = oneof [ pure AllowNewerNone
-                      , AllowNewerSome <$> shortListOf1 3 arbitrary
-                      , pure AllowNewerAll
+    arbitrary = AllowNewer <$> arbitrary
+
+instance Arbitrary AllowOlder where
+    arbitrary = AllowOlder <$> arbitrary
+
+instance Arbitrary RelaxDeps where
+    arbitrary = oneof [ pure RelaxDepsNone
+                      , RelaxDepsSome <$> shortListOf1 3 arbitrary
+                      , pure RelaxDepsAll
                       ]
 
-instance Arbitrary AllowNewerDep where
-    arbitrary = oneof [ AllowNewerDep       <$> arbitrary
-                      , AllowNewerDepScoped <$> arbitrary <*> arbitrary
+instance Arbitrary RelaxedDep where
+    arbitrary = oneof [ RelaxedDep       <$> arbitrary
+                      , RelaxedDepScoped <$> arbitrary <*> arbitrary
                       ]
 
 instance Arbitrary ProfDetailLevel where