Move predicates to VersionRange module

haskell · Nov 20, 2024 · 0245bdc · 0245bdc
1 parent eeddb5b
commit 0245bdc
Show file tree

Hide file tree

Showing 5 changed files with 62 additions and 66 deletions.
diff --git a/Cabal-syntax/src/Distribution/Types/VersionRange.hs b/Cabal-syntax/src/Distribution/Types/VersionRange.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+
 module Distribution.Types.VersionRange
   ( -- * Version ranges
     VersionRange
@@ -26,6 +29,9 @@ module Distribution.Types.VersionRange
   , stripParensVersionRange
   , hasUpperBound
   , hasLowerBound
+  , hasLEQUpperBound
+  , hasTrailingZeroUpperBound
+  , hasGTLowerBound
 
     -- ** Cata & ana
   , VersionRangeF (..)
@@ -197,3 +203,43 @@ hasLowerBound =
     (const False)
     (&&)
     (||)
+
+pattern HasLEQUpperBound, HasGTLowerBound, HasTrailingZeroUpperBound :: VersionRangeF a
+pattern HasLEQUpperBound <- OrEarlierVersionF _
+pattern HasGTLowerBound <- LaterVersionF _
+pattern HasTrailingZeroUpperBound <- (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
+
+-- | Is the upper bound version range LEQ (less or equal, <=)?
+hasLEQUpperBound :: VersionRange -> Bool
+hasLEQUpperBound (projectVersionRange -> v)
+  | HasLEQUpperBound <- v = True
+  | IntersectVersionRangesF x y <- v = hasLEQUpperBound x || hasLEQUpperBound y
+  | UnionVersionRangesF x y <- v = hasLEQUpperBound x || hasLEQUpperBound y
+  | otherwise = False
+
+-- | Is the lower bound version range GT (greater than, >)?
+hasGTLowerBound :: VersionRange -> Bool
+hasGTLowerBound (projectVersionRange -> v)
+  | HasGTLowerBound <- v = True
+  | IntersectVersionRangesF x y <- v = hasGTLowerBound x || hasGTLowerBound y
+  | UnionVersionRangesF x y <- v = hasGTLowerBound x || hasGTLowerBound y
+  | otherwise = False
+
+-- | Does the upper bound version range have a trailing zero?
+hasTrailingZeroUpperBound :: VersionRange -> Bool
+hasTrailingZeroUpperBound (projectVersionRange -> v)
+  | HasTrailingZeroUpperBound <- v = True
+  | IntersectVersionRangesF x y <- v = hasTrailingZeroUpperBound x || hasTrailingZeroUpperBound y
+  | UnionVersionRangesF x y <- v = hasTrailingZeroUpperBound x || hasTrailingZeroUpperBound y
+  | otherwise = False
diff --git a/Cabal-syntax/src/Distribution/Version.hs b/Cabal-syntax/src/Distribution/Version.hs
@@ -50,6 +50,9 @@ module Distribution.Version
   , stripParensVersionRange
   , hasUpperBound
   , hasLowerBound
+  , hasLEQUpperBound
+  , hasTrailingZeroUpperBound
+  , hasGTLowerBound
 
     -- ** Cata & ana
   , VersionRangeF (..)

diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs
@@ -577,11 +577,11 @@ checkSetupBuildInfo (Just (SetupBuildInfo ds _)) = do
       gtlck =
         PackageDistSuspiciousWarn
           . GTLowerBounds CETSetup
-  checkPVP withoutUpperBound ick is
-  checkPVPs withoutUpperBound rck rs
-  checkPVPs leqUpperBound lequck ds
-  checkPVPs trailingZeroUpperBound tzuck ds
-  checkPVPs gtLowerBound gtlck ds
+  checkPVP (checkDependencyVersionRange $ not . hasUpperBound) ick is
+  checkPVPs (checkDependencyVersionRange $ not . hasUpperBound) rck rs
+  checkPVPs (checkDependencyVersionRange hasLEQUpperBound) lequck ds
+  checkPVPs (checkDependencyVersionRange hasTrailingZeroUpperBound) tzuck ds
+  checkPVPs (checkDependencyVersionRange hasGTLowerBound) gtlck ds
 
 checkPackageId :: Monad m => PackageIdentifier -> CheckM m ()
 checkPackageId (PackageIdentifier pkgName_ _pkgVersion_) = do

diff --git a/Cabal/src/Distribution/PackageDescription/Check/Common.hs b/Cabal/src/Distribution/PackageDescription/Check/Common.hs
@@ -19,10 +19,7 @@ module Distribution.PackageDescription.Check.Common
   , partitionDeps
   , checkPVP
   , checkPVPs
-  , withoutUpperBound
-  , leqUpperBound
-  , trailingZeroUpperBound
-  , gtLowerBound
+  , checkDependencyVersionRange
   ) where
 
 import Distribution.Compat.Prelude
@@ -150,55 +147,5 @@ checkPVPs p cf ds
     ods = filter p ds
     ns = map (unPackageName . depPkgName) ods
 
--- | 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 _) = hasLEQUpperBound ver
-
--- | Does the upper bound version range have a trailing zero?
-trailingZeroUpperBound :: Dependency -> Bool
-trailingZeroUpperBound (Dependency _ ver _) = hasTrailingZeroUpperBound ver
-
--- | Is the lower bound version range GT (greater than, >)?
-gtLowerBound :: Dependency -> Bool
-gtLowerBound (Dependency _ ver _) = hasGTLowerBound ver
-
-pattern HasLEQUpperBound, HasGTLowerBound, HasTrailingZeroUpperBound :: VersionRangeF a
-pattern HasLEQUpperBound <- OrEarlierVersionF _
-pattern HasGTLowerBound <- LaterVersionF _
-pattern HasTrailingZeroUpperBound <- (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
-
-hasLEQUpperBound :: VersionRange -> Bool
-hasLEQUpperBound (projectVersionRange -> v)
-  | HasLEQUpperBound <- v = True
-  | IntersectVersionRangesF x y <- v = hasLEQUpperBound x || hasLEQUpperBound y
-  | UnionVersionRangesF x y <- v = hasLEQUpperBound x || hasLEQUpperBound y
-  | otherwise = False
-
-hasGTLowerBound :: VersionRange -> Bool
-hasGTLowerBound (projectVersionRange -> v)
-  | HasGTLowerBound <- v = True
-  | IntersectVersionRangesF x y <- v = hasGTLowerBound x || hasGTLowerBound y
-  | UnionVersionRangesF x y <- v = hasGTLowerBound x || hasGTLowerBound y
-  | otherwise = False
-
-hasTrailingZeroUpperBound :: VersionRange -> Bool
-hasTrailingZeroUpperBound (projectVersionRange -> v)
-  | HasTrailingZeroUpperBound <- v = True
-  | IntersectVersionRangesF x y <- v = hasTrailingZeroUpperBound x || hasTrailingZeroUpperBound y
-  | UnionVersionRangesF x y <- v = hasTrailingZeroUpperBound x || hasTrailingZeroUpperBound y
-  | otherwise = False
+checkDependencyVersionRange :: (VersionRange -> Bool) -> Dependency -> Bool
+checkDependencyVersionRange p (Dependency _ ver _) = p ver
diff --git a/Cabal/src/Distribution/PackageDescription/Check/Target.hs b/Cabal/src/Distribution/PackageDescription/Check/Target.hs
@@ -342,19 +342,19 @@ checkBuildInfo cet ams ads bi = do
       lequck = PackageDistSuspiciousWarn . LEQUpperBounds cet
       tzuck = PackageDistSuspiciousWarn . TrailingZeroUpperBounds cet
       gtlck = PackageDistSuspiciousWarn . GTLowerBounds cet
-  checkPVP withoutUpperBound ick ids
+  checkPVP (checkDependencyVersionRange $ not . hasUpperBound) ick ids
   unless
     (isInternalTarget cet)
-    (checkPVPs withoutUpperBound rck rds)
+    (checkPVPs (checkDependencyVersionRange $ not . hasUpperBound) rck rds)
   unless
     (isInternalTarget cet)
-    (checkPVPs leqUpperBound lequck ds)
+    (checkPVPs (checkDependencyVersionRange hasLEQUpperBound) lequck ds)
   unless
     (isInternalTarget cet)
-    (checkPVPs trailingZeroUpperBound tzuck ds)
+    (checkPVPs (checkDependencyVersionRange hasTrailingZeroUpperBound) tzuck ds)
   unless
     (isInternalTarget cet)
-    (checkPVPs gtLowerBound gtlck ds)
+    (checkPVPs (checkDependencyVersionRange hasGTLowerBound) gtlck ds)
 
   -- Custom fields well-formedness (ASCII).
   mapM_ checkCustomField (customFieldsBI bi)