Commit ac039772 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov

Move 'configAllowNewer' to 'ConfigFlags'.

parent 2251d56f
......@@ -34,6 +34,7 @@ module Distribution.Simple.Setup (
GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand,
ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand,
AllowNewer(..), isAllowNewer,
configAbsolutePaths, readPackageDbList, showPackageDbList,
CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand,
InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand,
......@@ -64,7 +65,8 @@ module Distribution.Simple.Setup (
fromFlagOrDefault,
flagToMaybe,
flagToList,
boolOpt, boolOpt', trueArg, falseArg, optionVerbosity, optionNumJobs ) where
boolOpt, boolOpt', trueArg, falseArg,
optionVerbosity, optionNumJobs, readPToMaybe ) where
import Distribution.Compiler
import Distribution.ReadE
......@@ -86,6 +88,7 @@ import Distribution.Compat.Semigroup as Semi
import Control.Monad (liftM)
import Data.List ( sort )
import Data.Maybe ( listToMaybe )
import Data.Char ( isSpace, isAlpha )
import GHC.Generics (Generic)
......@@ -252,6 +255,57 @@ instance Semigroup GlobalFlags where
-- * Config flags
-- ------------------------------------------------------------
-- | Policy for relaxing upper bounds in dependencies. For example, given
-- '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 =
-- | Default: honor the upper bounds in all dependencies, never choose
-- versions newer than allowed.
AllowNewerNone
-- | Ignore upper bounds in dependencies on the given packages.
| AllowNewerSome [PackageName]
-- | Ignore upper bounds in dependencies on all packages.
| AllowNewerAll
deriving (Eq, Ord, Read, Show, Generic)
instance Binary AllowNewer
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)
instance Monoid AllowNewer where
mempty = AllowNewerNone
mappend = (Semi.<>)
-- | Convert 'AllowNewer' to a boolean.
isAllowNewer :: AllowNewer -> Bool
isAllowNewer AllowNewerNone = False
isAllowNewer (AllowNewerSome _) = True
isAllowNewer AllowNewerAll = True
allowNewerParser :: ReadE AllowNewer
allowNewerParser = ReadE $ \s ->
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 ',')
allowNewerPrinter :: Flag AllowNewer -> [Maybe String]
allowNewerPrinter (Flag AllowNewerNone) = [Just "False"]
allowNewerPrinter (Flag AllowNewerAll) = [Just "True"]
allowNewerPrinter (Flag (AllowNewerSome pkgs)) =
[Just . intercalate "," . map display $ pkgs]
allowNewerPrinter NoFlag = []
-- | Flags to @configure@ command.
--
-- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags'
......@@ -319,7 +373,8 @@ data ConfigFlags = ConfigFlags {
configFlagError :: Flag String,
-- ^Halt and show an error message indicating an error in flag assignment
configRelocatable :: Flag Bool, -- ^ Enable relocatable package built
configDebugInfo :: Flag DebugInfoLevel -- ^ Emit debug info.
configDebugInfo :: Flag DebugInfoLevel, -- ^ Emit debug info.
configAllowNewer :: Flag AllowNewer -- ^
}
deriving (Generic, Read, Show)
......@@ -365,7 +420,8 @@ defaultConfigFlags progConf = emptyConfigFlags {
configExactConfiguration = Flag False,
configFlagError = NoFlag,
configRelocatable = Flag False,
configDebugInfo = Flag NoDebugInfo
configDebugInfo = Flag NoDebugInfo,
configAllowNewer = NoFlag
}
configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags
......@@ -602,6 +658,13 @@ configureOptions showOrParseArgs =
configLibCoverage (\v flags -> flags { configLibCoverage = v })
(boolOpt [] [])
,option [] ["allow-newer"]
("Ignore upper bounds in all dependencies or DEPS")
configAllowNewer (\v flags -> flags { configAllowNewer = v})
(optArg "DEPS"
(fmap Flag allowNewerParser) (Flag AllowNewerAll)
allowNewerPrinter)
,option "" ["exact-configuration"]
"All direct dependencies and flags are provided on the command line."
configExactConfiguration
......@@ -769,7 +832,8 @@ instance Monoid ConfigFlags where
configBenchmarks = mempty,
configFlagError = mempty,
configRelocatable = mempty,
configDebugInfo = mempty
configDebugInfo = mempty,
configAllowNewer = mempty
}
mappend = (Semi.<>)
......@@ -817,9 +881,13 @@ instance Semigroup ConfigFlags where
configBenchmarks = combine configBenchmarks,
configFlagError = combine configFlagError,
configRelocatable = combine configRelocatable,
configDebugInfo = combine configDebugInfo
configDebugInfo = combine configDebugInfo,
configAllowNewer = combineAllowNewer (configAllowNewer a)
(configAllowNewer b)
}
where combine field = field a `mappend` field b
combineAllowNewer (Flag fa) (Flag fb) = (Flag $ fa `mappend` fb)
combineAllowNewer fa fb = fa `mappend` fb
-- ------------------------------------------------------------
-- * Copy flags
......@@ -2156,6 +2224,10 @@ optionNumJobs get set =
-- * Other Utils
-- ------------------------------------------------------------
readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
, all isSpace s ]
-- | Arguments to pass to a @configure@ script, e.g. generated by
-- @autoconf@.
configureArgs :: Bool -> ConfigFlags -> [String]
......
......@@ -324,7 +324,8 @@ instance Semigroup SavedConfig where
configLibCoverage = combine configLibCoverage,
configExactConfiguration = combine configExactConfiguration,
configFlagError = combine configFlagError,
configRelocatable = combine configRelocatable
configRelocatable = combine configRelocatable,
configAllowNewer = combine configAllowNewer
}
where
combine = combine' savedConfigureFlags
......@@ -337,8 +338,7 @@ instance Semigroup SavedConfig where
configExConstraints = lastNonEmpty configExConstraints,
-- TODO: NubListify
configPreferences = lastNonEmpty configPreferences,
configSolver = combine configSolver,
configAllowNewer = combine configAllowNewer
configSolver = combine configSolver
}
where
combine = combine' savedConfigureExFlags
......
......@@ -20,7 +20,7 @@ module Distribution.Client.Configure (
import Distribution.Client.Dependency
import Distribution.Client.Dependency.Types
( AllowNewer(..), isAllowNewer, ConstraintSource(..)
( ConstraintSource(..)
, LabeledPackageConstraint(..), showConstraintSource )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
......@@ -62,6 +62,8 @@ import Distribution.Version
( anyVersion, thisVersion )
import Distribution.Simple.Utils as Utils
( warn, notice, info, debug, die )
import Distribution.Simple.Setup
( AllowNewer(..), isAllowNewer )
import Distribution.System
( Platform )
import Distribution.Text ( display )
......@@ -78,14 +80,14 @@ import Data.Maybe (isJust, fromMaybe)
-- | Choose the Cabal version such that the setup scripts compiled against this
-- version will support the given command-line flags.
chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange
chooseCabalVersion configExFlags maybeVersion =
chooseCabalVersion :: ConfigFlags -> Maybe Version -> VersionRange
chooseCabalVersion configFlags maybeVersion =
maybe defaultVersionRange thisVersion maybeVersion
where
-- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed
-- for '--allow-newer' to work.
allowNewer = fromFlagOrDefault False $
fmap isAllowNewer (configAllowNewer configExFlags)
fmap isAllowNewer (configAllowNewer configFlags)
defaultVersionRange = if allowNewer
then orLaterVersion (Version [1,19,2] [])
......@@ -152,7 +154,7 @@ configure verbosity packageDBs repoCtxt comp platform conf
(useDistPref defaultSetupScriptOptions)
(configDistPref configFlags))
(chooseCabalVersion
configExFlags
configFlags
(flagToMaybe (configCabalVersion configExFlags)))
Nothing
False
......@@ -288,7 +290,7 @@ planLocalPackage verbosity comp platform configFlags configExFlags
resolverParams =
removeUpperBounds (fromFlagOrDefault AllowNewerNone $
configAllowNewer configExFlags)
configAllowNewer configFlags)
. addPreferences
-- preferences from the config file or command line
......
......@@ -78,7 +78,7 @@ import Distribution.Client.Dependency.Types
, PackageConstraint(..), showPackageConstraint
, LabeledPackageConstraint(..), unlabelPackageConstraint
, ConstraintSource(..), showConstraintSource
, AllowNewer(..), PackagePreferences(..), InstalledPreference(..)
, PackagePreferences(..), InstalledPreference(..)
, PackagesPreferenceDefault(..)
, Progress(..), foldProgress )
import Distribution.Client.Sandbox.Types
......@@ -110,6 +110,8 @@ import Distribution.Client.Utils
( duplicates, duplicatesBy, mergeBy, MergeResult(..) )
import Distribution.Simple.Utils
( comparing, warn, info )
import Distribution.Simple.Setup
( AllowNewer(..) )
import Distribution.Text
( display )
import Distribution.Verbosity
......
......@@ -19,7 +19,6 @@ module Distribution.Client.Dependency.Types (
DependencyResolver,
ResolverPackage(..),
AllowNewer(..), isAllowNewer,
PackageConstraint(..),
showPackageConstraint,
PackagePreferences(..),
......@@ -211,31 +210,6 @@ data PackagesPreferenceDefault =
| PreferLatestForSelected
deriving Show
-- | Policy for relaxing upper bounds in dependencies. For example, given
-- '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 =
-- | Default: honor the upper bounds in all dependencies, never choose
-- versions newer than allowed.
AllowNewerNone
-- | Ignore upper bounds in dependencies on the given packages.
| AllowNewerSome [PackageName]
-- | Ignore upper bounds in dependencies on all packages.
| AllowNewerAll
deriving (Eq, Ord, Show, Generic)
instance Binary AllowNewer
-- | Convert 'AllowNewer' to a boolean.
isAllowNewer :: AllowNewer -> Bool
isAllowNewer AllowNewerNone = False
isAllowNewer (AllowNewerSome _) = True
isAllowNewer AllowNewerAll = True
-- | A type to represent the unfolding of an expensive long running
-- calculation that may fail. We may get intermediate steps before the final
-- result which may be used to indicate progress and\/or logging messages.
......
......@@ -417,7 +417,7 @@ planPackages comp platform mSandboxPkgInfo solver
maxBackjumps = fromFlag (installMaxBackjumps installFlags)
upgradeDeps = fromFlag (installUpgradeDeps installFlags)
onlyDeps = fromFlag (installOnlyDeps installFlags)
allowNewer = fromFlag (configAllowNewer configExFlags)
allowNewer = fromFlag (configAllowNewer configFlags)
-- | Remove the provided targets from the install plan.
pruneInstallPlan :: Package targetpkg
......@@ -1092,7 +1092,7 @@ performInstallations verbosity
platform
conf
distPref
(chooseCabalVersion configExFlags (libVersion miscOptions))
(chooseCabalVersion configFlags (libVersion miscOptions))
(Just lock)
parallelInstall
index
......
......@@ -58,7 +58,7 @@ import Distribution.Client.Types
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.Dependency.Types
( AllowNewer(..), PreSolver(..), ConstraintSource(..) )
( PreSolver(..), ConstraintSource(..) )
import qualified Distribution.Client.Init.Types as IT
( InitFlags(..), PackageType(..) )
import Distribution.Client.Targets
......@@ -79,7 +79,8 @@ import Distribution.Simple.Setup
, SDistFlags(..), HaddockFlags(..)
, readPackageDbList, showPackageDbList
, Flag(..), toFlag, flagToMaybe, flagToList
, optionVerbosity, boolOpt, boolOpt', trueArg, falseArg, optionNumJobs )
, optionVerbosity, boolOpt, boolOpt', trueArg, falseArg
, readPToMaybe, optionNumJobs )
import Distribution.Simple.InstallDirs
( PathTemplate, InstallDirs(sysconfdir)
, toPathTemplate, fromPathTemplate )
......@@ -94,7 +95,7 @@ import Distribution.Text
import Distribution.ReadE
( ReadE(..), readP_to_E, succeedReadE )
import qualified Distribution.Compat.ReadP as Parse
( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, sepBy1, (+++) )
( ReadP, readS_to_P, char, munch1, pfail, (+++) )
import Distribution.Compat.Semigroup
( Semigroup((<>)) )
import Distribution.Verbosity
......@@ -107,11 +108,11 @@ import Distribution.Client.GlobalFlags
)
import Data.Char
( isSpace, isAlphaNum )
( isAlphaNum )
import Data.List
( intercalate, deleteFirstsBy )
import Data.Maybe
( listToMaybe, maybeToList, fromMaybe )
( maybeToList, fromMaybe )
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
( Monoid(..) )
......@@ -364,8 +365,13 @@ filterConfigureFlags flags cabalLibVersion
| cabalLibVersion < Version [1,23,0] [] = flags_1_22_0
| otherwise = flags_latest
where
-- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
flags_latest = flags { configConstraints = [] }
flags_latest = flags {
-- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
configConstraints = [],
-- Passing '--allow-newer' to Setup.hs is unnecessary, we use
-- '--exact-configuration' instead.
configAllowNewer = NoFlag
}
-- Cabal < 1.23 doesn't know about '--profiling-detail'.
flags_1_22_0 = flags_latest { configProfDetail = NoFlag
......@@ -418,14 +424,12 @@ data ConfigExFlags = ConfigExFlags {
configCabalVersion :: Flag Version,
configExConstraints:: [(UserConstraint, ConstraintSource)],
configPreferences :: [Dependency],
configSolver :: Flag PreSolver,
configAllowNewer :: Flag AllowNewer
configSolver :: Flag PreSolver
}
deriving (Eq, Generic)
defaultConfigExFlags :: ConfigExFlags
defaultConfigExFlags = mempty { configSolver = Flag defaultSolver
, configAllowNewer = Flag AllowNewerNone }
defaultConfigExFlags = mempty { configSolver = Flag defaultSolver }
configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
......@@ -469,23 +473,14 @@ configureExOptions _showOrParseArgs src =
, optionSolver configSolver (\v flags -> flags { configSolver = v })
, option [] ["allow-newer"]
("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)
configAllowNewer (\v flags -> flags { configAllowNewer = v})
(optArg allowNewerArgument
(fmap Flag allowNewerParser) (Flag AllowNewerAll)
allowNewerPrinter)
]
where allowNewerArgument = "DEPS"
instance Monoid ConfigExFlags where
mempty = ConfigExFlags {
configCabalVersion = mempty,
configExConstraints= mempty,
configPreferences = mempty,
configSolver = mempty,
configAllowNewer = mempty
configSolver = mempty
}
mappend = (<>)
......@@ -494,8 +489,7 @@ instance Semigroup ConfigExFlags where
configCabalVersion = combine configCabalVersion,
configExConstraints= combine configExConstraints,
configPreferences = combine configPreferences,
configSolver = combine configSolver,
configAllowNewer = combine configAllowNewer
configSolver = combine configSolver
}
where combine field = field a `mappend` field b
......@@ -1242,27 +1236,6 @@ defaultInstallFlags = InstallFlags {
docIndexFile = toPathTemplate ("$datadir" </> "doc"
</> "$arch-$os-$compiler" </> "index.html")
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 ',')
allowNewerPrinter :: Flag AllowNewer -> [Maybe String]
allowNewerPrinter (Flag AllowNewerNone) = [Just "False"]
allowNewerPrinter (Flag AllowNewerAll) = [Just "True"]
allowNewerPrinter (Flag (AllowNewerSome pkgs)) =
[Just . intercalate "," . map display $ pkgs]
allowNewerPrinter NoFlag = []
defaultMaxBackjumps :: Int
defaultMaxBackjumps = 2000
......@@ -2290,10 +2263,6 @@ parsePackageArgs = parsePkgArgs []
show arg ++ " is not valid syntax for a package name or"
++ " package dependency."
readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
, all isSpace s ]
parseDependencyOrPackageId :: Parse.ReadP r Dependency
parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse
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