Commit 4066ea7a authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

Refactor 'RelaxDeps' to avoid semantic ambiguity of mempty value

This removes the redundancy between `RelaxDepsNone` and
`RelaxDepsSome []` by removing `RelaxDepsNone`.

This way we avoid the risk of subtle bugs that can occur if the same
semantic value can be expressed in a non-unique way.

A further step to normalise the type would be to turn `[RelaxedDep]`
into `Set RelaxedDep`, but there is no operation that would
significantly benefit from that yet.
parent a8036999
......@@ -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(..), 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,7 +454,7 @@ 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 pkgName verRange) =
......
......@@ -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),
......
......@@ -25,7 +25,7 @@ import Distribution.Client.Compat.Prelude
import Distribution.Client.ProjectConfig.Types
import Distribution.Client.Types
( RemoteRepo(..), emptyRemoteRepo
( RemoteRepo(..), emptyRemoteRepo, isRelaxDeps
, AllowNewer(..), AllowOlder(..), RelaxDeps(..) )
import Distribution.Client.Config
......@@ -872,12 +872,12 @@ legacySharedConfigFieldDescrs =
parseRelaxDeps :: ReadP r RelaxDeps
parseRelaxDeps =
((const RelaxDepsNone <$> (Parse.string "none" +++ Parse.string "None"))
((const mempty <$> (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 rd | not (isRelaxDeps rd) = Disp.text "None"
dispRelaxDeps (RelaxDepsSome pkgs) = Disp.fsep . Disp.punctuate Disp.comma
. map disp $ pkgs
dispRelaxDeps RelaxDepsAll = Disp.text "All"
......
......@@ -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
......
......@@ -396,15 +396,11 @@ 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.
| RelaxDepsAll
......@@ -465,15 +461,28 @@ 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
......
......@@ -785,7 +785,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
]
......
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