Commit 0fdf2174 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺 Committed by GitHub
Browse files

Merge pull request #4669

Augment `--allow-{newer,older}` syntax to support wildcards
parents a8036999 8bcd719a
......@@ -754,16 +754,36 @@ The following settings control the behavior of the dependency solver:
-- Disregard all upper bounds when dependency solving
allow-newer: all
-- Disregard all `^>=`-style upper bounds when dependency solving
allow-newer: ^all
For consistency, there is also the explicit wildcard scope syntax
``*`` (or its alphabetic synonym ``all``). Consequently, the first
part of the example above is equivalent to the explicitly scoped
variant:
``*`` (or its alphabetic synonym ``all``). Consequently, the
examples above are equivalent to the explicitly scoped variants:
::
allow-newer: all:bar, *:baz, *:^quux
allow-newer: *:*
allow-newer: all:all
allow-newer: *:^*
allow-newer: all:^all
In order to ignore all bounds specified by a package ``pkg-1.2.3``
you can combine scoping with a right-hand-side wildcard like so
::
-- Disregard any upper bounds specified by pkg-1.2.3
allow-newer: pkg-1.2.3:*
-- Disregard only `^>=`-style upper bounds in pkg-1.2.3
allow-newer: pkg-1.2.3:^*
:cfg-field:`allow-newer` is often used in conjunction with a constraint
(in the cfg-field:`constraints` field) forcing the usage of a specific,
newer version of a package.
......
......@@ -46,7 +46,7 @@ module Distribution.Client.Config (
import Distribution.Client.Types
( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo
, AllowOlder(..), AllowNewer(..), RelaxDeps(..)
, AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps
)
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
......@@ -704,8 +704,8 @@ commentSavedConfig = do
},
savedInstallFlags = defaultInstallFlags,
savedConfigureExFlags = defaultConfigExFlags {
configAllowNewer = Just (AllowNewer RelaxDepsNone),
configAllowOlder = Just (AllowOlder RelaxDepsNone)
configAllowNewer = Just (AllowNewer mempty),
configAllowOlder = Just (AllowOlder mempty)
},
savedConfigureFlags = (defaultConfigFlags defaultProgramDb) {
configUserInstall = toFlag defaultUserInstall
......@@ -862,12 +862,12 @@ configFieldDescriptions src =
optional = Parse.option mempty . fmap toFlag
showRelaxDeps Nothing = mempty
showRelaxDeps (Just RelaxDepsNone) = Disp.text "False"
showRelaxDeps (Just _) = Disp.text "True"
showRelaxDeps Nothing = mempty
showRelaxDeps (Just rd) | isRelaxDeps rd = Disp.text "True"
| otherwise = Disp.text "False"
toRelaxDeps True = RelaxDepsAll
toRelaxDeps False = RelaxDepsNone
toRelaxDeps False = mempty
-- TODO: next step, make the deprecated fields elicit a warning.
......
......@@ -97,20 +97,14 @@ chooseCabalVersion configExFlags maybeVersion =
-- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed
-- for '--allow-newer' to work.
allowNewer = isRelaxDeps
(maybe RelaxDepsNone unAllowNewer $ configAllowNewer configExFlags)
(maybe mempty unAllowNewer $ configAllowNewer configExFlags)
allowOlder = isRelaxDeps
(maybe RelaxDepsNone unAllowOlder $ configAllowOlder configExFlags)
(maybe mempty unAllowOlder $ configAllowOlder configExFlags)
defaultVersionRange = if allowOlder || allowNewer
then orLaterVersion (mkVersion [1,19,2])
else anyVersion
-- | Convert 'RelaxDeps' to a boolean.
isRelaxDeps :: RelaxDeps -> Bool
isRelaxDeps RelaxDepsNone = False
isRelaxDeps (RelaxDepsSome _) = True
isRelaxDeps RelaxDepsAll = True
-- | Configure the package found in the local directory
configure :: Verbosity
-> PackageDBStack
......@@ -325,9 +319,9 @@ planLocalPackage verbosity comp platform configFlags configExFlags
resolverParams =
removeLowerBounds
(fromMaybe (AllowOlder RelaxDepsNone) $ configAllowOlder configExFlags)
(fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags)
. removeUpperBounds
(fromMaybe (AllowNewer RelaxDepsNone) $ configAllowNewer configExFlags)
(fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags)
. addPreferences
-- preferences from the config file or command line
......
......@@ -73,7 +73,7 @@ import Distribution.Client.Types
( SourcePackageDb(SourcePackageDb)
, UnresolvedPkgLoc, UnresolvedSourcePackage
, AllowNewer(..), AllowOlder(..), RelaxDeps(..), RelaxedDep(..)
, RelaxDepScope(..), RelaxDepMod(..)
, RelaxDepScope(..), RelaxDepMod(..), RelaxDepSubject(..), isRelaxDeps
)
import Distribution.Client.Dependency.Types
( PreSolver(..), Solver(..)
......@@ -434,8 +434,8 @@ data RelaxKind = RelaxLower | RelaxUpper
-- | Common internal implementation of 'removeLowerBounds'/'removeUpperBounds'
removeBounds :: RelaxKind -> RelaxDeps -> DepResolverParams -> DepResolverParams
removeBounds _relKind RelaxDepsNone params = params -- no-op optimisation
removeBounds relKind relDeps params =
removeBounds _ rd params | not (isRelaxDeps rd) = params -- no-op optimisation
removeBounds relKind relDeps params =
params {
depResolverSourcePkgIndex = sourcePkgIndex'
}
......@@ -454,9 +454,10 @@ removeBounds relKind relDeps params =
relaxPackageDeps :: RelaxKind
-> RelaxDeps
-> PD.GenericPackageDescription -> PD.GenericPackageDescription
relaxPackageDeps _ RelaxDepsNone gpd = gpd -- subsumed by no-op case in 'removeBounds'
relaxPackageDeps _ rd gpd | not (isRelaxDeps rd) = gpd -- subsumed by no-op case in 'removeBounds'
relaxPackageDeps relKind RelaxDepsAll gpd = PD.transformAllBuildDepends relaxAll gpd
where
relaxAll :: Dependency -> Dependency
relaxAll (Dependency pkgName verRange) =
Dependency pkgName (removeBound relKind RelaxDepModNone verRange)
......@@ -467,7 +468,7 @@ relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd =
thisPkgId = packageId gpd
depsToRelax = Map.fromList $ mapMaybe f depsToRelax0
f :: RelaxedDep -> Maybe (PackageName,RelaxDepMod)
f :: RelaxedDep -> Maybe (RelaxDepSubject,RelaxDepMod)
f (RelaxedDep scope rdm p) = case scope of
RelaxDepScopeAll -> Just (p,rdm)
RelaxDepScopePackage p0
......@@ -479,7 +480,11 @@ relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd =
relaxSome :: Dependency -> Dependency
relaxSome d@(Dependency depName verRange)
| Just relMod <- Map.lookup depName depsToRelax =
| Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax =
-- a '*'-subject acts absorbing, for consistency with
-- the 'Semigroup RelaxDeps' instance
Dependency depName (removeBound relKind relMod verRange)
| Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax =
Dependency depName (removeBound relKind relMod verRange)
| otherwise = d -- no-op
......
......@@ -458,9 +458,9 @@ planPackages verbosity comp platform mSandboxPkgInfo solver
upgradeDeps = fromFlag (installUpgradeDeps installFlags)
onlyDeps = fromFlag (installOnlyDeps installFlags)
allowOlder = fromMaybe (AllowOlder RelaxDepsNone)
allowOlder = fromMaybe (AllowOlder mempty)
(configAllowOlder configExFlags)
allowNewer = fromMaybe (AllowNewer RelaxDepsNone)
allowNewer = fromMaybe (AllowNewer mempty)
(configAllowNewer configExFlags)
-- | Remove the provided targets from the install plan.
......
......@@ -221,8 +221,8 @@ resolveSolverSettings ProjectConfig{
defaults = mempty {
projectConfigSolver = Flag defaultSolver,
projectConfigAllowOlder = Just (AllowOlder RelaxDepsNone),
projectConfigAllowNewer = Just (AllowNewer RelaxDepsNone),
projectConfigAllowOlder = Just (AllowOlder mempty),
projectConfigAllowNewer = Just (AllowNewer mempty),
projectConfigMaxBackjumps = Flag defaultMaxBackjumps,
projectConfigReorderGoals = Flag (ReorderGoals False),
projectConfigCountConflicts = Flag (CountConflicts True),
......
......@@ -26,7 +26,7 @@ import Distribution.Client.Compat.Prelude
import Distribution.Client.ProjectConfig.Types
import Distribution.Client.Types
( RemoteRepo(..), emptyRemoteRepo
, AllowNewer(..), AllowOlder(..), RelaxDeps(..) )
, AllowNewer(..), AllowOlder(..) )
import Distribution.Client.Config
( SavedConfig(..), remoteRepoFields )
......@@ -830,12 +830,12 @@ legacySharedConfigFieldDescrs =
configPreferences (\v conf -> conf { configPreferences = v })
, simpleField "allow-older"
(maybe mempty dispRelaxDeps) (fmap Just parseRelaxDeps)
(maybe mempty disp) (fmap Just parse)
(fmap unAllowOlder . configAllowOlder)
(\v conf -> conf { configAllowOlder = fmap AllowOlder v })
, simpleField "allow-newer"
(maybe mempty dispRelaxDeps) (fmap Just parseRelaxDeps)
(maybe mempty disp) (fmap Just parse)
(fmap unAllowNewer . configAllowNewer)
(\v conf -> conf { configAllowNewer = fmap AllowNewer v })
]
......@@ -870,18 +870,6 @@ legacySharedConfigFieldDescrs =
where
constraintSrc = ConstraintSourceProjectConfig "TODO"
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]
legacyPackageConfigFieldDescrs =
......
......@@ -598,7 +598,6 @@ relaxDepsParser =
relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String]
relaxDepsPrinter Nothing = []
relaxDepsPrinter (Just RelaxDepsNone) = []
relaxDepsPrinter (Just RelaxDepsAll) = [Nothing]
relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . display) $ pkgs
......
......@@ -42,7 +42,7 @@ import Distribution.Types.AnnotatedId
import Distribution.Types.UnitId
( UnitId )
import Distribution.Types.PackageName
( PackageName )
( PackageName, mkPackageName )
import Distribution.Types.ComponentName
( ComponentName(..) )
......@@ -56,6 +56,7 @@ import Distribution.Solver.Types.PackageFixedDeps
import Distribution.Solver.Types.SourcePackage
import Distribution.Compat.Graph (IsNode(..))
import qualified Distribution.Compat.ReadP as Parse
import Distribution.ParseUtils (parseOptCommaList)
import Distribution.Simple.Utils (ordNub)
import Distribution.Text (Text(..))
......@@ -396,23 +397,25 @@ newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps }
-- (respectively).
data RelaxDeps =
-- | Default: honor the bounds in all dependencies, never choose
-- versions newer than allowed.
RelaxDepsNone
-- | Ignore upper bounds in dependencies on the given packages.
-- | Ignore upper bounds in some (or no) dependencies on the given packages.
--
-- Note that 'RelaxDepsNone' and @RelaxDepsSome []@ are equivalent
-- (TODO: change @[RelaxedDep]@ to @NonEmpty RelaxDep@ or remove 'RelaxDepsNone')
| RelaxDepsSome [RelaxedDep]
-- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all
-- dependencies, never choose versions newer than allowed.
RelaxDepsSome [RelaxedDep]
-- | Ignore upper bounds in dependencies on all packages.
--
-- __Note__: This is should be semantically equivalent to
--
-- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]
--
-- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep')
| RelaxDepsAll
deriving (Eq, Read, Show, Generic)
-- | Dependencies can be relaxed either for all packages in the install plan, or
-- only for some packages.
data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !PackageName
data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject
deriving (Eq, Read, Show, Generic)
-- | Specify the scope of a relaxation, i.e. limit which depending
......@@ -430,15 +433,20 @@ data RelaxDepMod = RelaxDepModNone -- ^ Default semantics
| RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints
deriving (Eq, Read, Show, Generic)
-- | Express whether to relax bounds /on/ @all@ packages, or a single package
data RelaxDepSubject = RelaxDepSubjectAll
| RelaxDepSubjectPkg !PackageName
deriving (Eq, Ord, Read, Show, Generic)
instance Text RelaxedDep where
disp (RelaxedDep scope rdmod dep) = case scope of
RelaxDepScopeAll -> modDep
disp (RelaxedDep scope rdmod subj) = case scope of
RelaxDepScopeAll -> Disp.text "all:" Disp.<> modDep
RelaxDepScopePackage p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep
RelaxDepScopePackageId p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep
where
modDep = case rdmod of
RelaxDepModNone -> disp dep
RelaxDepModCaret -> Disp.char '^' Disp.<> disp dep
RelaxDepModNone -> disp subj
RelaxDepModCaret -> Disp.char '^' Disp.<> disp subj
parse = RelaxedDep <$> scopeP <*> modP <*> parse
where
......@@ -458,22 +466,62 @@ instance Text RelaxedDep where
when (pkgVersion p0 == nullVersion) Parse.pfail
pure p0
instance Text RelaxDepSubject where
disp RelaxDepSubjectAll = Disp.text "all"
disp (RelaxDepSubjectPkg pn) = disp pn
parse = (pure RelaxDepSubjectAll <* Parse.char '*') Parse.<++ pkgn
where
pkgn = do
pn <- parse
pure (if (pn == mkPackageName "all")
then RelaxDepSubjectAll
else RelaxDepSubjectPkg pn)
instance Text RelaxDeps where
disp rd | not (isRelaxDeps rd) = Disp.text "none"
disp (RelaxDepsSome pkgs) = Disp.fsep .
Disp.punctuate Disp.comma .
map disp $ pkgs
disp RelaxDepsAll = Disp.text "all"
parse = (const mempty <$> ((Parse.string "none" Parse.+++
Parse.string "None") <* Parse.eof))
Parse.<++ (const RelaxDepsAll <$> ((Parse.string "all" Parse.+++
Parse.string "All" Parse.+++
Parse.string "*") <* Parse.eof))
Parse.<++ ( RelaxDepsSome <$> parseOptCommaList parse)
instance Binary RelaxDeps
instance Binary RelaxDepMod
instance Binary RelaxDepScope
instance Binary RelaxDepSubject
instance Binary RelaxedDep
instance Binary AllowNewer
instance Binary AllowOlder
-- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations
--
-- Equivalent to @isRelaxDeps = (/= 'mempty')@
isRelaxDeps :: RelaxDeps -> Bool
isRelaxDeps (RelaxDepsSome []) = False
isRelaxDeps (RelaxDepsSome (_:_)) = True
isRelaxDeps RelaxDepsAll = True
-- | 'RelaxDepsAll' is the /absorbing element/
instance Semigroup RelaxDeps where
RelaxDepsNone <> r = r
-- identity element
RelaxDepsSome [] <> r = r
l@(RelaxDepsSome _) <> RelaxDepsSome [] = l
-- absorbing element
l@RelaxDepsAll <> _ = l
l@(RelaxDepsSome _) <> RelaxDepsNone = l
(RelaxDepsSome _) <> r@RelaxDepsAll = r
-- combining non-{identity,absorbing} elements
(RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b)
-- | @'RelaxDepsSome' []@ is the /identity element/
instance Monoid RelaxDeps where
mempty = RelaxDepsNone
mempty = RelaxDepsSome []
mappend = (<>)
instance Semigroup AllowNewer where
......
......@@ -13,8 +13,8 @@
* Completed the 'new-bench' command. Same as above.
* '--allow-{newer,older}' syntax has been enhanced. Dependency
relaxation can be now limited to a specific release of a package,
plus there's a now syntax for relaxing only caret dependencies
(#4575).
plus there's a now syntax for relaxing only caret-style (i.e. '^>=')
dependencies (#4575, #4669).
2.0.0.0 Ryan Thomas <ryan@ryant.org> July 2017
* Removed the '--root-cmd' parameter of the 'install' command
......
......@@ -65,6 +65,8 @@ tests =
, testGroup "individual parser tests"
[ testProperty "package location" prop_parsePackageLocationTokenQ
, testProperty "RelaxedDep" prop_roundtrip_printparse_RelaxedDep
, testProperty "RelaxDeps" prop_roundtrip_printparse_RelaxDeps
, testProperty "RelaxDeps'" prop_roundtrip_printparse_RelaxDeps'
]
, testGroup "ProjectConfig printing/parsing round trip"
......@@ -234,19 +236,38 @@ prop_roundtrip_printparse_specific config =
-- Individual Parser tests
--
-- | Helper to parse a given string
--
-- Succeeds only if there is a unique complete parse
runReadP :: Parse.ReadP a a -> String -> Maybe a
runReadP parser s = case [ x | (x,"") <- Parse.readP_to_S parser s ] of
[x'] -> Just x'
_ -> Nothing
prop_parsePackageLocationTokenQ :: PackageLocationString -> Bool
prop_parsePackageLocationTokenQ (PackageLocationString str) =
case [ x | (x,"") <- Parse.readP_to_S parsePackageLocationTokenQ
(renderPackageLocationToken str) ] of
[str'] -> str' == str
_ -> False
runReadP parsePackageLocationTokenQ (renderPackageLocationToken str) == Just str
prop_roundtrip_printparse_RelaxedDep :: RelaxedDep -> Bool
prop_roundtrip_printparse_RelaxedDep rdep =
case [ x | (x,"") <- Parse.readP_to_S Text.parse (Text.display rdep) ] of
[rdep'] -> rdep' == rdep
_ -> False
runReadP Text.parse (Text.display rdep) == Just rdep
prop_roundtrip_printparse_RelaxDeps :: RelaxDeps -> Bool
prop_roundtrip_printparse_RelaxDeps rdep =
runReadP Text.parse (Text.display rdep) == Just rdep
prop_roundtrip_printparse_RelaxDeps' :: RelaxDeps -> Bool
prop_roundtrip_printparse_RelaxDeps' rdep =
runReadP Text.parse (go $ Text.display rdep) == Just rdep
where
-- replace 'all' tokens by '*'
go :: String -> String
go [] = []
go "all" = "*"
go ('a':'l':'l':c:rest) | c `elem` ":," = '*' : go (c:rest)
go rest = let (x,y) = break (`elem` ":,") rest
(x',y') = span (`elem` ":,^") y
in x++x'++go y'
------------------------
-- Arbitrary instances
......@@ -785,7 +806,7 @@ instance Arbitrary AllowOlder where
arbitrary = AllowOlder <$> arbitrary
instance Arbitrary RelaxDeps where
arbitrary = oneof [ pure RelaxDepsNone
arbitrary = oneof [ pure mempty
, RelaxDepsSome <$> shortListOf1 3 arbitrary
, pure RelaxDepsAll
]
......@@ -799,6 +820,11 @@ instance Arbitrary RelaxDepScope where
, RelaxDepScopePackageId <$> (PackageIdentifier <$> arbitrary <*> arbitrary)
]
instance Arbitrary RelaxDepSubject where
arbitrary = oneof [ pure RelaxDepSubjectAll
, RelaxDepSubjectPkg <$> arbitrary
]
instance Arbitrary RelaxedDep where
arbitrary = RelaxedDep <$> arbitrary <*> arbitrary <*> arbitrary
......
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