Add package bounds breaking checks

- Check for LEQ upper bounds
- Check for GT lower bounds
- Check for trailing zero upper bounds
- Add missing gtLowerBound to checks
- Handle ^>= versions with its IntersectVersionRangesF
- Set baseline for cabal init generated bounds
- Use recursive functions for checking bounds
- Handle union version ranges

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 leqUpperBound lequck ds
+  checkPVPs trailingZeroUpperBound tzuck ds
+  checkPVPs gtLowerBound gtlck ds
 
 checkPackageId :: Monad m => PackageIdentifier -> CheckM m ()
 checkPackageId (PackageIdentifier pkgName_ _pkgVersion_) = do

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

@@ -1,3 +1,6 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+
 -- |
 -- Module      :  Distribution.PackageDescription.Check.Common
 -- Copyright   :  Francesco Ariis 2022
@@ -16,6 +19,10 @@ module Distribution.PackageDescription.Check.Common
   , partitionDeps
   , checkPVP
   , checkPVPs
+  , withoutUpperBound
+  , leqUpperBound
+  , trailingZeroUpperBound
+  , gtLowerBound
   ) where
 
 import Distribution.Compat.Prelude
@@ -116,34 +123,82 @@ 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
-  where
-    withoutUpper :: Dependency -> Bool
-    withoutUpper (Dependency _ ver _) = not . hasUpperBound $ ver
+-- | 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 _) = isLEQUpperBound ver
+
+-- | Does the upper bound version range have a trailing zero?
+trailingZeroUpperBound :: Dependency -> Bool
+trailingZeroUpperBound (Dependency _ ver _) = isTrailingZeroUpperBound ver
+
+-- | Is the lower bound version range GT (greater than, >)?
+gtLowerBound :: Dependency -> Bool
+gtLowerBound (Dependency _ ver _) = isGTLowerBound ver
+
+pattern IsLEQUpperBound, IsGTLowerBound, IsTrailingZeroUpperBound :: VersionRangeF a
+pattern IsLEQUpperBound <- OrEarlierVersionF _
+pattern IsGTLowerBound <- LaterVersionF _
+pattern IsTrailingZeroUpperBound <- (upperTrailingZero -> True)
+
+upperTrailingZero :: VersionRangeF a -> Bool
+upperTrailingZero (OrEarlierVersionF x) = trailingZero x
+upperTrailingZero (EarlierVersionF x) = trailingZero x
+upperTrailingZero _ = False
+
+trailingZero :: Version -> Bool
+trailingZero (versionNumbers -> vs)
+  | [0] <- vs = False
+  | 0 : _ <- reverse vs = True
+  | otherwise = False
+
+isLEQUpperBound :: VersionRange -> Bool
+isLEQUpperBound (projectVersionRange -> v)
+  | IsLEQUpperBound <- v = True
+  | IntersectVersionRangesF x y <- v = isLEQUpperBound x || isLEQUpperBound y
+  | UnionVersionRangesF x y <- v = isLEQUpperBound x || isLEQUpperBound y
+  | otherwise = False
+
+isGTLowerBound :: VersionRange -> Bool
+isGTLowerBound (projectVersionRange -> v)
+  | IsGTLowerBound <- v = True
+  | IntersectVersionRangesF x y <- v = isGTLowerBound x || isGTLowerBound y
+  | UnionVersionRangesF x y <- v = isGTLowerBound x || isGTLowerBound y
+  | otherwise = False
+
+isTrailingZeroUpperBound :: VersionRange -> Bool
+isTrailingZeroUpperBound (projectVersionRange -> v)
+  | IsTrailingZeroUpperBound <- v = True
+  | IntersectVersionRangesF x y <- v = isTrailingZeroUpperBound x || isTrailingZeroUpperBound y
+  | UnionVersionRangesF x y <- v = isTrailingZeroUpperBound x || isTrailingZeroUpperBound y
+  | 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 leqUpperBound lequck ds)
+  unless
+    (isInternalTarget cet)
+    (checkPVPs trailingZeroUpperBound tzuck ds)
+  unless
+    (isInternalTarget cet)
+    (checkPVPs 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,18 @@
+# cabal check
+These warnings may cause trouble when distributing the package:
+Warning: [missing-upper-bounds] On library, these packages miss upper bounds:
+  - missing-upper
+  - exclusive-minimums-missing-upper
+  - or-exclusive-minimums-missing-upper
+  - or-inclusive-maximums-missing-upper
+Please add them. There is more information at https://pvp.haskell.org/
+Warning: [less-than-equals-upper-bounds] On library, these packages have less than or equals (<=) upper bounds:
+  - inclusive-maximums
+  - and-inclusive-maximums
+  - or-inclusive-maximums-missing-upper
+Please use less than (<) 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:
+  - exclusive-minimums-missing-upper
+  - and-exclusive-minimums
+  - or-exclusive-minimums-missing-upper
+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,25 @@
+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 ^>= 4.20.0.0
+
+    , missing-upper >= 0
+    , missing-lower < 1
+
+    , exclusive-minimums-missing-upper > 0
+    , and-exclusive-minimums > 0 && < 1
+    , or-exclusive-minimums-missing-upper > 0 || < 1
+
+    , inclusive-maximums <= 1
+    , and-inclusive-maximums >= 0 && <= 1
+    , or-inclusive-maximums-missing-upper >= 0 || <= 1