From bffb3664c3a26a06841461cc20d97160310ea12a Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sat, 4 Jun 2016 16:46:23 +0200 Subject: [PATCH] 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 | 14 +-- Cabal/Distribution/Simple/Setup.hs | 96 ++++++++++++------- cabal-install/Distribution/Client/Config.hs | 12 +-- .../Distribution/Client/Configure.hs | 10 +- .../Distribution/Client/Dependency.hs | 6 +- cabal-install/Distribution/Client/Install.hs | 4 +- .../Distribution/Client/ProjectConfig.hs | 4 +- .../Client/ProjectConfig/Legacy.hs | 29 +++--- .../Distribution/Client/ProjectPlanning.hs | 2 +- cabal-install/Distribution/Client/Setup.hs | 2 +- .../Distribution/Client/ProjectConfig.hs | 18 ++-- 11 files changed, 115 insertions(+), 82 deletions(-) diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index 0891004b21c..645bb5697f8 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/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) -> diff --git a/Cabal/Distribution/Simple/Setup.hs b/Cabal/Distribution/Simple/Setup.hs index c3d2090ae15..7714ebfd626 100644 --- a/Cabal/Distribution/Simple/Setup.hs +++ b/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 +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." diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 98b287dd3a3..fc4f3d2b532 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/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 @@ -629,7 +629,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, @@ -659,13 +659,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 diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs index ad249ef278a..b144ee56135 100644 --- a/cabal-install/Distribution/Client/Configure.hs +++ b/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 diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs index 3c5b500aa2a..36e70b388e4 100644 --- a/cabal-install/Distribution/Client/Dependency.hs +++ b/cabal-install/Distribution/Client/Dependency.hs @@ -105,7 +105,7 @@ import Distribution.Simple.Utils import Distribution.Simple.Configure ( relaxPackageDeps ) import Distribution.Simple.Setup - ( AllowNewer(..) ) + ( RelaxDeps(..) ) import Distribution.Text ( display ) import Distribution.Verbosity @@ -389,8 +389,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' diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index 403c5c9757b..36ea2b15eda 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/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(..) @@ -438,7 +438,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 diff --git a/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs index 740b206dd84..b7b5bb2508f 100644 --- a/cabal-install/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/Distribution/Client/ProjectConfig.hs @@ -74,7 +74,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 @@ -207,7 +207,7 @@ resolveSolverSettings ProjectConfig{ defaults = mempty { projectConfigSolver = Flag defaultSolver, - projectConfigAllowNewer = Just AllowNewerNone, + projectConfigAllowNewer = Just (AllowNewer RelaxDepsNone), projectConfigMaxBackjumps = Flag defaultMaxBackjumps, projectConfigReorderGoals = Flag (ReorderGoals False), projectConfigStrongFlags = Flag (StrongFlags False) diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs index 56e785c90ee..b0a5650d2cd 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/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 @@ -783,8 +783,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 @@ -832,17 +833,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] diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index bb653c1bfcd..3b8f5e2cb77 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -863,7 +863,7 @@ planPackages comp platform solver SolverSettings{..} then PreferAllLatest else PreferLatestForSelected)-} - . removeUpperBounds solverSettingAllowNewer + . removeUpperBounds (Cabal.unAllowNewer solverSettingAllowNewer) . addDefaultSetupDependencies (defaultSetupDeps comp platform . PD.packageDescription diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index d965c089caa..4383ba407b8 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/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'. diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index a93d543ad00..23fb00ad1c8 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -582,14 +582,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