From 1347791c7bf70b1bf54edc30acbea93bad5d46d0 Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Thu, 3 Sep 2020 15:39:15 +0300
Subject: [PATCH] Rewrite VersionInterval code
- The old code is preserved for now in VersionInterval.Legacy module
- Add normaliseVersionRange bench, comparing new and old
- We drop intersectVersionIntervals, which is complicated function for acceptable performance loss, but gained simplicity
- Remove Ord instances (can be added back, removed to make sure we don't use them)
---
.gitignore | 3 +
.../src/Test/QuickCheck/Instances/Cabal.hs | 29 +-
Cabal/Cabal.cabal | 1 +
.../src/Distribution/FieldGrammar/Newtypes.hs | 7 +-
.../Distribution/PackageDescription/Check.hs | 5 +-
.../Types/PkgconfigVersionRange.hs | 4 +-
.../src/Distribution/Types/VersionInterval.hs | 517 +++++++++---------
.../Types/VersionInterval/Legacy.hs | 368 +++++++++++++
Cabal/src/Distribution/Types/VersionRange.hs | 4 +-
Cabal/src/Distribution/Version.hs | 71 +--
Cabal/tests/UnitTests/Distribution/Version.hs | 371 +++----------
cabal-benchmarks/bench/CabalBenchmarks.hs | 103 +++-
cabal-benchmarks/cabal-benchmarks.cabal | 2 +-
.../src/Distribution/Client/Dependency.hs | 16 +-
.../src/Distribution/Client/GenBounds.hs | 19 +-
.../src/Distribution/Client/Outdated.hs | 4 +-
16 files changed, 854 insertions(+), 670 deletions(-)
create mode 100644 Cabal/src/Distribution/Types/VersionInterval/Legacy.hs
diff --git a/.gitignore b/.gitignore
index d40cd06fdf..b5bea88e87 100644
--- a/.gitignore
+++ b/.gitignore
@@ -66,3 +66,6 @@ register.sh
# macOS folder metadata
.DS_Store
+
+# benchmarks
+bench.html
diff --git a/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs b/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs
index 46299b8eda..01fd765c72 100644
--- a/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs
+++ b/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs
@@ -149,35 +149,8 @@ instance Arbitrary VersionRange where
shrink (UnionVersionRanges a b) = a : b : map (uncurry UnionVersionRanges) (shrink (a, b))
shrink (IntersectVersionRanges a b) = a : b : map (uncurry IntersectVersionRanges) (shrink (a, b))
--- | Generating VersionIntervals
---
--- This is a tad tricky as VersionIntervals is an abstract type, so we first
--- make a local type for generating the internal representation. Then we check
--- that this lets us construct valid 'VersionIntervals'.
---
-
instance Arbitrary VersionIntervals where
- arbitrary = fmap mkVersionIntervals' arbitrary
- where
- mkVersionIntervals' :: [(Version, Bound)] -> VersionIntervals
- mkVersionIntervals' = mkVersionIntervals . go version0
- where
- go :: Version -> [(Version, Bound)] -> [VersionInterval]
- go _ [] = []
- go v [(lv, lb)] =
- [(LowerBound (addVersion lv v) lb, NoUpperBound)]
- go v ((lv, lb) : (uv, ub) : rest) =
- (LowerBound lv' lb, UpperBound uv' ub) : go uv' rest
- where
- lv' = addVersion v lv
- uv' = addVersion lv' uv
-
- addVersion :: Version -> Version -> Version
- addVersion xs ys = mkVersion $ z (versionNumbers xs) (versionNumbers ys)
- where
- z [] ys' = ys'
- z xs' [] = xs'
- z (x : xs') (y : ys') = x + y : z xs' ys'
+ arbitrary = fmap toVersionIntervals arbitrary
instance Arbitrary Bound where
arbitrary = elements [ExclusiveBound, InclusiveBound]
diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal
index 9e8b52884b..33d75f7770 100644
--- a/Cabal/Cabal.cabal
+++ b/Cabal/Cabal.cabal
@@ -521,6 +521,7 @@ library
Distribution.Types.VersionRange
Distribution.Types.VersionRange.Internal
Distribution.Types.VersionInterval
+ Distribution.Types.VersionInterval.Legacy
Distribution.Types.GivenComponent
Distribution.Types.PackageVersionConstraint
Distribution.Utils.Generic
diff --git a/Cabal/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal/src/Distribution/FieldGrammar/Newtypes.hs
index d0b9fc297d..3f37b43eb3 100644
--- a/Cabal/src/Distribution/FieldGrammar/Newtypes.hs
+++ b/Cabal/src/Distribution/FieldGrammar/Newtypes.hs
@@ -47,7 +47,8 @@ import Distribution.License (License)
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Version
- (LowerBound (..), Version, VersionRange, VersionRangeF (..), anyVersion, asVersionIntervals, cataVersionRange, mkVersion, version0, versionNumbers)
+ (LowerBound (..), Version, VersionInterval (..), VersionRange, VersionRangeF (..), anyVersion, asVersionIntervals, cataVersionRange, mkVersion,
+ version0, versionNumbers)
import Text.PrettyPrint (Doc, comma, fsep, punctuate, text, vcat)
import qualified Data.List.NonEmpty as NE
@@ -332,8 +333,8 @@ instance Parsec SpecVersion where
specVersionFromRange :: VersionRange -> Version
specVersionFromRange versionRange = case asVersionIntervals versionRange of
- [] -> version0
- ((LowerBound version _, _):_) -> version
+ [] -> version0
+ VersionInterval (LowerBound version _) _ : _ -> version
simpleSpecVersionRangeSyntax = cataVersionRange alg where
alg (OrLaterVersionF _) = True
diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs
index cdf9040427..bbc486950e 100644
--- a/Cabal/src/Distribution/PackageDescription/Check.hs
+++ b/Cabal/src/Distribution/PackageDescription/Check.hs
@@ -1413,12 +1413,13 @@ checkPackageVersions pkg =
-- then we will just skip the check, since boundedAbove noVersion = True
_ -> noVersion
+ -- TODO: move to Distribution.Version
boundedAbove :: VersionRange -> Bool
boundedAbove vr = case asVersionIntervals vr of
[] -> True -- this is the inconsistent version range.
(x:xs) -> case last (x:|xs) of
- (_, UpperBound _ _) -> True
- (_, NoUpperBound ) -> False
+ VersionInterval _ UpperBound {} -> True
+ VersionInterval _ NoUpperBound -> False
checkConditionals :: GenericPackageDescription -> [PackageCheck]
diff --git a/Cabal/src/Distribution/Types/PkgconfigVersionRange.hs b/Cabal/src/Distribution/Types/PkgconfigVersionRange.hs
index 6c13c47953..2d0690b15e 100644
--- a/Cabal/src/Distribution/Types/PkgconfigVersionRange.hs
+++ b/Cabal/src/Distribution/Types/PkgconfigVersionRange.hs
@@ -151,8 +151,8 @@ versionRangeToPkgconfigVersionRange vr
[] -> PcEarlierVersion (PkgconfigVersion (BS8.pack "0"))
(i:is) -> foldl (\r j -> PcUnionVersionRanges r (conv j)) (conv i) is
where
- conv (LowerBound v b, NoUpperBound) = convL v b
- conv (LowerBound v b, UpperBound u c) = PcIntersectVersionRanges (convL v b) (convU u c)
+ conv (VersionInterval (LowerBound v b) NoUpperBound) = convL v b
+ conv (VersionInterval (LowerBound v b) (UpperBound u c)) = PcIntersectVersionRanges (convL v b) (convU u c)
convL v ExclusiveBound = PcLaterVersion (versionToPkgconfigVersion v)
convL v InclusiveBound = PcOrLaterVersion (versionToPkgconfigVersion v)
diff --git a/Cabal/src/Distribution/Types/VersionInterval.hs b/Cabal/src/Distribution/Types/VersionInterval.hs
index d07a47f3fd..622faa7787 100644
--- a/Cabal/src/Distribution/Types/VersionInterval.hs
+++ b/Cabal/src/Distribution/Types/VersionInterval.hs
@@ -1,35 +1,194 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
+-- | In @Cabal-3.6@ this module have been rewritten.
+--
+--
module Distribution.Types.VersionInterval (
-- * Version intervals
VersionIntervals,
+ unVersionIntervals,
+
+ -- * Conversions
toVersionIntervals,
fromVersionIntervals,
- withinIntervals,
- versionIntervals,
- mkVersionIntervals,
- unionVersionIntervals,
- intersectVersionIntervals,
- invertVersionIntervals,
+
+ -- ** Normalisation
+ normaliseVersionRange2,
+
+ -- * Relaxation
relaxLastInterval,
relaxHeadInterval,
-- * Version intervals view
asVersionIntervals,
- VersionInterval,
+ VersionInterval (..),
LowerBound(..),
UpperBound(..),
Bound(..),
+
+ -- * Invariants
+ invariantVersionIntervals,
) where
-import Prelude ()
+import Control.Applicative (liftA2)
+import Control.Exception (assert)
import Distribution.Compat.Prelude
-import Control.Exception (assert)
+import Prelude ()
import Distribution.Types.Version
import Distribution.Types.VersionRange.Internal
--- NonEmpty
-import qualified Prelude (foldr1)
+-- To test this module, and to run version range normalisation benchmarks:
+--
+-- cabal run Cabal:unit-tests -- -p Distribution.Version
+-- cabal run cabal-benchmarks -- -o bench.html normaliseVersionRange
+
+-------------------------------------------------------------------------------
+-- Data
+-------------------------------------------------------------------------------
+
+-- | A complementary representation of a 'VersionRange'. Instead of a boolean
+-- version predicate it uses an increasing sequence of non-overlapping,
+-- non-empty intervals.
+--
+-- The key point is that this representation gives a canonical representation
+-- for the semantics of 'VersionRange's. This makes it easier to check things
+-- like whether a version range is empty, covers all versions, or requires a
+-- certain minimum or maximum version. It also makes it easy to check equality
+-- or containment. It also makes it easier to identify \'simple\' version
+-- predicates for translation into foreign packaging systems that do not
+-- support complex version range expressions.
+--
+newtype VersionIntervals = VersionIntervals [VersionInterval]
+ deriving (Eq, Show, Typeable)
+
+-- | Inspect the list of version intervals.
+--
+unVersionIntervals :: VersionIntervals -> [VersionInterval]
+unVersionIntervals (VersionIntervals is) = is
+
+data VersionInterval = VersionInterval !LowerBound !UpperBound deriving (Eq, Show)
+data LowerBound = LowerBound !Version !Bound deriving (Eq, Show)
+data UpperBound = NoUpperBound | UpperBound !Version !Bound deriving (Eq, Show)
+data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show)
+
+zeroLowerBound :: LowerBound
+zeroLowerBound = LowerBound version0 InclusiveBound
+
+isVersion0 :: Version -> Bool
+isVersion0 = (==) version0
+
+-------------------------------------------------------------------------------
+-- Stage1
+-------------------------------------------------------------------------------
+
+stage1 :: VersionRange -> [VersionInterval]
+stage1 = cataVersionRange alg where
+ -- version range leafs transform into singleton intervals
+ alg (ThisVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound v InclusiveBound)]
+ alg (LaterVersionF v) = [VersionInterval (LowerBound v ExclusiveBound) NoUpperBound]
+ alg (OrLaterVersionF v) = [VersionInterval (LowerBound v InclusiveBound) NoUpperBound]
+ alg (EarlierVersionF v)
+ | isVersion0 v = []
+ | otherwise = [VersionInterval zeroLowerBound (UpperBound v ExclusiveBound)]
+ alg (OrEarlierVersionF v) = [VersionInterval zeroLowerBound (UpperBound v InclusiveBound)]
+
+ -- ^>= version-range's upper bound should be MajorBound
+ alg (MajorBoundVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound (majorUpperBound v) ExclusiveBound)]
+
+ -- union: just merge the version intervals
+ alg (UnionVersionRangesF v1 v2) = v1 ++ v2
+
+ -- intersection: pairwise intersect. Strip empty intervals. Sort to restore the invariant.
+ alg (IntersectVersionRangesF v1 v2) = mapMaybe nonEmptyInterval $ liftA2 intersectInterval (stage2and3 v1) (stage2and3 v2)
+
+-- | Creck that interval is non-empty
+nonEmptyInterval :: VersionInterval -> Maybe VersionInterval
+nonEmptyInterval i | nonEmptyVI i = Just i
+nonEmptyInterval _ = Nothing
+
+-------------------------------------------------------------------------------
+-- Stage2
+-------------------------------------------------------------------------------
+
+stage2 :: [VersionInterval] -> [VersionInterval]
+stage2 = sortBy lowerboundCmp
+
+lowerboundCmp :: VersionInterval -> VersionInterval -> Ordering
+lowerboundCmp (VersionInterval (LowerBound v vb) _) (VersionInterval (LowerBound u ub) _) =
+ compare v u `mappend` compareBound vb ub
+ where
+ compareBound :: Bound -> Bound -> Ordering
+ compareBound InclusiveBound InclusiveBound = EQ
+ compareBound InclusiveBound ExclusiveBound = LT
+ compareBound ExclusiveBound InclusiveBound = GT
+ compareBound ExclusiveBound ExclusiveBound = EQ
+
+-------------------------------------------------------------------------------
+-- Postprocess
+-------------------------------------------------------------------------------
+
+-- | Post-processing takes a list of ordered version intervals,
+-- but possibly overlapping, and creates 'VersionIntervals'.
+--
+postprocess :: [VersionInterval] -> VersionIntervals
+postprocess = checkInvariant . VersionIntervals . stage2and3
+
+stage2and3 :: [VersionInterval] -> [VersionInterval]
+stage2and3 = stage3 . stage2
+
+stage3 :: [VersionInterval] -> [VersionInterval]
+stage3 [] = []
+stage3 (VersionInterval lb ub : rest) = stage3go lb ub rest
+
+stage3go :: LowerBound -> UpperBound -> [VersionInterval] -> [VersionInterval]
+stage3go !lb NoUpperBound _ = [VersionInterval lb NoUpperBound]
+stage3go !lb !ub [] = [VersionInterval lb ub]
+stage3go !lb !ub (VersionInterval lb' ub' : rest')
+ | doesNotTouch ub lb' = VersionInterval lb ub : stage3go lb' ub' rest'
+ | otherwise = stage3go lb (unionUpper ub ub') rest'
+
+-------------------------------------------------------------------------------
+-- Intersections
+-------------------------------------------------------------------------------
+
+intersectInterval :: VersionInterval -> VersionInterval -> VersionInterval
+intersectInterval (VersionInterval lv uv) (VersionInterval lu uu) =
+ VersionInterval (intersectLower lv lu) (intersectUpper uv uu)
+
+intersectLower :: LowerBound -> LowerBound -> LowerBound
+intersectLower (LowerBound v vb) (LowerBound u ub) = case compare v u of
+ EQ -> LowerBound v (intersectBound vb ub)
+ LT -> LowerBound u ub
+ GT -> LowerBound v vb
+
+intersectUpper :: UpperBound -> UpperBound -> UpperBound
+intersectUpper NoUpperBound b = b
+intersectUpper b NoUpperBound = b
+intersectUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of
+ EQ -> UpperBound v (intersectBound vb ub)
+ LT -> UpperBound v vb
+ GT -> UpperBound u ub
+
+intersectBound :: Bound -> Bound -> Bound
+intersectBound InclusiveBound InclusiveBound = InclusiveBound
+intersectBound _ _ = ExclusiveBound
+
+-------------------------------------------------------------------------------
+-- Unions
+-------------------------------------------------------------------------------
+
+unionUpper :: UpperBound -> UpperBound -> UpperBound
+unionUpper NoUpperBound _ = NoUpperBound
+unionUpper _ NoUpperBound = NoUpperBound
+unionUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of
+ EQ -> UpperBound v (unionBound vb ub)
+ LT -> UpperBound u ub
+ GT -> UpperBound v vb
+
+unionBound :: Bound -> Bound -> Bound
+unionBound ExclusiveBound ExclusiveBound = ExclusiveBound
+unionBound _ _ = InclusiveBound
-------------------------------------------------------------------------------
-- VersionRange
@@ -58,64 +217,40 @@ import qualified Prelude (foldr1)
-- > | otherwise = Nothing
--
asVersionIntervals :: VersionRange -> [VersionInterval]
-asVersionIntervals = versionIntervals . toVersionIntervals
-
+asVersionIntervals = unVersionIntervals . toVersionIntervals
-------------------------------------------------------------------------------
--- VersionInterval
+-- Helpers
-------------------------------------------------------------------------------
--- | A complementary representation of a 'VersionRange'. Instead of a boolean
--- version predicate it uses an increasing sequence of non-overlapping,
--- non-empty intervals.
+-- | Check an upper bound does not intersect, or even touch a lower bound:
--
--- The key point is that this representation gives a canonical representation
--- for the semantics of 'VersionRange's. This makes it easier to check things
--- like whether a version range is empty, covers all versions, or requires a
--- certain minimum or maximum version. It also makes it easy to check equality
--- or containment. It also makes it easier to identify \'simple\' version
--- predicates for translation into foreign packaging systems that do not
--- support complex version range expressions.
---
-newtype VersionIntervals = VersionIntervals [VersionInterval]
- deriving (Eq, Show, Typeable)
-
--- | Inspect the list of version intervals.
+-- @
+-- ---| or ---) but not ---] or ---) or ---]
+-- |--- (--- (--- [--- [---
+-- @
--
-versionIntervals :: VersionIntervals -> [VersionInterval]
-versionIntervals (VersionIntervals is) = is
-
-type VersionInterval = (LowerBound, UpperBound)
-data LowerBound = LowerBound Version !Bound deriving (Eq, Show)
-data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show)
-data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show)
-
-minLowerBound :: LowerBound
-minLowerBound = LowerBound (mkVersion [0]) InclusiveBound
+doesNotTouch :: UpperBound -> LowerBound -> Bool
+doesNotTouch NoUpperBound _ = False
+doesNotTouch (UpperBound u ub) (LowerBound l lb) =
+ (u < l) || (u == l && ub == ExclusiveBound && lb == ExclusiveBound)
-isVersion0 :: Version -> Bool
-isVersion0 = (==) version0
+-------------------------------------------------------------------------------
+-- Invariants
+-------------------------------------------------------------------------------
-instance Ord LowerBound where
- LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of
- LT -> True
- EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound)
- GT -> False
-
-instance Ord UpperBound where
- _ <= NoUpperBound = True
- NoUpperBound <= UpperBound _ _ = False
- UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of
- LT -> True
- EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound)
- GT -> False
-
-invariant :: VersionIntervals -> Bool
-invariant (VersionIntervals intervals) = all validInterval intervals
- && all doesNotTouch' adjacentIntervals
+-- | 'VersionIntervals' invariant:
+--
+-- * all intervals are valid (lower bound is less then upper bound, i.e. non-empty)
+-- * intervals doesn't touch each other (distinct)
+--
+invariantVersionIntervals :: VersionIntervals -> Bool
+invariantVersionIntervals (VersionIntervals intervals) =
+ all validInterval intervals &&
+ all doesNotTouch' adjacentIntervals
where
doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool
- doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l'
+ doesNotTouch' (VersionInterval _ u, VersionInterval l' _) = doesNotTouch u l'
adjacentIntervals :: [(VersionInterval, VersionInterval)]
adjacentIntervals = case intervals of
@@ -123,242 +258,88 @@ invariant (VersionIntervals intervals) = all validInterval intervals
(_:tl) -> zip intervals tl
checkInvariant :: VersionIntervals -> VersionIntervals
-checkInvariant is = assert (invariant is) is
+checkInvariant is = assert (invariantVersionIntervals is) is
+{-# INLINE checkInvariant #-}
--- | Directly construct a 'VersionIntervals' from a list of intervals.
---
--- In @Cabal-2.2@ the 'Maybe' is dropped from the result type.
---
-mkVersionIntervals :: [VersionInterval] -> VersionIntervals
-mkVersionIntervals intervals
- | invariant (VersionIntervals intervals) = VersionIntervals intervals
- | otherwise
- = checkInvariant
- . foldl' (flip insertInterval) (VersionIntervals [])
- . filter validInterval
- $ intervals
-
-insertInterval :: VersionInterval -> VersionIntervals -> VersionIntervals
-insertInterval i is = unionVersionIntervals (VersionIntervals [i]) is
-
-validInterval :: (LowerBound, UpperBound) -> Bool
-validInterval i@(l, u) = validLower l && validUpper u && nonEmptyVI i
+validInterval :: VersionInterval -> Bool
+validInterval i@(VersionInterval l u) = validLower l && validUpper u && nonEmptyVI i
where
validLower (LowerBound v _) = validVersion v
- validUpper NoUpperBound = True
- validUpper (UpperBound v _) = validVersion v
+ validUpper NoUpperBound = True
+ validUpper (UpperBound v _) = validVersion v
-- Check an interval is non-empty
--
nonEmptyVI :: VersionInterval -> Bool
-nonEmptyVI (_, NoUpperBound ) = True
-nonEmptyVI (LowerBound l lb, UpperBound u ub) =
+nonEmptyVI (VersionInterval _ NoUpperBound) = True
+nonEmptyVI (VersionInterval (LowerBound l lb) (UpperBound u ub)) =
(l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound)
--- Check an upper bound does not intersect, or even touch a lower bound:
---
--- ---| or ---) but not ---] or ---) or ---]
--- |--- (--- (--- [--- [---
---
-doesNotTouch :: UpperBound -> LowerBound -> Bool
-doesNotTouch NoUpperBound _ = False
-doesNotTouch (UpperBound u ub) (LowerBound l lb) =
- u < l
- || (u == l && ub == ExclusiveBound && lb == ExclusiveBound)
-
--- | Check an upper bound does not intersect a lower bound:
---
--- ---| or ---) or ---] or ---) but not ---]
--- |--- (--- (--- [--- [---
---
-doesNotIntersect :: UpperBound -> LowerBound -> Bool
-doesNotIntersect NoUpperBound _ = False
-doesNotIntersect (UpperBound u ub) (LowerBound l lb) =
- u < l
- || (u == l && not (ub == InclusiveBound && lb == InclusiveBound))
-
--- | Test if a version falls within the version intervals.
---
--- It exists mostly for completeness and testing. It satisfies the following
--- properties:
---
--- > withinIntervals v (toVersionIntervals vr) = withinRange v vr
--- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs)
---
-withinIntervals :: Version -> VersionIntervals -> Bool
-withinIntervals v (VersionIntervals intervals) = any withinInterval intervals
- where
- withinInterval (lowerBound, upperBound) = withinLower lowerBound
- && withinUpper upperBound
- withinLower (LowerBound v' ExclusiveBound) = v' < v
- withinLower (LowerBound v' InclusiveBound) = v' <= v
-
- withinUpper NoUpperBound = True
- withinUpper (UpperBound v' ExclusiveBound) = v' > v
- withinUpper (UpperBound v' InclusiveBound) = v' >= v
+-------------------------------------------------------------------------------
+-- Conversions
+-------------------------------------------------------------------------------
-- | Convert a 'VersionRange' to a sequence of version intervals.
--
toVersionIntervals :: VersionRange -> VersionIntervals
-toVersionIntervals = cataVersionRange alg where
- alg (ThisVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)
- alg (LaterVersionF v) = chkIvl (LowerBound v ExclusiveBound, NoUpperBound)
- alg (OrLaterVersionF v) = chkIvl (LowerBound v InclusiveBound, NoUpperBound)
- alg (EarlierVersionF v)
- | isVersion0 v = VersionIntervals []
- | otherwise = chkIvl (minLowerBound, UpperBound v ExclusiveBound)
- alg (OrEarlierVersionF v) = chkIvl (minLowerBound, UpperBound v InclusiveBound)
- alg (MajorBoundVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound (majorUpperBound v) ExclusiveBound)
- alg (UnionVersionRangesF v1 v2) = unionVersionIntervals v1 v2
- alg (IntersectVersionRangesF v1 v2) = intersectVersionIntervals v1 v2
-
- chkIvl interval = checkInvariant (VersionIntervals [interval])
+toVersionIntervals = postprocess . stage1
-- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression
-- representing the version intervals.
--
fromVersionIntervals :: VersionIntervals -> VersionRange
-fromVersionIntervals (VersionIntervals []) = noVersion
-fromVersionIntervals (VersionIntervals intervals) =
- Prelude.foldr1 unionVersionRanges [ interval l u | (l, u) <- intervals ]
+fromVersionIntervals (VersionIntervals []) = noVersion
+fromVersionIntervals (VersionIntervals (x:xs)) = foldr1 unionVersionRanges (fmap intervalToVersionRange (x:|xs))
- where
- interval (LowerBound v InclusiveBound)
- (UpperBound v' InclusiveBound) | v == v'
- = thisVersion v
- interval l u = lowerBound l `intersectVersionRanges'` upperBound u
-
- lowerBound (LowerBound v InclusiveBound)
- | isVersion0 v = Nothing
- | otherwise = Just (orLaterVersion v)
- lowerBound (LowerBound v ExclusiveBound) = Just (laterVersion v)
-
- upperBound NoUpperBound = Nothing
- upperBound (UpperBound v InclusiveBound) = Just (orEarlierVersion v)
- upperBound (UpperBound v ExclusiveBound) = Just (earlierVersion v)
-
- intersectVersionRanges' Nothing Nothing = anyVersion
- intersectVersionRanges' (Just vr) Nothing = vr
- intersectVersionRanges' Nothing (Just vr) = vr
- intersectVersionRanges' (Just vr) (Just vr') = intersectVersionRanges vr vr'
-
-unionVersionIntervals :: VersionIntervals -> VersionIntervals
- -> VersionIntervals
-unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) =
- checkInvariant (VersionIntervals (union is0 is'0))
- where
- union is [] = is
- union [] is' = is'
- union (i:is) (i':is') = case unionInterval i i' of
- Left Nothing -> i : union is (i' :is')
- Left (Just i'') -> union is (i'':is')
- Right Nothing -> i' : union (i :is) is'
- Right (Just i'') -> union (i'':is) is'
-
-unionInterval :: VersionInterval -> VersionInterval
- -> Either (Maybe VersionInterval) (Maybe VersionInterval)
-unionInterval (lower , upper ) (lower', upper')
-
- -- Non-intersecting intervals with the left interval ending first
- | upper `doesNotTouch` lower' = Left Nothing
-
- -- Non-intersecting intervals with the right interval first
- | upper' `doesNotTouch` lower = Right Nothing
-
- -- Complete or partial overlap, with the left interval ending first
- | upper <= upper' = lowerBound `seq`
- Left (Just (lowerBound, upper'))
-
- -- Complete or partial overlap, with the left interval ending first
- | otherwise = lowerBound `seq`
- Right (Just (lowerBound, upper))
- where
- lowerBound = min lower lower'
+intervalToVersionRange :: VersionInterval -> VersionRange
+intervalToVersionRange (VersionInterval (LowerBound v vb) upper') = case upper' of
+ NoUpperBound
+ -> lowerBound
-intersectVersionIntervals :: VersionIntervals -> VersionIntervals
- -> VersionIntervals
-intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) =
- checkInvariant (VersionIntervals (intersect is0 is'0))
- where
- intersect _ [] = []
- intersect [] _ = []
- intersect (i:is) (i':is') = case intersectInterval i i' of
- Left Nothing -> intersect is (i':is')
- Left (Just i'') -> i'' : intersect is (i':is')
- Right Nothing -> intersect (i:is) is'
- Right (Just i'') -> i'' : intersect (i:is) is'
-
-intersectInterval :: VersionInterval -> VersionInterval
- -> Either (Maybe VersionInterval) (Maybe VersionInterval)
-intersectInterval (lower , upper ) (lower', upper')
-
- -- Non-intersecting intervals with the left interval ending first
- | upper `doesNotIntersect` lower' = Left Nothing
-
- -- Non-intersecting intervals with the right interval first
- | upper' `doesNotIntersect` lower = Right Nothing
-
- -- Complete or partial overlap, with the left interval ending first
- | upper <= upper' = lowerBound `seq`
- Left (Just (lowerBound, upper))
-
- -- Complete or partial overlap, with the right interval ending first
- | otherwise = lowerBound `seq`
- Right (Just (lowerBound, upper'))
+ UpperBound u ub
+ | vb == InclusiveBound
+ , ub == InclusiveBound
+ , v == u
+ -> thisVersion v
+
+ UpperBound u ub -> withLowerBound (makeUpperBound u ub)
where
- lowerBound = max lower lower'
-
-invertVersionIntervals :: VersionIntervals
- -> VersionIntervals
-invertVersionIntervals (VersionIntervals xs) =
- case xs of
- -- Empty interval set
- [] -> VersionIntervals [(noLowerBound, NoUpperBound)]
- -- Interval with no lower bound
- ((lb, ub) : more) | lb == noLowerBound ->
- VersionIntervals $ invertVersionIntervals' ub more
- -- Interval with a lower bound
- ((lb, ub) : more) ->
- VersionIntervals $ (noLowerBound, invertLowerBound lb)
- : invertVersionIntervals' ub more
- where
- -- Invert subsequent version intervals given the upper bound of
- -- the intervals already inverted.
- invertVersionIntervals' :: UpperBound
- -> [(LowerBound, UpperBound)]
- -> [(LowerBound, UpperBound)]
- invertVersionIntervals' NoUpperBound [] = []
- invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)]
- invertVersionIntervals' ub0 [(lb, NoUpperBound)] =
- [(invertUpperBound ub0, invertLowerBound lb)]
- invertVersionIntervals' ub0 ((lb, ub1) : more) =
- (invertUpperBound ub0, invertLowerBound lb)
- : invertVersionIntervals' ub1 more
-
- invertLowerBound :: LowerBound -> UpperBound
- invertLowerBound (LowerBound v b) = UpperBound v (invertBound b)
-
- invertUpperBound :: UpperBound -> LowerBound
- invertUpperBound (UpperBound v b) = LowerBound v (invertBound b)
- invertUpperBound NoUpperBound = error "NoUpperBound: unexpected"
-
- invertBound :: Bound -> Bound
- invertBound ExclusiveBound = InclusiveBound
- invertBound InclusiveBound = ExclusiveBound
-
- noLowerBound :: LowerBound
- noLowerBound = LowerBound (mkVersion [0]) InclusiveBound
+ lowerBound :: VersionRange
+ lowerBound = case vb of
+ InclusiveBound -> orLaterVersion v
+ ExclusiveBound -> laterVersion v
+
+ withLowerBound :: VersionRange -> VersionRange
+ withLowerBound vr
+ | isVersion0 v, vb == InclusiveBound = vr
+ | otherwise = intersectVersionRanges lowerBound vr
+ makeUpperBound :: Version -> Bound -> VersionRange
+ makeUpperBound u InclusiveBound = orEarlierVersion u
+ makeUpperBound u ExclusiveBound = earlierVersion u
+
+-------------------------------------------------------------------------------
+-- Normalisation
+-------------------------------------------------------------------------------
+
+-- | Since @Cabal-3.6@ this function.. TODO
+--
+normaliseVersionRange2 :: VersionRange -> VersionRange
+normaliseVersionRange2 = fromVersionIntervals . toVersionIntervals
+
+-------------------------------------------------------------------------------
+-- Relaxation
+-------------------------------------------------------------------------------
relaxLastInterval :: VersionIntervals -> VersionIntervals
relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs)
where
- relaxLastInterval' [] = []
- relaxLastInterval' [(l,_)] = [(l, NoUpperBound)]
- relaxLastInterval' (i:is) = i : relaxLastInterval' is
+ relaxLastInterval' [] = []
+ relaxLastInterval' [VersionInterval l _] = [VersionInterval l NoUpperBound]
+ relaxLastInterval' (i:is) = i : relaxLastInterval' is
relaxHeadInterval :: VersionIntervals -> VersionIntervals
relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs)
where
- relaxHeadInterval' [] = []
- relaxHeadInterval' ((_,u):is) = (minLowerBound,u) : is
+ relaxHeadInterval' [] = []
+ relaxHeadInterval' (VersionInterval _ u : is) = VersionInterval zeroLowerBound u : is
diff --git a/Cabal/src/Distribution/Types/VersionInterval/Legacy.hs b/Cabal/src/Distribution/Types/VersionInterval/Legacy.hs
new file mode 100644
index 0000000000..4d16156fb7
--- /dev/null
+++ b/Cabal/src/Distribution/Types/VersionInterval/Legacy.hs
@@ -0,0 +1,368 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+-- | This is old version of "Distribution.Types.VersionInterval" module.
+--
+-- It will be removed in @Cabal-3.8@.
+--
+module Distribution.Types.VersionInterval.Legacy {-# DEPRECATED "Use Distribution.Types.VersionInterval instead" #-} (
+ -- * Version intervals
+ VersionIntervals,
+ toVersionIntervals,
+ fromVersionIntervals,
+ withinIntervals,
+ versionIntervals,
+ mkVersionIntervals,
+ unionVersionIntervals,
+ intersectVersionIntervals,
+ invertVersionIntervals,
+ relaxLastInterval,
+ relaxHeadInterval,
+
+ -- * Version intervals view
+ asVersionIntervals,
+ VersionInterval,
+ LowerBound(..),
+ UpperBound(..),
+ Bound(..),
+ ) where
+
+import Prelude ()
+import Distribution.Compat.Prelude
+import Control.Exception (assert)
+
+import Distribution.Types.Version
+import Distribution.Types.VersionRange.Internal
+
+-- NonEmpty
+import qualified Prelude (foldr1)
+
+-------------------------------------------------------------------------------
+-- VersionRange
+-------------------------------------------------------------------------------
+
+-- | View a 'VersionRange' as a union of intervals.
+--
+-- This provides a canonical view of the semantics of a 'VersionRange' as
+-- opposed to the syntax of the expression used to define it. For the syntactic
+-- view use 'foldVersionRange'.
+--
+-- Each interval is non-empty. The sequence is in increasing order and no
+-- intervals overlap or touch. Therefore only the first and last can be
+-- unbounded. The sequence can be empty if the range is empty
+-- (e.g. a range expression like @< 1 && > 2@).
+--
+-- Other checks are trivial to implement using this view. For example:
+--
+-- > isNoVersion vr | [] <- asVersionIntervals vr = True
+-- > | otherwise = False
+--
+-- > isSpecificVersion vr
+-- > | [(LowerBound v InclusiveBound
+-- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr
+-- > , v == v' = Just v
+-- > | otherwise = Nothing
+--
+asVersionIntervals :: VersionRange -> [VersionInterval]
+asVersionIntervals = versionIntervals . toVersionIntervals
+
+
+-------------------------------------------------------------------------------
+-- VersionInterval
+-------------------------------------------------------------------------------
+
+-- | A complementary representation of a 'VersionRange'. Instead of a boolean
+-- version predicate it uses an increasing sequence of non-overlapping,
+-- non-empty intervals.
+--
+-- The key point is that this representation gives a canonical representation
+-- for the semantics of 'VersionRange's. This makes it easier to check things
+-- like whether a version range is empty, covers all versions, or requires a
+-- certain minimum or maximum version. It also makes it easy to check equality
+-- or containment. It also makes it easier to identify \'simple\' version
+-- predicates for translation into foreign packaging systems that do not
+-- support complex version range expressions.
+--
+newtype VersionIntervals = VersionIntervals [VersionInterval]
+ deriving (Eq, Show, Typeable)
+
+-- | Inspect the list of version intervals.
+--
+versionIntervals :: VersionIntervals -> [VersionInterval]
+versionIntervals (VersionIntervals is) = is
+
+type VersionInterval = (LowerBound, UpperBound)
+data LowerBound = LowerBound Version !Bound deriving (Eq, Show)
+data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show)
+data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show)
+
+minLowerBound :: LowerBound
+minLowerBound = LowerBound (mkVersion [0]) InclusiveBound
+
+isVersion0 :: Version -> Bool
+isVersion0 = (==) version0
+
+instance Ord LowerBound where
+ LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of
+ LT -> True
+ EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound)
+ GT -> False
+
+instance Ord UpperBound where
+ _ <= NoUpperBound = True
+ NoUpperBound <= UpperBound _ _ = False
+ UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of
+ LT -> True
+ EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound)
+ GT -> False
+
+invariant :: VersionIntervals -> Bool
+invariant (VersionIntervals intervals) = all validInterval intervals
+ && all doesNotTouch' adjacentIntervals
+ where
+ doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool
+ doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l'
+
+ adjacentIntervals :: [(VersionInterval, VersionInterval)]
+ adjacentIntervals = case intervals of
+ [] -> []
+ (_:tl) -> zip intervals tl
+
+checkInvariant :: VersionIntervals -> VersionIntervals
+checkInvariant is = assert (invariant is) is
+
+-- | Directly construct a 'VersionIntervals' from a list of intervals.
+--
+-- In @Cabal-2.2@ the 'Maybe' is dropped from the result type.
+--
+mkVersionIntervals :: [VersionInterval] -> VersionIntervals
+mkVersionIntervals intervals
+ | invariant (VersionIntervals intervals) = VersionIntervals intervals
+ | otherwise
+ = checkInvariant
+ . foldl' (flip insertInterval) (VersionIntervals [])
+ . filter validInterval
+ $ intervals
+
+insertInterval :: VersionInterval -> VersionIntervals -> VersionIntervals
+insertInterval i is = unionVersionIntervals (VersionIntervals [i]) is
+
+validInterval :: (LowerBound, UpperBound) -> Bool
+validInterval i@(l, u) = validLower l && validUpper u && nonEmptyVI i
+ where
+ validLower (LowerBound v _) = validVersion v
+ validUpper NoUpperBound = True
+ validUpper (UpperBound v _) = validVersion v
+
+-- Check an interval is non-empty
+--
+nonEmptyVI :: VersionInterval -> Bool
+nonEmptyVI (_, NoUpperBound ) = True
+nonEmptyVI (LowerBound l lb, UpperBound u ub) =
+ (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound)
+
+-- Check an upper bound does not intersect, or even touch a lower bound:
+--
+-- ---| or ---) but not ---] or ---) or ---]
+-- |--- (--- (--- [--- [---
+--
+doesNotTouch :: UpperBound -> LowerBound -> Bool
+doesNotTouch NoUpperBound _ = False
+doesNotTouch (UpperBound u ub) (LowerBound l lb) =
+ u < l
+ || (u == l && ub == ExclusiveBound && lb == ExclusiveBound)
+
+-- | Check an upper bound does not intersect a lower bound:
+--
+-- ---| or ---) or ---] or ---) but not ---]
+-- |--- (--- (--- [--- [---
+--
+doesNotIntersect :: UpperBound -> LowerBound -> Bool
+doesNotIntersect NoUpperBound _ = False
+doesNotIntersect (UpperBound u ub) (LowerBound l lb) =
+ u < l
+ || (u == l && not (ub == InclusiveBound && lb == InclusiveBound))
+
+-- | Test if a version falls within the version intervals.
+--
+-- It exists mostly for completeness and testing. It satisfies the following
+-- properties:
+--
+-- > withinIntervals v (toVersionIntervals vr) = withinRange v vr
+-- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs)
+--
+withinIntervals :: Version -> VersionIntervals -> Bool
+withinIntervals v (VersionIntervals intervals) = any withinInterval intervals
+ where
+ withinInterval (lowerBound, upperBound) = withinLower lowerBound
+ && withinUpper upperBound
+ withinLower (LowerBound v' ExclusiveBound) = v' < v
+ withinLower (LowerBound v' InclusiveBound) = v' <= v
+
+ withinUpper NoUpperBound = True
+ withinUpper (UpperBound v' ExclusiveBound) = v' > v
+ withinUpper (UpperBound v' InclusiveBound) = v' >= v
+
+-- | Convert a 'VersionRange' to a sequence of version intervals.
+--
+toVersionIntervals :: VersionRange -> VersionIntervals
+toVersionIntervals = cataVersionRange alg where
+ alg (ThisVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)
+ alg (LaterVersionF v) = chkIvl (LowerBound v ExclusiveBound, NoUpperBound)
+ alg (OrLaterVersionF v) = chkIvl (LowerBound v InclusiveBound, NoUpperBound)
+ alg (EarlierVersionF v)
+ | isVersion0 v = VersionIntervals []
+ | otherwise = chkIvl (minLowerBound, UpperBound v ExclusiveBound)
+ alg (OrEarlierVersionF v) = chkIvl (minLowerBound, UpperBound v InclusiveBound)
+ alg (MajorBoundVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound (majorUpperBound v) ExclusiveBound)
+ alg (UnionVersionRangesF v1 v2) = unionVersionIntervals v1 v2
+ alg (IntersectVersionRangesF v1 v2) = intersectVersionIntervals v1 v2
+
+ chkIvl interval = checkInvariant (VersionIntervals [interval])
+
+-- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression
+-- representing the version intervals.
+--
+fromVersionIntervals :: VersionIntervals -> VersionRange
+fromVersionIntervals (VersionIntervals []) = noVersion
+fromVersionIntervals (VersionIntervals intervals) =
+ Prelude.foldr1 unionVersionRanges [ interval l u | (l, u) <- intervals ]
+
+ where
+ interval (LowerBound v InclusiveBound)
+ (UpperBound v' InclusiveBound) | v == v'
+ = thisVersion v
+ interval l u = lowerBound l `intersectVersionRanges'` upperBound u
+
+ lowerBound (LowerBound v InclusiveBound)
+ | isVersion0 v = Nothing
+ | otherwise = Just (orLaterVersion v)
+ lowerBound (LowerBound v ExclusiveBound) = Just (laterVersion v)
+
+ upperBound NoUpperBound = Nothing
+ upperBound (UpperBound v InclusiveBound) = Just (orEarlierVersion v)
+ upperBound (UpperBound v ExclusiveBound) = Just (earlierVersion v)
+
+ intersectVersionRanges' Nothing Nothing = anyVersion
+ intersectVersionRanges' (Just vr) Nothing = vr
+ intersectVersionRanges' Nothing (Just vr) = vr
+ intersectVersionRanges' (Just vr) (Just vr') = intersectVersionRanges vr vr'
+
+unionVersionIntervals :: VersionIntervals -> VersionIntervals
+ -> VersionIntervals
+unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) =
+ checkInvariant (VersionIntervals (union is0 is'0))
+ where
+ union is [] = is
+ union [] is' = is'
+ union (i:is) (i':is') = case unionInterval i i' of
+ Left Nothing -> i : union is (i' :is')
+ Left (Just i'') -> union is (i'':is')
+ Right Nothing -> i' : union (i :is) is'
+ Right (Just i'') -> union (i'':is) is'
+
+unionInterval :: VersionInterval -> VersionInterval
+ -> Either (Maybe VersionInterval) (Maybe VersionInterval)
+unionInterval (lower , upper ) (lower', upper')
+
+ -- Non-intersecting intervals with the left interval ending first
+ | upper `doesNotTouch` lower' = Left Nothing
+
+ -- Non-intersecting intervals with the right interval first
+ | upper' `doesNotTouch` lower = Right Nothing
+
+ -- Complete or partial overlap, with the left interval ending first
+ | upper <= upper' = lowerBound `seq`
+ Left (Just (lowerBound, upper'))
+
+ -- Complete or partial overlap, with the left interval ending first
+ | otherwise = lowerBound `seq`
+ Right (Just (lowerBound, upper))
+ where
+ lowerBound = min lower lower'
+
+intersectVersionIntervals :: VersionIntervals -> VersionIntervals
+ -> VersionIntervals
+intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) =
+ checkInvariant (VersionIntervals (intersect is0 is'0))
+ where
+ intersect _ [] = []
+ intersect [] _ = []
+ intersect (i:is) (i':is') = case intersectInterval i i' of
+ Left Nothing -> intersect is (i':is')
+ Left (Just i'') -> i'' : intersect is (i':is')
+ Right Nothing -> intersect (i:is) is'
+ Right (Just i'') -> i'' : intersect (i:is) is'
+
+intersectInterval :: VersionInterval -> VersionInterval
+ -> Either (Maybe VersionInterval) (Maybe VersionInterval)
+intersectInterval (lower , upper ) (lower', upper')
+
+ -- Non-intersecting intervals with the left interval ending first
+ | upper `doesNotIntersect` lower' = Left Nothing
+
+ -- Non-intersecting intervals with the right interval first
+ | upper' `doesNotIntersect` lower = Right Nothing
+
+ -- Complete or partial overlap, with the left interval ending first
+ | upper <= upper' = lowerBound `seq`
+ Left (Just (lowerBound, upper))
+
+ -- Complete or partial overlap, with the right interval ending first
+ | otherwise = lowerBound `seq`
+ Right (Just (lowerBound, upper'))
+ where
+ lowerBound = max lower lower'
+
+invertVersionIntervals :: VersionIntervals
+ -> VersionIntervals
+invertVersionIntervals (VersionIntervals xs) =
+ case xs of
+ -- Empty interval set
+ [] -> VersionIntervals [(noLowerBound, NoUpperBound)]
+ -- Interval with no lower bound
+ ((lb, ub) : more) | lb == noLowerBound ->
+ VersionIntervals $ invertVersionIntervals' ub more
+ -- Interval with a lower bound
+ ((lb, ub) : more) ->
+ VersionIntervals $ (noLowerBound, invertLowerBound lb)
+ : invertVersionIntervals' ub more
+ where
+ -- Invert subsequent version intervals given the upper bound of
+ -- the intervals already inverted.
+ invertVersionIntervals' :: UpperBound
+ -> [(LowerBound, UpperBound)]
+ -> [(LowerBound, UpperBound)]
+ invertVersionIntervals' NoUpperBound [] = []
+ invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)]
+ invertVersionIntervals' ub0 [(lb, NoUpperBound)] =
+ [(invertUpperBound ub0, invertLowerBound lb)]
+ invertVersionIntervals' ub0 ((lb, ub1) : more) =
+ (invertUpperBound ub0, invertLowerBound lb)
+ : invertVersionIntervals' ub1 more
+
+ invertLowerBound :: LowerBound -> UpperBound
+ invertLowerBound (LowerBound v b) = UpperBound v (invertBound b)
+
+ invertUpperBound :: UpperBound -> LowerBound
+ invertUpperBound (UpperBound v b) = LowerBound v (invertBound b)
+ invertUpperBound NoUpperBound = error "NoUpperBound: unexpected"
+
+ invertBound :: Bound -> Bound
+ invertBound ExclusiveBound = InclusiveBound
+ invertBound InclusiveBound = ExclusiveBound
+
+ noLowerBound :: LowerBound
+ noLowerBound = LowerBound (mkVersion [0]) InclusiveBound
+
+
+relaxLastInterval :: VersionIntervals -> VersionIntervals
+relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs)
+ where
+ relaxLastInterval' [] = []
+ relaxLastInterval' [(l,_)] = [(l, NoUpperBound)]
+ relaxLastInterval' (i:is) = i : relaxLastInterval' is
+
+relaxHeadInterval :: VersionIntervals -> VersionIntervals
+relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs)
+ where
+ relaxHeadInterval' [] = []
+ relaxHeadInterval' ((_,u):is) = (minLowerBound,u) : is
diff --git a/Cabal/src/Distribution/Types/VersionRange.hs b/Cabal/src/Distribution/Types/VersionRange.hs
index 2bd8a8f941..1f10688407 100644
--- a/Cabal/src/Distribution/Types/VersionRange.hs
+++ b/Cabal/src/Distribution/Types/VersionRange.hs
@@ -128,8 +128,8 @@ withinRange v = foldVersionRange
--
isAnyVersion :: VersionRange -> Bool
isAnyVersion vr = case asVersionIntervals vr of
- [(LowerBound v InclusiveBound, NoUpperBound)] -> v == version0
- _ -> False
+ [VersionInterval (LowerBound v InclusiveBound) NoUpperBound] -> v == version0
+ _ -> False
-- A fast and non-precise version of 'isAnyVersion',
-- returns 'True' only for @>= 0@ 'VersionRange's.
diff --git a/Cabal/src/Distribution/Version.hs b/Cabal/src/Distribution/Version.hs
index f282759043..33e2885af7 100644
--- a/Cabal/src/Distribution/Version.hs
+++ b/Cabal/src/Distribution/Version.hs
@@ -31,8 +31,6 @@ module Distribution.Version (
laterVersion, earlierVersion,
orLaterVersion, orEarlierVersion,
unionVersionRanges, intersectVersionRanges,
- differenceVersionRanges,
- invertVersionRange,
withinVersion,
majorBoundVersion,
@@ -63,10 +61,13 @@ module Distribution.Version (
-- ** Modification
removeUpperBound,
removeLowerBound,
+ transformCaret,
+ transformCaretUpper,
+ transformCaretLower,
-- * Version intervals view
asVersionIntervals,
- VersionInterval,
+ VersionInterval(..),
LowerBound(..),
UpperBound(..),
Bound(..),
@@ -80,12 +81,7 @@ module Distribution.Version (
VersionIntervals,
toVersionIntervals,
fromVersionIntervals,
- withinIntervals,
- versionIntervals,
- mkVersionIntervals,
- unionVersionIntervals,
- intersectVersionIntervals,
- invertVersionIntervals
+ unVersionIntervals,
) where
@@ -116,11 +112,14 @@ isNoVersion vr = case asVersionIntervals vr of
--
isSpecificVersion :: VersionRange -> Maybe Version
isSpecificVersion vr = case asVersionIntervals vr of
- [(LowerBound v InclusiveBound
- ,UpperBound v' InclusiveBound)]
+ [VersionInterval (LowerBound v InclusiveBound) (UpperBound v' InclusiveBound)]
| v == v' -> Just v
_ -> Nothing
+-------------------------------------------------------------------------------
+-- Transformations
+-------------------------------------------------------------------------------
+
-- | Simplify a 'VersionRange' expression. For non-empty version ranges
-- this produces a canonical form. Empty or inconsistent version ranges
-- are left as-is because that provides more information.
@@ -142,30 +141,11 @@ simplifyVersionRange vr
-- If the version range is inconsistent then we just return the
-- original since that has more information than ">1 && < 1", which
-- is the canonical inconsistent version range.
- | null (versionIntervals vi) = vr
- | otherwise = fromVersionIntervals vi
+ | null (unVersionIntervals vi) = vr
+ | otherwise = fromVersionIntervals vi
where
vi = toVersionIntervals vr
--- | The difference of two version ranges
---
--- > withinRange v' (differenceVersionRanges vr1 vr2)
--- > = withinRange v' vr1 && not (withinRange v' vr2)
---
--- @since 1.24.1.0
-differenceVersionRanges :: VersionRange -> VersionRange -> VersionRange
-differenceVersionRanges vr1 vr2 =
- intersectVersionRanges vr1 (invertVersionRange vr2)
-
--- | The inverse of a version range
---
--- > withinRange v' (invertVersionRange vr)
--- > = not (withinRange v' vr)
---
-invertVersionRange :: VersionRange -> VersionRange
-invertVersionRange =
- fromVersionIntervals . invertVersionIntervals . toVersionIntervals
-
-- | Given a version range, remove the highest upper bound. Example: @(>= 1 && <
-- 3) || (>= 4 && < 5)@ is converted to @(>= 1 && < 3) || (>= 4)@.
removeUpperBound :: VersionRange -> VersionRange
@@ -176,3 +156,30 @@ removeUpperBound = fromVersionIntervals . relaxLastInterval . toVersionIntervals
-- @(>= 0 && < 3) || (>= 4 && < 5)@.
removeLowerBound :: VersionRange -> VersionRange
removeLowerBound = fromVersionIntervals . relaxHeadInterval . toVersionIntervals
+
+-- | Rewrite @^>= x.y.z@ into @>= x.y.z && < x.(y+1)@
+--
+-- @since 3.6.0.0
+--
+transformCaret :: VersionRange -> VersionRange
+transformCaret = hyloVersionRange embed projectVersionRange where
+ embed (MajorBoundVersionF v) = orLaterVersion v `intersectVersionRanges` earlierVersion (majorUpperBound v)
+ embed vr = embedVersionRange vr
+
+-- | Rewrite @^>= x.y.z@ into @>= x.y.z@
+--
+-- @since 3.6.0.0
+--
+transformCaretUpper :: VersionRange -> VersionRange
+transformCaretUpper = hyloVersionRange embed projectVersionRange where
+ embed (MajorBoundVersionF v) = orLaterVersion v
+ embed vr = embedVersionRange vr
+
+-- | Rewrite @^>= x.y.z@ into @<x.(y+1)@
+--
+-- @since 3.6.0.0
+--
+transformCaretLower :: VersionRange -> VersionRange
+transformCaretLower = hyloVersionRange embed projectVersionRange where
+ embed (MajorBoundVersionF v) = earlierVersion (majorUpperBound v)
+ embed vr = embedVersionRange vr
diff --git a/Cabal/tests/UnitTests/Distribution/Version.hs b/Cabal/tests/UnitTests/Distribution/Version.hs
index 024ab84012..27d9f440af 100644
--- a/Cabal/tests/UnitTests/Distribution/Version.hs
+++ b/Cabal/tests/UnitTests/Distribution/Version.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns
-fno-warn-deprecations
-fno-warn-unused-binds #-} --FIXME
@@ -7,23 +8,23 @@ module UnitTests.Distribution.Version (versionTests) where
import Distribution.Compat.Prelude.Internal
import Prelude ()
-import Distribution.Version
-import Distribution.Types.VersionRange.Internal
-import Distribution.Parsec (simpleParsec)
+import Distribution.Parsec (simpleParsec)
import Distribution.Pretty
+import Distribution.Types.VersionRange.Internal
import Distribution.Utils.Generic
+import Distribution.Version
-import Data.Typeable (typeOf)
-import Math.NumberTheory.Logarithms (intLog2)
-import Text.PrettyPrint as Disp (text, render, hcat
- ,punctuate, int, char)
-import Test.Tasty
-import Test.Tasty.QuickCheck
-import qualified Test.Laws as Laws
+import Data.Maybe (fromJust)
+import Data.Typeable (typeOf)
+import Test.QuickCheck (Arbitrary (..), NonEmptyList (..), NonNegative (..), Property, Testable, counterexample, property, (===), (==>), vectorOf, sized, choose, arbitrarySizedNatural)
import Test.QuickCheck.Instances.Cabal ()
+import Test.Tasty (TestTree)
+import Test.Tasty.QuickCheck (testProperty)
-import Data.Maybe (fromJust)
+import qualified Distribution.Types.VersionInterval as New
+import qualified Distribution.Types.VersionInterval.Legacy as Old
+import qualified Text.PrettyPrint as Disp
versionTests :: [TestTree]
versionTests =
@@ -38,9 +39,17 @@ versionTests =
, tp "readMaybe . show = Just" prop_ShowRead
, tp "read example" prop_ShowRead_example
- , tp "normaliseVersionRange involutive" prop_normalise_inv
, tp "parsec . prettyShow involutive" prop_parsec_disp_inv
+ , tp "normaliseVersionRange involutive" prop_normalise_inv
+ , tp "normaliseVersionRange equivalent" prop_normalise_equiv
+ , tp "normaliseVersionRange caretequiv" prop_normalise_caret_equiv
+ , tp "normaliseVersionRange model" prop_normalise_model
+
+ , tp "simplifyVersionRange involutive" prop_simplify_inv
+ , tp "simplifyVersionRange equivalent" prop_simplify_equiv
+ -- , tp "simplifyVersionRange caretequiv" prop_simplify_caret_equiv
+
, tp "simpleParsec . prettyShow = Just" prop_parse_disp
]
@@ -52,8 +61,6 @@ versionTests =
[ typProperty prop_nonNull
, typProperty prop_gen_intervals1
, typProperty prop_gen_intervals2
- --, typProperty prop_equivalentVersionRange --FIXME: runs out of test cases
- , typProperty prop_intermediateVersion
, typProperty prop_anyVersion
, typProperty prop_noVersion
@@ -65,47 +72,11 @@ versionTests =
, typProperty prop_orEarlierVersion
, typProperty prop_unionVersionRanges
, typProperty prop_intersectVersionRanges
- , typProperty prop_differenceVersionRanges
- , typProperty prop_invertVersionRange
, typProperty prop_withinVersion
, typProperty prop_foldVersionRange
- -- the semantic query functions
- --, typProperty prop_isAnyVersion1 --FIXME: runs out of test cases
- --, typProperty prop_isAnyVersion2 --FIXME: runs out of test cases
- --, typProperty prop_isNoVersion --FIXME: runs out of test cases
- --, typProperty prop_isSpecificVersion1 --FIXME: runs out of test cases
- --, typProperty prop_isSpecificVersion2 --FIXME: runs out of test cases
- , typProperty prop_simplifyVersionRange1
- , typProperty prop_simplifyVersionRange1'
- --, typProperty prop_simplifyVersionRange2 --FIXME: runs out of test cases
- --, typProperty prop_simplifyVersionRange2' --FIXME: runs out of test cases
- --, typProperty prop_simplifyVersionRange2'' --FIXME: actually wrong
-
-- converting between version ranges and version intervals
- , typProperty prop_to_intervals
- --, typProperty prop_to_intervals_canonical --FIXME: runs out of test cases
- --, typProperty prop_to_intervals_canonical' --FIXME: runs out of test cases
- , typProperty prop_from_intervals
, typProperty prop_to_from_intervals
- , typProperty prop_from_to_intervals
- , typProperty prop_from_to_intervals'
-
- -- union and intersection of version intervals
- , typProperty prop_unionVersionIntervals
- , typProperty prop_unionVersionIntervals_idempotent
- , typProperty prop_unionVersionIntervals_commutative
- , typProperty prop_unionVersionIntervals_associative
- , typProperty prop_intersectVersionIntervals
- , typProperty prop_intersectVersionIntervals_idempotent
- , typProperty prop_intersectVersionIntervals_commutative
- , typProperty prop_intersectVersionIntervals_associative
- , typProperty prop_union_intersect_distributive
- , typProperty prop_intersect_union_distributive
-
- -- inversion of version intervals
- , typProperty prop_invertVersionIntervals
- , typProperty prop_invertVersionIntervalsTwice
]
where
tp :: Testable p => String -> p -> TestTree
@@ -113,21 +84,9 @@ versionTests =
typProperty p = (typeOf p, property p)
-
--- parseTests :: [TestTree]
--- parseTests =
--- zipWith (\n p -> testProperty ("Parse Property " ++ show n) p) [1::Int ..]
--- -- parsing and pretty printing
--- [ -- property prop_parse_disp1 --FIXME: actually wrong
-
--- -- These are also wrong, see
--- -- https://github.com/haskell/cabal/issues/3037#issuecomment-177671011
-
--- -- property prop_parse_disp2
--- -- , property prop_parse_disp3
--- -- , property prop_parse_disp4
--- -- , property prop_parse_disp5
--- ]
+-------------------------------------------------------------------------------
+-- Arbitrary for inputs of mkVersion
+-------------------------------------------------------------------------------
newtype VersionArb = VersionArb [Int]
deriving (Eq,Ord,Show)
@@ -190,8 +149,44 @@ prop_ShowRead_example = show (mkVersion [1,2,3]) == "mkVersion [1,2,3]"
--
prop_normalise_inv :: VersionRange -> Property
-prop_normalise_inv vr =
- normaliseVersionRange vr === normaliseVersionRange (normaliseVersionRange vr)
+prop_normalise_inv vr = normaliseVersionRange vr === normaliseVersionRange (normaliseVersionRange vr)
+
+prop_normalise_equiv :: VersionRange -> Version -> Property
+prop_normalise_equiv vr =
+ prop_equivalentVersionRange vr (normaliseVersionRange vr)
+
+prop_normalise_caret_equiv :: VersionRange -> Version -> Property
+prop_normalise_caret_equiv vr = prop_equivalentVersionRange
+ (transformCaretUpper vr)
+ (transformCaretUpper (normaliseVersionRange vr))
+
+prop_normalise_model :: VersionRange -> Property
+prop_normalise_model vr =
+ oldNormaliseVersionRange vr' === newNormaliseVersionRange vr'
+ where
+ vr' = transformCaret vr
+
+ oldNormaliseVersionRange :: VersionRange -> VersionRange
+ oldNormaliseVersionRange = Old.fromVersionIntervals . Old.toVersionIntervals
+
+ newNormaliseVersionRange :: VersionRange -> VersionRange
+ newNormaliseVersionRange = New.normaliseVersionRange2
+
+prop_simplify_inv :: VersionRange -> Property
+prop_simplify_inv vr =
+ simplifyVersionRange vr === simplifyVersionRange (simplifyVersionRange vr)
+
+prop_simplify_equiv :: VersionRange -> Version -> Property
+prop_simplify_equiv vr v =
+ counterexample (show vr') $ prop_equivalentVersionRange vr vr' v
+ where
+ vr' = simplifyVersionRange vr
+
+-- TODO: Doesn't hold yet
+-- prop_simplify_caret_equiv :: VersionRange -> Version -> Property
+-- prop_simplify_caret_equiv vr = prop_equivalentVersionRange
+-- (transformCaretUpper vr)
+-- (transformCaretUpper (simplifyVersionRange vr))
prop_nonNull :: Version -> Bool
prop_nonNull = (/= nullVersion)
@@ -244,16 +239,6 @@ prop_intersectVersionRanges vr1 vr2 v' =
withinRange v' (intersectVersionRanges vr1 vr2)
== (withinRange v' vr1 && withinRange v' vr2)
-prop_differenceVersionRanges :: VersionRange -> VersionRange -> Version -> Bool
-prop_differenceVersionRanges vr1 vr2 v' =
- withinRange v' (differenceVersionRanges vr1 vr2)
- == (withinRange v' vr1 && not (withinRange v' vr2))
-
-prop_invertVersionRange :: VersionRange -> Version -> Bool
-prop_invertVersionRange vr v' =
- withinRange v' (invertVersionRange vr)
- == not (withinRange v' vr)
-
prop_withinVersion :: Version -> Version -> Property
prop_withinVersion v v' =
withinRange v' (withinVersion v)
@@ -323,49 +308,12 @@ prop_isSpecificVersion2 range =
where
version = isSpecificVersion range
--- | 'simplifyVersionRange' is a semantic identity on 'VersionRange'.
---
-prop_simplifyVersionRange1 :: VersionRange -> Version -> Bool
-prop_simplifyVersionRange1 range version =
- withinRange version range == withinRange version (simplifyVersionRange range)
-
-prop_simplifyVersionRange1' :: VersionRange -> Bool
-prop_simplifyVersionRange1' range =
- range `equivalentVersionRange` (simplifyVersionRange range)
-
--- | 'simplifyVersionRange' produces a canonical form for ranges with
--- equivalent semantics.
---
-prop_simplifyVersionRange2 :: VersionRange -> VersionRange -> Version -> Property
-prop_simplifyVersionRange2 r r' v =
- r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==>
- withinRange v r == withinRange v r'
-
-prop_simplifyVersionRange2' :: VersionRange -> VersionRange -> Property
-prop_simplifyVersionRange2' r r' =
- r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==>
- r `equivalentVersionRange` r'
-
---FIXME: see equivalentVersionRange for details
-prop_simplifyVersionRange2'' :: VersionRange -> VersionRange -> Property
-prop_simplifyVersionRange2'' r r' =
- r /= r' && r `equivalentVersionRange` r' ==>
- simplifyVersionRange r == simplifyVersionRange r'
- || isNoVersion r
- || isNoVersion r'
-
-- | Check that our VersionIntervals' arbitrary instance generates intervals
-- that satisfies the invariant.
--
prop_gen_intervals1 :: VersionIntervals -> Property
-prop_gen_intervals1 i
- = label ("length i ≈ 2 ^ " ++ show metric ++ " - 1")
- $ xs === ys
- where
- metric = intLog2 (length xs + 1)
+prop_gen_intervals1 = property . New.invariantVersionIntervals
- xs = versionIntervals i
- ys = versionIntervals (mkVersionIntervals xs)
-- | Check that constructing our intervals type and converting it to a
-- 'VersionRange' and then into the true intervals type gives us back
-- the exact same sequence of intervals. This tells us that our arbitrary
@@ -374,38 +322,7 @@ prop_gen_intervals1 i
prop_gen_intervals2 :: VersionIntervals -> Property
prop_gen_intervals2 intervals =
toVersionIntervals (fromVersionIntervals intervals) === intervals
-
--- | Check that 'VersionIntervals' models 'VersionRange' via
--- 'toVersionIntervals'.
--
-prop_to_intervals :: VersionRange -> Version -> Bool
-prop_to_intervals range version =
- withinRange version range == withinIntervals version intervals
- where
- intervals = toVersionIntervals range
-
--- | Check that semantic equality on 'VersionRange's is the same as converting
--- to 'VersionIntervals' and doing syntactic equality.
---
-prop_to_intervals_canonical :: VersionRange -> VersionRange -> Property
-prop_to_intervals_canonical r r' =
- r /= r' && r `equivalentVersionRange` r' ==>
- toVersionIntervals r == toVersionIntervals r'
-
-prop_to_intervals_canonical' :: VersionRange -> VersionRange -> Property
-prop_to_intervals_canonical' r r' =
- r /= r' && toVersionIntervals r == toVersionIntervals r' ==>
- r `equivalentVersionRange` r'
-
--- | Check that 'VersionIntervals' models 'VersionRange' via
--- 'fromVersionIntervals'.
---
-prop_from_intervals :: VersionIntervals -> Version -> Bool
-prop_from_intervals intervals version =
- withinRange version range == withinIntervals version intervals
- where
- range = fromVersionIntervals intervals
-
-- | @'toVersionIntervals' . 'fromVersionIntervals'@ is an exact identity on
-- 'VersionIntervals'.
--
@@ -413,167 +330,13 @@ prop_to_from_intervals :: VersionIntervals -> Bool
prop_to_from_intervals intervals =
toVersionIntervals (fromVersionIntervals intervals) == intervals
--- | @'fromVersionIntervals' . 'toVersionIntervals'@ is a semantic identity on
--- 'VersionRange', though not necessarily a syntactic identity.
---
-prop_from_to_intervals :: VersionRange -> Bool
-prop_from_to_intervals range =
- range' `equivalentVersionRange` range
- where
- range' = fromVersionIntervals (toVersionIntervals range)
-
--- | Equivalent of 'prop_from_to_intervals'
---
-prop_from_to_intervals' :: VersionRange -> Version -> Bool
-prop_from_to_intervals' range version =
- withinRange version range' == withinRange version range
- where
- range' = fromVersionIntervals (toVersionIntervals range)
-
--- | The semantics of 'unionVersionIntervals' is (||).
---
-prop_unionVersionIntervals :: VersionIntervals -> VersionIntervals
- -> Version -> Bool
-prop_unionVersionIntervals is1 is2 v =
- withinIntervals v (unionVersionIntervals is1 is2)
- == (withinIntervals v is1 || withinIntervals v is2)
-
--- | 'unionVersionIntervals' is idempotent
---
-prop_unionVersionIntervals_idempotent :: VersionIntervals -> Bool
-prop_unionVersionIntervals_idempotent =
- Laws.idempotent_binary unionVersionIntervals
-
--- | 'unionVersionIntervals' is commutative
---
-prop_unionVersionIntervals_commutative :: VersionIntervals
- -> VersionIntervals -> Bool
-prop_unionVersionIntervals_commutative =
- Laws.commutative unionVersionIntervals
-
--- | 'unionVersionIntervals' is associative
---
-prop_unionVersionIntervals_associative :: VersionIntervals
- -> VersionIntervals
- -> VersionIntervals -> Bool
-prop_unionVersionIntervals_associative =
- Laws.associative unionVersionIntervals
-
--- | The semantics of 'intersectVersionIntervals' is (&&).
---
-prop_intersectVersionIntervals :: VersionIntervals -> VersionIntervals
- -> Version -> Bool
-prop_intersectVersionIntervals is1 is2 v =
- withinIntervals v (intersectVersionIntervals is1 is2)
- == (withinIntervals v is1 && withinIntervals v is2)
-
--- | 'intersectVersionIntervals' is idempotent
---
-prop_intersectVersionIntervals_idempotent :: VersionIntervals -> Bool
-prop_intersectVersionIntervals_idempotent =
- Laws.idempotent_binary intersectVersionIntervals
-
--- | 'intersectVersionIntervals' is commutative
---
-prop_intersectVersionIntervals_commutative :: VersionIntervals
- -> VersionIntervals -> Bool
-prop_intersectVersionIntervals_commutative =
- Laws.commutative intersectVersionIntervals
-
--- | 'intersectVersionIntervals' is associative
---
-prop_intersectVersionIntervals_associative :: VersionIntervals
- -> VersionIntervals
- -> VersionIntervals -> Bool
-prop_intersectVersionIntervals_associative =
- Laws.associative intersectVersionIntervals
-
--- | 'unionVersionIntervals' distributes over 'intersectVersionIntervals'
---
-prop_union_intersect_distributive :: Property
-prop_union_intersect_distributive =
- Laws.distributive_left unionVersionIntervals intersectVersionIntervals
- .&. Laws.distributive_right unionVersionIntervals intersectVersionIntervals
-
--- | 'intersectVersionIntervals' distributes over 'unionVersionIntervals'
---
-prop_intersect_union_distributive :: Property
-prop_intersect_union_distributive =
- Laws.distributive_left intersectVersionIntervals unionVersionIntervals
- .&. Laws.distributive_right intersectVersionIntervals unionVersionIntervals
-
--- | The semantics of 'invertVersionIntervals' is 'not'.
---
-prop_invertVersionIntervals :: VersionIntervals
- -> Version -> Bool
-prop_invertVersionIntervals vi v =
- withinIntervals v (invertVersionIntervals vi)
- == not (withinIntervals v vi)
-
--- | Double application of 'invertVersionIntervals' is the identity function
-prop_invertVersionIntervalsTwice :: VersionIntervals -> Bool
-prop_invertVersionIntervalsTwice vi =
- invertVersionIntervals (invertVersionIntervals vi) == vi
-
-
-
--------------------------------
-- equivalentVersionRange helper
-prop_equivalentVersionRange :: VersionRange -> VersionRange
- -> Version -> Property
+prop_equivalentVersionRange
+ :: VersionRange -> VersionRange -> Version -> Property
prop_equivalentVersionRange range range' version =
- equivalentVersionRange range range' && range /= range' ==>
- withinRange version range == withinRange version range'
-
---FIXME: this is wrong. consider version ranges "<=1" and "<1.0"
--- this algorithm cannot distinguish them because there is no version
--- that is included by one that is excluded by the other.
--- Alternatively we must reconsider the semantics of '<' and '<='
--- in version ranges / version intervals. Perhaps the canonical
--- representation should use just < v and interpret "<= v" as "< v.0".
-equivalentVersionRange :: VersionRange -> VersionRange -> Bool
-equivalentVersionRange vr1 vr2 =
- let allVersionsUsed = nub (sort (versionsUsed vr1 ++ versionsUsed vr2))
- minPoint = mkVersion [0]
- maxPoint | null allVersionsUsed = minPoint
- | otherwise = alterVersion (++[1]) (maximum allVersionsUsed)
- probeVersions = minPoint : maxPoint
- : intermediateVersions allVersionsUsed
-
- in all (\v -> withinRange v vr1 == withinRange v vr2) probeVersions
-
- where
- versionsUsed = foldVersionRange [] (\x->[x]) (\x->[x]) (\x->[x]) (++) (++)
- intermediateVersions (v1:v2:vs) = v1 : intermediateVersion v1 v2
- : intermediateVersions (v2:vs)
- intermediateVersions vs = vs
-
-intermediateVersion :: Version -> Version -> Version
-intermediateVersion v1 v2 | v1 >= v2 = error "intermediateVersion: v1 >= v2"
-intermediateVersion v1 v2 =
- mkVersion (intermediateList (versionNumbers v1) (versionNumbers v2))
- where
- intermediateList :: [Int] -> [Int] -> [Int]
- intermediateList [] (_:_) = [0]
- intermediateList (x:xs) (y:ys)
- | x < y = x : xs ++ [0]
- | otherwise = x : intermediateList xs ys
-
-prop_intermediateVersion :: Version -> Version -> Property
-prop_intermediateVersion v1 v2 =
- (v1 /= v2) && not (adjacentVersions v1 v2) ==>
- if v1 < v2
- then let v = intermediateVersion v1 v2
- in (v1 < v && v < v2)
- else let v = intermediateVersion v2 v1
- in v1 > v && v > v2
-
-adjacentVersions :: Version -> Version -> Bool
-adjacentVersions ver1 ver2 = v1 ++ [0] == v2 || v2 ++ [0] == v1
- where
- v1 = versionNumbers ver1
- v2 = versionNumbers ver2
+ withinRange version range === withinRange version range'
--------------------------------
-- Parsing and pretty printing
diff --git a/cabal-benchmarks/bench/CabalBenchmarks.hs b/cabal-benchmarks/bench/CabalBenchmarks.hs
index f63a475881..65d698db0f 100644
--- a/cabal-benchmarks/bench/CabalBenchmarks.hs
+++ b/cabal-benchmarks/bench/CabalBenchmarks.hs
@@ -1,14 +1,115 @@
+{-# OPTIONS -Wno-deprecations #-}
module Main where
-import Criterion.Main (bench, defaultMain, env, whnf)
+import Criterion.Main (bench, bgroup, defaultMain, env, nf, whnf)
import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe)
+import Distribution.Parsec (eitherParsec)
+import Distribution.Version
import qualified Data.ByteString as BS
+import qualified Distribution.Types.VersionInterval.Legacy as Old
+import qualified Distribution.Types.VersionInterval as New
+
+-------------------------------------------------------------------------------
+-- Main
+-------------------------------------------------------------------------------
+
main :: IO ()
main = defaultMain
[ env (BS.readFile "Cabal/Cabal.cabal") $ \bs ->
bench "Cabal" $ whnf parseGenericPackageDescriptionMaybe bs
, env (BS.readFile "cabal-benchmarks/cabal-benchmarks.cabal") $ \bs ->
bench "cabal-benchmarks" $ whnf parseGenericPackageDescriptionMaybe bs
+
+ , bgroup "normaliseVersionRange" $
+ let suite name f = bgroup name
+ [ env bigVersionRange1 $ \vr -> bench "dnf1" $ nf f vr
+ , env bigVersionRange2 $ \vr -> bench "dnf2" $ nf f vr
+ , env bigVersionRange3 $ \vr -> bench "cnf1" $ nf f vr
+ , env bigVersionRange4 $ \vr -> bench "cnf2" $ nf f vr
+ , env bigVersionRange5 $ \vr -> bench "mix1" $ nf f vr
+ , env bigVersionRange6 $ \vr -> bench "mix2" $ nf f vr
+ , env bigVersionRange7 $ \vr -> bench "pat1" $ nf f vr
+ , env bigVersionRange8 $ \vr -> bench "pat2" $ nf f vr
+ , env bigVersionRange9 $ \vr -> bench "pat3" $ nf f vr
+ , env bigVersionRangeA $ \vr -> bench "pat4" $ nf f vr
+ ]
+ in [ suite "def" normaliseVersionRange
+ , suite "old" oldNormaliseVersionRange
+ , suite "new" newNormaliseVersionRange
+ ]
]
+
+-------------------------------------------------------------------------------
+-- VersionRanges normalisation
+-------------------------------------------------------------------------------
+
+oldNormaliseVersionRange :: VersionRange -> VersionRange
+oldNormaliseVersionRange = Old.fromVersionIntervals . Old.toVersionIntervals
+
+newNormaliseVersionRange :: VersionRange -> VersionRange
+newNormaliseVersionRange = New.normaliseVersionRange2
+
+bigVersionRange1 :: IO VersionRange
+bigVersionRange1 = either fail return $ eitherParsec
+ "(>=1.2.0 && <1.3) || (>=1.3.0 && <1.4) || (>=1.4.0.0 && <1.5) || (>=1.5.0.0 && <1.6) || (>=1.7.0.0 && <1.8)"
+
+bigVersionRange2 :: IO VersionRange
+bigVersionRange2 = either fail return $ eitherParsec
+ "(>=1.2.0 && <1.3) || (>=1.4.0.0 && <1.5) || (>=1.3.0 && <1.4) || (>=1.5.0.0 && <1.6) || (>=1.7.0.0 && <1.8)"
+
+bigVersionRange3 :: IO VersionRange
+bigVersionRange3 = either fail return $ eitherParsec
+ ">=1.2.0 && (<1.3 || >=1.3.0) && (<1.4 || >=1.4.0.0) && (<1.5 || >=1.5.0.0) && (<1.6 || >=1.7.0.0) && <1.8"
+
+bigVersionRange4 :: IO VersionRange
+bigVersionRange4 = either fail return $ eitherParsec
+ ">=1.2.0 && <1.8 && (<1.4 || >=1.4.0.0) && (<1.3 || >=1.3.0) && (<1.5 || >=1.5.0.0) || (<1.6 && >=1.7.0.0)"
+
+bigVersionRange5 :: IO VersionRange
+bigVersionRange5 = either fail return $ eitherParsec
+ ">=1.2.0 && (<1.3 || >=1.3.0) && (<1.4 || (>=1.4.0.0 && <1.5) || >=1.5.0.0) && (<1.6 || (>=1.7.0.0 && (<1.8 || >=1.9) && <1.10) || >=1.11) && <1.12"
+
+bigVersionRange6 :: IO VersionRange
+bigVersionRange6 = fmap New.normaliseVersionRange2 bigVersionRange5
+
+bigVersionRange7 :: IO VersionRange
+bigVersionRange7 = return $
+ i2 $ i2 $ u (b 0 1) (b 0 1)
+ where
+ i2 x = i x x
+ i = intersectVersionRanges
+ u = unionVersionRanges
+ b x y = intersectVersionRanges (laterVersion (v x)) (earlierVersion (v y))
+ v x = mkVersion [x]
+
+bigVersionRange8 :: IO VersionRange
+bigVersionRange8 = return $
+ i2 $ i2 $ i2 $ u (b 0 1) (b 0 1)
+ where
+ i2 x = i x x
+ i = intersectVersionRanges
+ u = unionVersionRanges
+ b x y = intersectVersionRanges (laterVersion (v x)) (earlierVersion (v y))
+ v x = mkVersion [x]
+
+bigVersionRange9 :: IO VersionRange
+bigVersionRange9 = return $
+ i2 $ i2 $ i2 $ i2 $ u (b 0 1) (b 0 1)
+ where
+ i2 x = i x x
+ i = intersectVersionRanges
+ u = unionVersionRanges
+ b x y = intersectVersionRanges (laterVersion (v x)) (earlierVersion (v y))
+ v x = mkVersion [x]
+
+bigVersionRangeA :: IO VersionRange
+bigVersionRangeA = return $
+ i2 $ i2 $ i2 $ i2 $ i2 $ u (b 0 1) (b 0 1)
+ where
+ i2 x = i x x
+ i = intersectVersionRanges
+ u = unionVersionRanges
+ b x y = intersectVersionRanges (laterVersion (v x)) (earlierVersion (v y))
+ v x = mkVersion [x]
diff --git a/cabal-benchmarks/cabal-benchmarks.cabal b/cabal-benchmarks/cabal-benchmarks.cabal
index cc1df4789e..b06e97271a 100644
--- a/cabal-benchmarks/cabal-benchmarks.cabal
+++ b/cabal-benchmarks/cabal-benchmarks.cabal
@@ -19,7 +19,7 @@ extra-source-files: README.md
source-repository head
type: git
location: https://github.com/haskell/cabal/
- subdir: solver-benchmarks
+ subdir: cabal-benchmarks
test-suite cabal-benchmarks
default-language: Haskell2010
diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs
index e3312c0263..14025d74d8 100644
--- a/cabal-install/src/Distribution/Client/Dependency.hs
+++ b/cabal-install/src/Distribution/Client/Dependency.hs
@@ -513,18 +513,10 @@ relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd =
-- | Internal helper for 'relaxPackageDeps'
removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange
-removeBound RelaxLower RelaxDepModNone = removeLowerBound
-removeBound RelaxUpper RelaxDepModNone = removeUpperBound
-removeBound relKind RelaxDepModCaret = hyloVersionRange embed projectVersionRange
- where
- embed (MajorBoundVersionF v) = caretTransformation v (majorUpperBound v)
- embed vr = embedVersionRange vr
-
- -- This function is the interesting part as it defines the meaning
- -- of 'RelaxDepModCaret', i.e. to transform only @^>=@ constraints;
- caretTransformation l u = case relKind of
- RelaxUpper -> orLaterVersion l -- rewrite @^>= x.y.z@ into @>= x.y.z@
- RelaxLower -> earlierVersion u -- rewrite @^>= x.y.z@ into @< x.(y+1)@
+removeBound RelaxLower RelaxDepModNone = removeLowerBound
+removeBound RelaxUpper RelaxDepModNone = removeUpperBound
+removeBound RelaxLower RelaxDepModCaret = transformCaretLower
+removeBound RelaxUpper RelaxDepModCaret = transformCaretUpper
-- | Supply defaults for packages without explicit Setup dependencies
--
diff --git a/cabal-install/src/Distribution/Client/GenBounds.hs b/cabal-install/src/Distribution/Client/GenBounds.hs
index eccfd021f8..5fe5ffd8ba 100644
--- a/cabal-install/src/Distribution/Client/GenBounds.hs
+++ b/cabal-install/src/Distribution/Client/GenBounds.hs
@@ -17,7 +17,6 @@ module Distribution.Client.GenBounds (
import Prelude ()
import Distribution.Client.Compat.Prelude
-import Distribution.Utils.Generic (safeLast)
import Distribution.Client.Init
( incVersion )
@@ -45,19 +44,12 @@ import Distribution.Simple.Utils
import Distribution.System
( Platform )
import Distribution.Version
- ( Version, alterVersion
+ ( Version, alterVersion, VersionInterval (..)
, LowerBound(..), UpperBound(..), VersionRange, asVersionIntervals
- , orLaterVersion, earlierVersion, intersectVersionRanges )
+ , orLaterVersion, earlierVersion, intersectVersionRanges, hasUpperBound)
import System.Directory
( getCurrentDirectory )
--- | Does this version range have an upper bound?
-hasUpperBound :: VersionRange -> Bool
-hasUpperBound vr =
- case safeLast (asVersionIntervals vr) of
- Nothing -> False
- Just l -> if snd l == NoUpperBound then False else True
-
-- | Given a version, return an API-compatible (according to PVP) version range.
--
-- Example: @0.4.1.2@ produces the version range @>= 0.4.1 && < 0.5@.
@@ -78,15 +70,16 @@ pvpize v = orLaterVersion (vn 3)
showBounds :: Package pkg => Int -> pkg -> String
showBounds padTo p = unwords $
(padAfter padTo $ unPackageName $ packageName p) :
+ -- TODO: use normaliseVersionRange
map showInterval (asVersionIntervals $ pvpize $ packageVersion p)
where
padAfter :: Int -> String -> String
padAfter n str = str ++ replicate (n - length str) ' '
- showInterval :: (LowerBound, UpperBound) -> String
- showInterval (LowerBound _ _, NoUpperBound) =
+ showInterval :: VersionInterval -> String
+ showInterval (VersionInterval (LowerBound _ _) NoUpperBound) =
error "Error: expected upper bound...this should never happen!"
- showInterval (LowerBound l _, UpperBound u _) =
+ showInterval (VersionInterval (LowerBound l _) (UpperBound u _)) =
unwords [">=", prettyShow l, "&& <", prettyShow u]
-- | Entry point for the @gen-bounds@ command.
diff --git a/cabal-install/src/Distribution/Client/Outdated.hs b/cabal-install/src/Distribution/Client/Outdated.hs
index b153c3ab5d..b4a781c183 100644
--- a/cabal-install/src/Distribution/Client/Outdated.hs
+++ b/cabal-install/src/Distribution/Client/Outdated.hs
@@ -43,7 +43,7 @@ import Distribution.Types.Dependency
(Dependency(..))
import Distribution.Verbosity (silent)
import Distribution.Version
- (Version, VersionRange, LowerBound(..), UpperBound(..)
+ (Version, VersionInterval (..), VersionRange, LowerBound(..), UpperBound(..)
,asVersionIntervals, majorBoundVersion)
import Distribution.PackageDescription.Parsec
(readGenericPackageDescription)
@@ -207,7 +207,7 @@ listOutdated deps pkgIndex (ListOutdatedSettings ignorePred minorPred) =
relaxMinor vr =
let vis = asVersionIntervals vr
in maybe vr relax (safeLast vis)
- where relax (LowerBound v0 _, upper) =
+ where relax (VersionInterval (LowerBound v0 _) upper) =
case upper of
NoUpperBound -> vr
UpperBound _v1 _ -> majorBoundVersion v0
--
GitLab