diff --git a/Cabal-syntax/src/Distribution/Types/VersionRange.hs b/Cabal-syntax/src/Distribution/Types/VersionRange.hs index c470b93c0d2..2f72f084bdc 100644 --- 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 index 80383358037..f460da2648b 100644 --- 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 index 7cf30744263..3f9879b99f3 100644 --- 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 index fd45da153e1..f612eed4264 100644 --- 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 index 4451a94b73c..dd692efbfe9 100644 --- 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)