Commit 9a5b601b authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

New 'install' option: '--allow-newer'.

parent b62e3bc0
...@@ -18,6 +18,7 @@ module Distribution.Client.Setup ...@@ -18,6 +18,7 @@ module Distribution.Client.Setup
, buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)
, testCommand, benchmarkCommand , testCommand, benchmarkCommand
, installCommand, InstallFlags(..), installOptions, defaultInstallFlags , installCommand, InstallFlags(..), installOptions, defaultInstallFlags
, AllowNewer(..)
, listCommand, ListFlags(..) , listCommand, ListFlags(..)
, updateCommand , updateCommand
, upgradeCommand , upgradeCommand
...@@ -65,7 +66,8 @@ import Distribution.Simple.InstallDirs ...@@ -65,7 +66,8 @@ import Distribution.Simple.InstallDirs
import Distribution.Version import Distribution.Version
( Version(Version), anyVersion, thisVersion ) ( Version(Version), anyVersion, thisVersion )
import Distribution.Package import Distribution.Package
( PackageIdentifier, packageName, packageVersion, Dependency(..) ) ( PackageIdentifier, PackageName, packageName, packageVersion
, Dependency(..) )
import Distribution.PackageDescription import Distribution.PackageDescription
( RepoKind(..) ) ( RepoKind(..) )
import Distribution.Text import Distribution.Text
...@@ -73,7 +75,7 @@ import Distribution.Text ...@@ -73,7 +75,7 @@ import Distribution.Text
import Distribution.ReadE import Distribution.ReadE
( ReadE(..), readP_to_E, succeedReadE ) ( ReadE(..), readP_to_E, succeedReadE )
import qualified Distribution.Compat.ReadP as Parse import qualified Distribution.Compat.ReadP as Parse
( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, (+++) ) ( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, sepBy1, (+++) )
import Distribution.Verbosity import Distribution.Verbosity
( Verbosity, normal ) ( Verbosity, normal )
import Distribution.Simple.Utils import Distribution.Simple.Utils
...@@ -802,7 +804,8 @@ data InstallFlags = InstallFlags { ...@@ -802,7 +804,8 @@ data InstallFlags = InstallFlags {
installBuildReports :: Flag ReportLevel, installBuildReports :: Flag ReportLevel,
installSymlinkBinDir :: Flag FilePath, installSymlinkBinDir :: Flag FilePath,
installOneShot :: Flag Bool, installOneShot :: Flag Bool,
installNumJobs :: Flag (Maybe Int) installNumJobs :: Flag (Maybe Int),
installAllowNewer :: Flag AllowNewer
} }
defaultInstallFlags :: InstallFlags defaultInstallFlags :: InstallFlags
...@@ -826,11 +829,28 @@ defaultInstallFlags = InstallFlags { ...@@ -826,11 +829,28 @@ defaultInstallFlags = InstallFlags {
installBuildReports = Flag NoReports, installBuildReports = Flag NoReports,
installSymlinkBinDir = mempty, installSymlinkBinDir = mempty,
installOneShot = Flag False, installOneShot = Flag False,
installNumJobs = mempty installNumJobs = mempty,
installAllowNewer = Flag AllowNewerNone
} }
where where
docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html") docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")
data AllowNewer = AllowNewerNone | AllowNewerSome [PackageName] | AllowNewerAll
deriving (Eq, Show)
allowNewerParser :: ReadE AllowNewer
allowNewerParser = ReadE $ \s ->
case s of
"" -> Right AllowNewerNone
"False" -> Right AllowNewerNone
"True" -> Right AllowNewerAll
_ ->
case readPToMaybe pkgsParser s of
Just pkgs -> Right . AllowNewerSome $ pkgs
Nothing -> Left ("Cannot parse the list of packages: " ++ s)
where
pkgsParser = Parse.sepBy1 parse (Parse.char ',')
defaultMaxBackjumps :: Int defaultMaxBackjumps :: Int
defaultMaxBackjumps = 200 defaultMaxBackjumps = 200
...@@ -933,6 +953,18 @@ installOptions showOrParseArgs = ...@@ -933,6 +953,18 @@ installOptions showOrParseArgs =
installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v }) installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v })
(yesNoOpt showOrParseArgs) (yesNoOpt showOrParseArgs)
, option [] ["allow-newer"]
"Ignore upper bounds in dependencies on some or all packages."
installAllowNewer (\v flags -> flags { installAllowNewer = v})
(optArg "PKGS"
(fmap Flag allowNewerParser) (Flag AllowNewerAll)
(\f -> case f of
Flag AllowNewerNone -> [Just "False"]
Flag AllowNewerAll -> [Just "True"]
Flag (AllowNewerSome pkgs) ->
[Just . intercalate "," . map display $ pkgs]
NoFlag -> []))
, option [] ["upgrade-dependencies"] , option [] ["upgrade-dependencies"]
"Pick the latest version for all dependencies, rather than trying to pick an installed version." "Pick the latest version for all dependencies, rather than trying to pick an installed version."
installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v }) installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v })
...@@ -1019,7 +1051,8 @@ instance Monoid InstallFlags where ...@@ -1019,7 +1051,8 @@ instance Monoid InstallFlags where
installBuildReports = mempty, installBuildReports = mempty,
installSymlinkBinDir = mempty, installSymlinkBinDir = mempty,
installOneShot = mempty, installOneShot = mempty,
installNumJobs = mempty installNumJobs = mempty,
installAllowNewer = mempty
} }
mappend a b = InstallFlags { mappend a b = InstallFlags {
installDocumentation = combine installDocumentation, installDocumentation = combine installDocumentation,
...@@ -1041,7 +1074,8 @@ instance Monoid InstallFlags where ...@@ -1041,7 +1074,8 @@ instance Monoid InstallFlags where
installBuildReports = combine installBuildReports, installBuildReports = combine installBuildReports,
installSymlinkBinDir = combine installSymlinkBinDir, installSymlinkBinDir = combine installSymlinkBinDir,
installOneShot = combine installOneShot, installOneShot = combine installOneShot,
installNumJobs = combine installNumJobs installNumJobs = combine installNumJobs,
installAllowNewer = combine installAllowNewer
} }
where combine field = field a `mappend` field b where combine field = field a `mappend` field b
......
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