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.

cabal-install/Distribution/Client/Config.hs

@@ -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.

cabal-install/Distribution/Client/Configure.hs

@@ -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

cabal-install/Distribution/Client/Dependency.hs

@@ -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) =

cabal-install/Distribution/Client/Install.hs

@@ -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.

cabal-install/Distribution/Client/ProjectConfig.hs

@@ -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),

cabal-install/Distribution/Client/ProjectConfig/Legacy.hs

@@ -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"

cabal-install/Distribution/Client/Setup.hs

@@ -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
 

cabal-install/Distribution/Client/Types.hs

@@ -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

cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs

@@ -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
                       ]