Additional version bound checks

Cabal/src/Distribution/PackageDescription/Check.hs

@@ -568,8 +568,20 @@ checkSetupBuildInfo (Just (SetupBuildInfo ds _)) = do
       rck =
         PackageDistSuspiciousWarn
           . MissingUpperBounds CETSetup
-  checkPVP ick is
-  checkPVPs rck rs
+      lequck =
+        PackageDistSuspiciousWarn
+          . LEQUpperBounds CETSetup
+      tzuck =
+        PackageDistSuspiciousWarn
+          . TrailingZeroUpperBounds CETSetup
+      gtlck =
+        PackageDistSuspiciousWarn
+          . GTLowerBounds CETSetup
+  checkPVP withoutUpperBound ick is
+  checkPVPs withoutUpperBound rck rs
+  checkPVPs (not . leqUpperBound) lequck ds
+  checkPVPs (not . trailingZeroUpperBound) tzuck ds
+  checkPVPs (not . gtLowerBound) gtlck ds
 
 checkPackageId :: Monad m => PackageIdentifier -> CheckM m ()
 checkPackageId (PackageIdentifier pkgName_ _pkgVersion_) = do

Cabal/src/Distribution/PackageDescription/Check/Common.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE ViewPatterns #-}
+
 -- |
 -- Module      :  Distribution.PackageDescription.Check.Common
 -- Copyright   :  Francesco Ariis 2022
@@ -16,6 +18,10 @@ module Distribution.PackageDescription.Check.Common
   , partitionDeps
   , checkPVP
   , checkPVPs
+  , withoutUpperBound
+  , leqUpperBound
+  , trailingZeroUpperBound
+  , gtLowerBound
   ) where
 
 import Distribution.Compat.Prelude
@@ -116,34 +122,58 @@ partitionDeps ads ns ds = do
 -- for important dependencies like base).
 checkPVP
   :: Monad m
-  => (String -> PackageCheck) -- Warn message dependend on name
+  => (Dependency -> Bool)
+  -> (String -> PackageCheck) -- Warn message dependend on name
   -- (e.g. "base", "Cabal").
   -> [Dependency]
   -> CheckM m ()
-checkPVP ckf ds = do
-  let ods = checkPVPPrim ds
+checkPVP p ckf ds = do
+  let ods = filter p ds
   mapM_ (tellP . ckf . unPackageName . depPkgName) ods
 
 -- PVP dependency check for a list of dependencies. Some code duplication
 -- is sadly needed to provide more ergonimic error messages.
 checkPVPs
   :: Monad m
-  => ( [String]
+  => (Dependency -> Bool)
+  -> ( [String]
        -> PackageCheck -- Grouped error message, depends on a
        -- set of names.
      )
   -> [Dependency] -- Deps to analyse.
   -> CheckM m ()
-checkPVPs cf ds
+checkPVPs p cf ds
   | null ns = return ()
   | otherwise = tellP (cf ns)
   where
-    ods = checkPVPPrim ds
+    ods = filter p ds
     ns = map (unPackageName . depPkgName) ods
 
--- Returns dependencies without upper bounds.
-checkPVPPrim :: [Dependency] -> [Dependency]
-checkPVPPrim ds = filter withoutUpper ds
+-- | Is the version range without an upper bound?
+withoutUpperBound :: Dependency -> Bool
+withoutUpperBound (Dependency _ ver _) = not . hasUpperBound $ ver
+
+-- | Is the upper bound version range LEQ (less or equal, <=)?
+leqUpperBound :: Dependency -> Bool
+leqUpperBound (Dependency _ ver _)
+  | OrEarlierVersionF _ <- projectVersionRange ver = True
+  | otherwise = False
+
+-- | Does the upper bound version range have a trailing zero?
+trailingZeroUpperBound :: Dependency -> Bool
+trailingZeroUpperBound (Dependency _ ver _)
+  | OrEarlierVersionF v <- projectVersionRange ver = trailingZero v
+  | EarlierVersionF v <- projectVersionRange ver = trailingZero v
+  | otherwise = False
   where
-    withoutUpper :: Dependency -> Bool
-    withoutUpper (Dependency _ ver _) = not . hasUpperBound $ ver
+    trailingZero :: Version -> Bool
+    trailingZero (versionNumbers -> vs)
+      | [0] <- vs = False
+      | 0 : _ <- reverse vs = True
+      | otherwise = False
+
+-- | Is the lower bound version range GT (greater than, >)?
+gtLowerBound :: Dependency -> Bool
+gtLowerBound (Dependency _ ver _)
+  | LaterVersionF _ <- projectVersionRange ver = True
+  | otherwise = False

Cabal/src/Distribution/PackageDescription/Check/Target.hs

@@ -331,17 +331,30 @@ checkBuildInfo cet ams ads bi = do
   checkAutogenModules ams bi
 
   -- PVP: we check for base and all other deps.
+  let ds = mergeDependencies $ targetBuildDepends bi
   (ids, rds) <-
     partitionDeps
       ads
       [mkUnqualComponentName "base"]
-      (mergeDependencies $ targetBuildDepends bi)
+      ds
   let ick = const (PackageDistInexcusable BaseNoUpperBounds)
       rck = PackageDistSuspiciousWarn . MissingUpperBounds cet
-  checkPVP ick ids
+      lequck = PackageDistSuspiciousWarn . LEQUpperBounds cet
+      tzuck = PackageDistSuspiciousWarn . TrailingZeroUpperBounds cet
+      gtlck = PackageDistSuspiciousWarn . GTLowerBounds cet
+  checkPVP withoutUpperBound ick ids
   unless
     (isInternalTarget cet)
-    (checkPVPs rck rds)
+    (checkPVPs withoutUpperBound rck rds)
+  unless
+    (isInternalTarget cet)
+    (checkPVPs (not . leqUpperBound) lequck ds)
+  unless
+    (isInternalTarget cet)
+    (checkPVPs (not . trailingZeroUpperBound) tzuck ds)
+  unless
+    (isInternalTarget cet)
+    (checkPVPs (not . gtLowerBound) gtlck ds)
 
   -- Custom fields well-formedness (ASCII).
   mapM_ checkCustomField (customFieldsBI bi)

Cabal/src/Distribution/PackageDescription/Check/Warning.hs

@@ -256,6 +256,9 @@ data CheckExplanation
   | UnknownCompiler [String]
   | BaseNoUpperBounds
   | MissingUpperBounds CEType [String]
+  | LEQUpperBounds CEType [String]
+  | TrailingZeroUpperBounds CEType [String]
+  | GTLowerBounds CEType [String]
   | SuspiciousFlagName [String]
   | DeclaredUsedFlags (Set.Set FlagName) (Set.Set FlagName)
   | NonASCIICustomField [String]
@@ -419,6 +422,9 @@ data CheckExplanationID
   | CIUnknownCompiler
   | CIBaseNoUpperBounds
   | CIMissingUpperBounds
+  | CILEQUpperBounds
+  | CITrailingZeroUpperBounds
+  | CIGTLowerBounds
   | CISuspiciousFlagName
   | CIDeclaredUsedFlags
   | CINonASCIICustomField
@@ -561,6 +567,9 @@ checkExplanationId (UnknownArch{}) = CIUnknownArch
 checkExplanationId (UnknownCompiler{}) = CIUnknownCompiler
 checkExplanationId (BaseNoUpperBounds{}) = CIBaseNoUpperBounds
 checkExplanationId (MissingUpperBounds{}) = CIMissingUpperBounds
+checkExplanationId (LEQUpperBounds{}) = CILEQUpperBounds
+checkExplanationId (TrailingZeroUpperBounds{}) = CITrailingZeroUpperBounds
+checkExplanationId (GTLowerBounds{}) = CIGTLowerBounds
 checkExplanationId (SuspiciousFlagName{}) = CISuspiciousFlagName
 checkExplanationId (DeclaredUsedFlags{}) = CIDeclaredUsedFlags
 checkExplanationId (NonASCIICustomField{}) = CINonASCIICustomField
@@ -708,6 +717,9 @@ ppCheckExplanationId CIUnknownArch = "unknown-arch"
 ppCheckExplanationId CIUnknownCompiler = "unknown-compiler"
 ppCheckExplanationId CIBaseNoUpperBounds = "missing-bounds-important"
 ppCheckExplanationId CIMissingUpperBounds = "missing-upper-bounds"
+ppCheckExplanationId CILEQUpperBounds = "less-than-equals-upper-bounds"
+ppCheckExplanationId CITrailingZeroUpperBounds = "trailing-zero-upper-bounds"
+ppCheckExplanationId CIGTLowerBounds = "greater-than-lower-bounds"
 ppCheckExplanationId CISuspiciousFlagName = "suspicious-flag"
 ppCheckExplanationId CIDeclaredUsedFlags = "unused-flag"
 ppCheckExplanationId CINonASCIICustomField = "non-ascii"
@@ -1310,6 +1322,36 @@ ppExplanation (MissingUpperBounds ct names) =
         ++ List.intercalate separator names
         ++ "\n"
         ++ "Please add them. There is more information at https://pvp.haskell.org/"
+ppExplanation (LEQUpperBounds ct names) =
+  let separator = "\n  - "
+   in "On "
+        ++ ppCET ct
+        ++ ", "
+        ++ "these packages have less than or equals (<=) upper bounds:"
+        ++ separator
+        ++ List.intercalate separator names
+        ++ "\n"
+        ++ "Please use less than (<) for upper bounds. There is more information at https://pvp.haskell.org/"
+ppExplanation (TrailingZeroUpperBounds ct names) =
+  let separator = "\n  - "
+   in "On "
+        ++ ppCET ct
+        ++ ", "
+        ++ "these packages have upper bounds with trailing zeros:"
+        ++ separator
+        ++ List.intercalate separator names
+        ++ "\n"
+        ++ "Please avoid trailing zeros for upper bounds. There is more information at https://pvp.haskell.org/"
+ppExplanation (GTLowerBounds ct names) =
+  let separator = "\n  - "
+   in "On "
+        ++ ppCET ct
+        ++ ", "
+        ++ "these packages have greater than (>) lower bounds:"
+        ++ separator
+        ++ List.intercalate separator names
+        ++ "\n"
+        ++ "Please use greater than or equals (>=) for lower bounds. There is more information at https://pvp.haskell.org/"
 ppExplanation (SuspiciousFlagName invalidFlagNames) =
   "Suspicious flag names: "
     ++ unwords invalidFlagNames

cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs

@@ -492,7 +492,15 @@ exAvSrcPkg ex =
         -- they are not related to this test suite, and are tested
         -- with golden tests.
         let checks = C.checkPackage (srcpkgDescription package)
-         in filter (\x -> not (isMissingUpperBound x) && not (isUnknownLangExt x)) checks
+         in filter
+              ( \x ->
+                  not (isgtLowerBound x)
+                    && not (isLeqUpperBound x)
+                    && not (isTrailingZeroUpperBound x)
+                    && not (isMissingUpperBound x)
+                    && not (isUnknownLangExt x)
+              )
+              checks
    in if null pkgCheckErrors
         then package
         else
@@ -715,6 +723,18 @@ exAvSrcPkg ex =
     isMissingUpperBound pc = case C.explanation pc of
       C.MissingUpperBounds{} -> True
       _ -> False
+    isTrailingZeroUpperBound :: C.PackageCheck -> Bool
+    isTrailingZeroUpperBound pc = case C.explanation pc of
+      C.TrailingZeroUpperBounds{} -> True
+      _ -> False
+    isLeqUpperBound :: C.PackageCheck -> Bool
+    isLeqUpperBound pc = case C.explanation pc of
+      C.LEQUpperBounds{} -> True
+      _ -> False
+    isgtLowerBound :: C.PackageCheck -> Bool
+    isgtLowerBound pc = case C.explanation pc of
+      C.GTLowerBounds{} -> True
+      _ -> False
 
 mkSimpleVersion :: ExamplePkgVersion -> C.Version
 mkSimpleVersion n = C.mkVersion [n, 0, 0]

cabal-testsuite/PackageTests/Check/PackageFiles/VersionBounds/cabal.out

@@ -0,0 +1,11 @@
+# cabal check
+These warnings may cause trouble when distributing the package:
+Warning: [less-than-equals-upper-bounds] On library, these packages have less than or equals (<=) upper bounds:
+  - base
+Please use less than (<) for upper bounds. There is more information at https://pvp.haskell.org/
+Warning: [trailing-zero-upper-bounds] On library, these packages have upper bounds with trailing zeros:
+  - base
+Please avoid trailing zeros for upper bounds. There is more information at https://pvp.haskell.org/
+Warning: [greater-than-lower-bounds] On library, these packages have greater than (>) lower bounds:
+  - base
+Please use greater than or equals (>=) for lower bounds. There is more information at https://pvp.haskell.org/

cabal-testsuite/PackageTests/Check/PackageFiles/VersionBounds/cabal.test.hs

@@ -0,0 +1,4 @@
+import Test.Cabal.Prelude
+
+main = cabalTest $
+  cabal "check" []

cabal-testsuite/PackageTests/Check/PackageFiles/VersionBounds/pkg.cabal

@@ -0,0 +1,16 @@
+cabal-version: 3.0
+name: pkg
+synopsis: synopsis
+description: description
+version: 0
+category: example
+maintainer: [email protected]
+license: GPL-3.0-or-later
+
+library
+  exposed-modules: Foo
+  default-language: Haskell2010
+  build-depends:
+      base <= 9999999
+    , base <= 9999999.9.9.0
+    , base > 0