Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Generalise 'AllowNewer'-types' names
This also adds a not yet used `AllowOlder` newtype

This is a preparatory refactoring propsed in haskell#3466 for supporting `--allow-older`
  • Loading branch information
hvr committed Jun 5, 2016
1 parent 2c465d9 commit f3c47af
Show file tree
Hide file tree
Showing 11 changed files with 116 additions and 83 deletions.
14 changes: 7 additions & 7 deletions Cabal/Distribution/Simple/Configure.hs
Expand Up @@ -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)
Expand Down Expand Up @@ -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) ->
Expand Down
98 changes: 62 additions & 36 deletions Cabal/Distribution/Simple/Setup.hs
Expand Up @@ -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,
Expand Down Expand Up @@ -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.
--
Expand Down Expand Up @@ -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."
Expand Down
12 changes: 6 additions & 6 deletions cabal-install/Distribution/Client/Config.hs
Expand Up @@ -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
Expand Down Expand Up @@ -630,7 +630,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,
Expand Down Expand Up @@ -660,13 +660,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
Expand Down
10 changes: 5 additions & 5 deletions cabal-install/Distribution/Client/Configure.hs
Expand Up @@ -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 )
Expand All @@ -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 )
Expand All @@ -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] [])
Expand Down Expand Up @@ -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
Expand Down
6 changes: 3 additions & 3 deletions cabal-install/Distribution/Client/Dependency.hs
Expand Up @@ -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
Expand Down Expand Up @@ -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'
Expand Down
4 changes: 2 additions & 2 deletions cabal-install/Distribution/Client/Install.hs
Expand Up @@ -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(..)
Expand Down Expand Up @@ -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
Expand Down
4 changes: 2 additions & 2 deletions cabal-install/Distribution/Client/ProjectConfig.hs
Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand Down
29 changes: 15 additions & 14 deletions cabal-install/Distribution/Client/ProjectConfig/Legacy.hs
Expand Up @@ -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
Expand Down Expand Up @@ -785,8 +785,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
Expand Down Expand Up @@ -834,17 +835,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]
Expand Down
2 changes: 1 addition & 1 deletion cabal-install/Distribution/Client/ProjectPlanning.hs
Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion cabal-install/Distribution/Client/Setup.hs
Expand Up @@ -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'.
Expand Down

0 comments on commit f3c47af

Please sign in to comment.