Merge pull request haskell#10554 from cabalism/fix/check-version-bounds

Additional version bound checks

Author: mergify[bot]

Cabal-syntax/src/Distribution/Types/VersionRange.hs

@@ -1,7 +1,26 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ViewPatterns #-}
+
 module Distribution.Types.VersionRange
-  ( -- * Version ranges
+  ( -- * Version Range
     VersionRange
 
+    -- ** Predicates
+    -- $predicate-examples
+
+    -- *** Lower Bound
+  , hasLowerBound
+  , hasGTLowerBound
+
+    -- *** Upper Bound
+  , hasUpperBound
+  , hasLEUpperBound
+  , hasTrailingZeroUpperBound
+
+    -- *** Any Version
+  , isAnyVersion
+  , isAnyVersionLight
+
     -- ** Constructing
   , anyVersion
   , noVersion
@@ -16,32 +35,31 @@ module Distribution.Types.VersionRange
   , withinVersion
   , majorBoundVersion
 
-    -- ** Inspection
+    -- ** Modification
+  , normaliseVersionRange
+  , stripParensVersionRange
 
-  --
-  -- See "Distribution.Version" for more utilities.
+    -- ** Inspection
   , withinRange
   , foldVersionRange
-  , normaliseVersionRange
-  , stripParensVersionRange
-  , hasUpperBound
-  , hasLowerBound
 
-    -- ** Cata & ana
+    -- ** Parser
+  , versionRangeParser
+
+    -- * Version F-Algebra
   , VersionRangeF (..)
+  , projectVersionRange
+  , embedVersionRange
   , cataVersionRange
   , anaVersionRange
   , hyloVersionRange
-  , projectVersionRange
-  , embedVersionRange
 
-    -- ** Utilities
-  , isAnyVersion
-  , isAnyVersionLight
+    -- * Version Utilities
+
+  -- See "Distribution.Version" for more utilities.
   , wildcardUpperBound
   , majorUpperBound
   , isWildcardRange
-  , versionRangeParser
   ) where
 
 import Distribution.Compat.Prelude
@@ -172,6 +190,9 @@ isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2)
 -- | Does the version range have an upper bound?
 --
 -- @since 1.24.0.0
+--
+-- >>> forM ["< 1", ">= 0 && < 1", ">= 0 || < 1", "^>= 4.20.0.0"] (fmap hasUpperBound . simpleParsec)
+-- Just [True,True,False,True]
 hasUpperBound :: VersionRange -> Bool
 hasUpperBound =
   foldVersionRange
@@ -188,6 +209,9 @@ hasUpperBound =
 -- the implicit >=0 lower bound.
 --
 -- @since 1.24.0.0
+--
+-- >>> forM ["< 1", ">= 0 && < 1", ">= 0 || < 1", "^>= 4.20.0.0"] (fmap hasLowerBound . simpleParsec)
+-- Just [False,True,False,True]
 hasLowerBound :: VersionRange -> Bool
 hasLowerBound =
   foldVersionRange
@@ -197,3 +221,50 @@ hasLowerBound =
     (const False)
     (&&)
     (||)
+
+-- | Is the upper bound version range (less than or equal (LE, <=)?
+--
+-- >>> forM ["< 1", "<= 1", ">= 0 && < 1", ">= 0 || < 1", ">= 0 && <= 1", ">= 0 || <= 1", "^>= 4.20.0.0"] (fmap hasLEUpperBound . simpleParsec)
+-- Just [False,True,False,False,True,True,False]
+hasLEUpperBound :: VersionRange -> Bool
+hasLEUpperBound = queryVersionRange (\case LEUpperBound -> True; _ -> False) hasLEUpperBound
+
+-- | Is the lower bound version range greater than (GT, >)?
+--
+-- >>> forM ["< 1", ">= 0 && < 1", ">= 0 || < 1", "> 0 && < 1", "> 0 || < 1", "^>= 4.20.0.0"] (fmap hasGTLowerBound . simpleParsec)
+-- Just [False,False,False,True,True,False]
+hasGTLowerBound :: VersionRange -> Bool
+hasGTLowerBound = queryVersionRange (\case GTLowerBound -> True; _ -> False) hasGTLowerBound
+
+-- | Does the upper bound version range have a trailing zero?
+--
+-- >>> forM ["< 1", "< 1.1", "< 1.0", "< 1.1.0", "^>= 4.20.0.0"] (fmap hasTrailingZeroUpperBound . simpleParsec)
+-- Just [False,False,True,True,False]
+hasTrailingZeroUpperBound :: VersionRange -> Bool
+hasTrailingZeroUpperBound = queryVersionRange (\case TZUpperBound -> True; _ -> False) hasTrailingZeroUpperBound
+
+queryVersionRange :: (VersionRangeF VersionRange -> Bool) -> (VersionRange -> Bool) -> VersionRange -> Bool
+queryVersionRange pf p (projectVersionRange -> v) =
+  let f = queryVersionRange pf p
+   in pf v || case v of
+        IntersectVersionRangesF x y -> f x || f y
+        UnionVersionRangesF x y -> f x || f y
+        _ -> False
+
+-- $setup
+-- >>> import Distribution.Parsec
+-- >>> import Data.Traversable
+
+-- $predicate-examples
+--
+-- The parsed 'VersionRange' of each version constraint used in the examples for
+-- 'hasUpperBound' and 'hasLowerBound' are:
+--
+-- >>> simpleParsec "< 1" :: Maybe VersionRange
+-- Just (EarlierVersion (mkVersion [1]))
+-- >>> simpleParsec ">= 0 && < 1" :: Maybe VersionRange
+-- Just (IntersectVersionRanges (OrLaterVersion (mkVersion [0])) (EarlierVersion (mkVersion [1])))
+-- >>> simpleParsec ">= 0 || < 1" :: Maybe VersionRange
+-- Just (UnionVersionRanges (OrLaterVersion (mkVersion [0])) (EarlierVersion (mkVersion [1])))
+-- >>> simpleParsec "^>= 4.20.0.0" :: Maybe VersionRange
+-- Just (MajorBoundVersion (mkVersion [4,20,0,0]))

Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs

@@ -3,7 +3,9 @@
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- | The only purpose of this module is to prevent the export of
 -- 'VersionRange' constructors from
@@ -23,7 +25,7 @@ module Distribution.Types.VersionRange.Internal
   , intersectVersionRanges
   , withinVersion
   , majorBoundVersion
-  , VersionRangeF (..)
+  , VersionRangeF (.., LEUpperBound, GTLowerBound, TZUpperBound)
   , projectVersionRange
   , embedVersionRange
   , cataVersionRange
@@ -184,6 +186,22 @@ data VersionRangeF a
     , Traversable
     )
 
+pattern LEUpperBound, GTLowerBound, TZUpperBound :: VersionRangeF a
+pattern LEUpperBound <- OrEarlierVersionF _
+pattern GTLowerBound <- LaterVersionF _
+pattern TZUpperBound <- (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
+
 -- | Generic destructor for 'VersionRange'.
 --
 -- @since 2.2

Cabal-syntax/src/Distribution/Version.hs

@@ -50,6 +50,9 @@ module Distribution.Version
   , stripParensVersionRange
   , hasUpperBound
   , hasLowerBound
+  , hasLEUpperBound
+  , hasTrailingZeroUpperBound
+  , hasGTLowerBound
 
     -- ** Cata & ana
   , VersionRangeF (..)

Cabal-tests/tests/ParserTests/regressions/issue-8646.cabal

@@ -11,6 +11,6 @@ license: BSD-3-Clause
 
 executable test
   main-is: ExeMain.hs
-  build-depends: base > 4 && < 5
+  build-depends: base >= 4 && < 5
   default-language: Haskell2010
   ghc-options: -main-is ExeMain

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
+      leuck =
+        PackageDistSuspiciousWarn
+          . LEUpperBounds CETSetup
+      tzuck =
+        PackageDistSuspiciousWarn
+          . TrailingZeroUpperBounds CETSetup
+      gtlck =
+        PackageDistSuspiciousWarn
+          . GTLowerBounds CETSetup
+  checkPVP (checkDependencyVersionRange $ not . hasUpperBound) ick is
+  checkPVPs (checkDependencyVersionRange $ not . hasUpperBound) rck rs
+  checkPVPs (checkDependencyVersionRange hasLEUpperBound) leuck ds
+  checkPVPs (checkDependencyVersionRange hasTrailingZeroUpperBound) tzuck ds
+  checkPVPs (checkDependencyVersionRange hasGTLowerBound) gtlck ds
 
 checkPackageId :: Monad m => PackageIdentifier -> CheckM m ()
 checkPackageId (PackageIdentifier pkgName_ _pkgVersion_) = do

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

@@ -16,6 +16,7 @@ module Distribution.PackageDescription.Check.Common
   , partitionDeps
   , checkPVP
   , checkPVPs
+  , checkDependencyVersionRange
   ) where
 
 import Distribution.Compat.Prelude
@@ -116,34 +117,32 @@ partitionDeps ads ns ds = do
 -- for important dependencies like base).
 checkPVP
   :: Monad m
-  => (String -> PackageCheck) -- Warn message depends on name
+  => (Dependency -> Bool)
+  -> (String -> PackageCheck) -- Warn message depends 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
+checkDependencyVersionRange :: (VersionRange -> Bool) -> Dependency -> Bool
+checkDependencyVersionRange p (Dependency _ ver _) = p ver

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
+      leuck = PackageDistSuspiciousWarn . LEUpperBounds cet
+      tzuck = PackageDistSuspiciousWarn . TrailingZeroUpperBounds cet
+      gtlck = PackageDistSuspiciousWarn . GTLowerBounds cet
+  checkPVP (checkDependencyVersionRange $ not . hasUpperBound) ick ids
   unless
     (isInternalTarget cet)
-    (checkPVPs rck rds)
+    (checkPVPs (checkDependencyVersionRange $ not . hasUpperBound) rck rds)
+  unless
+    (isInternalTarget cet)
+    (checkPVPs (checkDependencyVersionRange hasLEUpperBound) leuck ds)
+  unless
+    (isInternalTarget cet)
+    (checkPVPs (checkDependencyVersionRange hasTrailingZeroUpperBound) tzuck ds)
+  unless
+    (isInternalTarget cet)
+    (checkPVPs (checkDependencyVersionRange hasGTLowerBound) gtlck ds)
 
   -- Custom fields well-formedness (ASCII).
   mapM_ checkCustomField (customFieldsBI bi)