Commit b9fdc1bf authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺 Committed by Edward Z. Yang

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`
parent ce2ffb24
......@@ -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) ->
......
......@@ -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."
......
......@@ -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
......
......@@ -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
......
......@@ -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'
......
......@@ -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
......
......@@ -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),
......
......@@ -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]
......
......@@ -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
......
......@@ -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'.
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment