{-# LANGUAGE BangPatterns #-} -- | -- -- Author: Oleg Grenrus -- SPDX-License-Id: GPL-2.0-or-later -- -- This module implements a view of a 'VersionRange' as a finite -- list of separated version intervals. -- -- In conversion from and to 'VersionRange' it makes some effort to -- preserve the caret operator @^>=x.y@. This constraint a priori -- specifies the same interval as @==x.y.*@, but indicates that newer -- versions could be acceptable (@allow-newer: ^@). module VersionInterval ( -- * Version intervals VersionIntervals, -- * Conversions toVersionIntervals, fromVersionIntervals, ConversionProblem (..), -- ** Normalisation normaliseVersionRange, -- * Version intervals view VersionInterval (..), LB (..), MB (..), UB (..), Bound (..), -- * For testing validVersionInterval, validVersionIntervals, intersectInterval, stage1, stage2, stage3, ) where import Control.Monad (join) import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty (..), cons) import Data.Maybe (catMaybes) import Distribution.Types.Version ( Version, mkVersion, validVersion, version0, versionNumbers, ) import Distribution.Types.VersionRange.Internal ( VersionRange, VersionRangeF (..), cataVersionRange, earlierVersion, intersectVersionRanges, majorBoundVersion, majorUpperBound, noVersion, orLaterVersion, thisVersion, unionVersionRanges, ) singleton :: a -> NonEmpty a singleton x = x :| [] ------------------------------------------------------------------------------- -- Data ------------------------------------------------------------------------------- -- | A complementary representation of a 'VersionRange'. Instead of a boolean -- version predicate it uses an increasing sequence of non-overlapping, -- non-empty intervals. -- -- This version is different than in @Cabal-3.8@ and previous, -- as it tries to preserve @^>=@ version ranges under default and @transformCaretUpper@ semantics. -- Slighly simplifying, 'normalizeVersionRange' shouldn't destroy @^>=@ in version range expressions. newtype VersionIntervals = VersionIntervals [VersionInterval] deriving (Eq, Show) -- | Version interval. -- -- Invariants: -- -- * Interval is non-empty -- * 'MB' is between 'LB' and 'UB'. data VersionInterval = VI !LB !MB !UB deriving (Eq, Show) -- | Lower bound. For intervals it always exist: 'zeroLB' i.e. @>= 0@. -- -- All lower bound intervals are inclusive, i.e. @>=v@. @>x.y.z@ is converted into @>=x.y.z.0@. newtype LB = LB Version deriving (Eq, Ord, Show) -- | Upper bound. -- -- All upper bounds are exclusive, i.e. @=@ or @<=@ Incl | -- | exclusive: @>@ or @<@ Excl deriving (Eq, Ord, Show) -- | Middle bound. data MB = -- | major bound. MB !Version | -- | no major bound (i.e. infinite) NoMB deriving (Eq, Ord, Show) -- | @>=0@ zeroLB :: LB zeroLB = LB version0 -- | Whether the version is @0@. isVersion0 :: Version -> Bool isVersion0 = (==) version0 -- | Versions are not separated type. succVersion :: Version -> Version succVersion v = mkVersion (versionNumbers v ++ [0]) ------------------------------------------------------------------------------- -- Stage1 ------------------------------------------------------------------------------- stage1 :: ([VersionInterval] -> [VersionInterval]) -> VersionRange -> [VersionInterval] stage1 opt = cataVersionRange alg where -- version range leafs transform into singleton intervals alg (ThisVersionF v) = [VI (LB v) (MB (succVersion v)) (UB (succVersion v))] alg (LaterVersionF v) = [VI (LB (succVersion v)) NoMB NoUB] alg (OrLaterVersionF v) = [VI (LB v) NoMB NoUB] alg (EarlierVersionF v) | isVersion0 v = [] | otherwise = [VI zeroLB (MB v) (UB v)] alg (OrEarlierVersionF v) = [VI zeroLB (MB (succVersion v)) (UB (succVersion v))] -- \^>= version-range's upper bound should be MajorBound alg (MajorBoundVersionF v) = [VI (LB v) (MB (majorUpperBound v)) NoUB] -- 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) = catMaybes $ intersectInterval <$> opt v1 <*> opt v2 ------------------------------------------------------------------------------- -- Stage2 ------------------------------------------------------------------------------- stage2 :: [VersionInterval] -> [VersionInterval] stage2 = sortOn (\(VI l _ _) -> l) ------------------------------------------------------------------------------- -- Postprocess ------------------------------------------------------------------------------- stage2and3 :: [VersionInterval] -> [VersionInterval] stage2and3 = stage3 . stage2 stage3 :: [VersionInterval] -> [VersionInterval] stage3 [] = [] stage3 (VI l m u : rest) = stage3go l m u rest stage3go :: LB -> MB -> UB -> [VersionInterval] -> [VersionInterval] stage3go l m u [] = [VI l m u] stage3go l m u (VI l' m' u' : is) | l == l' = stage3go l' (unionMB m m') (unionUB u u') is | otherwise = case overlap m u l' of NoOverlap -> VI l m u : stage3go l' m' u' is OverlapU -> viCons (VI l m (trimLB u l')) (stage3go l' m' (unionUB u u') is) OverlapM -> stage3go l (unionMB m m') (unionUB u u') is where viCons :: VersionInterval -> [VersionInterval] -> [VersionInterval] viCons i | nonEmptyVI i = (i :) viCons _ = id trimLB :: UB -> LB -> UB trimLB _ (LB l) = UB l ------------------------------------------------------------------------------- -- Intersections ------------------------------------------------------------------------------- intersectInterval :: VersionInterval -> VersionInterval -> Maybe VersionInterval intersectInterval (VI xl xm xu) (VI yl ym yu) | nonEmptyVI xy = Just xy | otherwise = Nothing where l = intersectLB xl yl m = intersectMB xm ym u = intersectUB xu yu -- make middle bound be between l and u m' = rtrimMB (ltrimMB l m) u xy = VI l m' u ltrimMB :: LB -> MB -> MB ltrimMB _ NoMB = NoMB ltrimMB (LB l) (MB m) = case compare l m of LT -> MB m EQ -> MB m GT -> MB l rtrimMB :: MB -> UB -> MB rtrimMB m NoUB = m rtrimMB NoMB (UB u) = MB u rtrimMB (MB m) (UB u) = MB (min m u) intersectLB :: LB -> LB -> LB intersectLB (LB v) (LB u) = LB (max v u) intersectMB :: MB -> MB -> MB intersectMB NoMB b = b intersectMB b NoMB = b intersectMB (MB v) (MB u) = MB (min v u) intersectUB :: UB -> UB -> UB intersectUB NoUB b = b intersectUB b NoUB = b intersectUB (UB v) (UB u) = UB (min v u) intersectMBandUB :: MB -> UB -> UB intersectMBandUB NoMB b = b intersectMBandUB (MB v) NoUB = UB v intersectMBandUB (MB v) (UB u) = UB (min v u) ------------------------------------------------------------------------------- -- Unions ------------------------------------------------------------------------------- unionMB :: MB -> MB -> MB unionMB NoMB _ = NoMB unionMB _ NoMB = NoMB unionMB (MB v) (MB u) = MB (max v u) unionUB :: UB -> UB -> UB unionUB NoUB _ = NoUB unionUB _ NoUB = NoUB unionUB (UB v) (UB u) = UB (max v u) ------------------------------------------------------------------------------- -- Helpers ------------------------------------------------------------------------------- -- | Overlaps. data Overlap = -- | no overlap, next interval's @l@ is greater than @u@ NoOverlap | -- | overlaps, next interval's @l@ is less than @m@ OverlapM | -- | overlaps, next interval's @l@ is less than @u@ (but greater than @m@) OverlapU deriving (Eq, Show) overlap :: MB -> UB -> LB -> Overlap overlap _ (UB u) (LB l) | u < l = NoOverlap overlap (MB m) _ (LB l) | m < l = OverlapU overlap _ _ _ = OverlapM ------------------------------------------------------------------------------- -- Invariants ------------------------------------------------------------------------------- -- | 'VersionIntervals' invariant: -- -- * all intervals are valid (lower bound is less then upper bound, middle bound is in between) -- * intervals doesn't touch each other (distinct) validVersionIntervals :: VersionIntervals -> Bool validVersionIntervals (VersionIntervals intervals) = all validVersionInterval intervals && all doesNotTouch' (pairs intervals) where doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool doesNotTouch' (VI l m u, VI l' _ _) = l < l' && case overlap m u l' of NoOverlap -> True OverlapM -> False OverlapU -> case u of NoUB -> True UB uv -> case l' of LB lv -> uv == lv pairs :: [a] -> [(a, a)] pairs xs = zip xs (drop 1 xs) validLB :: LB -> Bool validLB (LB v) = validVersion v validUB :: UB -> Bool validUB NoUB = True validUB (UB v) = validVersion v validMB :: MB -> Bool validMB NoMB = True validMB (MB v) = validVersion v validVersionInterval :: VersionInterval -> Bool validVersionInterval i@(VI l m u) = validLB l && validMB m && validUB u && nonEmptyVI i && lbLessThanMB l m && mbLessThanUB m u mbLessThanUB :: MB -> UB -> Bool mbLessThanUB (MB m) (UB u) = m <= u mbLessThanUB NoMB (UB _) = False mbLessThanUB _ NoUB = True lbLessThanMB :: LB -> MB -> Bool lbLessThanMB _ NoMB = True lbLessThanMB (LB l) (MB m) = l <= m -- Check an interval is non-empty -- nonEmptyVI :: VersionInterval -> Bool nonEmptyVI (VI (LB _) _ NoUB) = True nonEmptyVI (VI (LB l) _ (UB u)) = l < u ------------------------------------------------------------------------------- -- Conversions ------------------------------------------------------------------------------- -- | Convert a 'VersionRange' to a sequence of version intervals. toVersionIntervals :: VersionRange -> VersionIntervals toVersionIntervals = VersionIntervals . stage2and3 . stage1 stage2and3 data ConversionProblem = IntervalsEmpty | OtherConversionProblem deriving (Eq, Show) -- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression -- representing the version intervals. fromVersionIntervals :: VersionIntervals -> Either ConversionProblem VersionRange fromVersionIntervals (VersionIntervals []) = Right noVersion fromVersionIntervals (VersionIntervals (x : xs)) = case join <$> traverse intervalToVersionRange (preprocess x xs) of Just vrs -> Right (foldr1 unionVersionRanges vrs) Nothing -> Left $ if all seemsEmpty (x : xs) then IntervalsEmpty else OtherConversionProblem where -- we can remove upper bounds, if they touch next interval, and the next interval doesn't have upper bound preprocess :: VersionInterval -> [VersionInterval] -> NonEmpty VersionInterval preprocess i [] = i :| [] preprocess i@(VI l m u) (j : js) = case u' of NoUB | touchesUB u l' -> cons (VI l m NoUB) js' _ -> cons i js' where js'@(VI l' _ u' :| _) = preprocess j js seemsEmpty :: VersionInterval -> Bool seemsEmpty (VI l m u) = not (nonEmptyVI (VI l NoMB (intersectMBandUB m u))) touchesUB :: UB -> LB -> Bool touchesUB NoUB _ = True touchesUB (UB u) (LB l) = u >= l lbToVR :: LB -> VersionRange lbToVR (LB l) = orLaterVersion l ubToVR :: UB -> VersionRange -> VersionRange ubToVR NoUB vr = vr ubToVR (UB u) vr = intersectVersionRanges vr (earlierVersion u) mbEqUB :: MB -> UB -> Bool mbEqUB NoMB NoUB = True mbEqUB NoMB (UB _) = False mbEqUB (MB m) (UB u) = m == u mbEqUB (MB _) NoUB = False -- return the unions of version ranges. intervalToVersionRange :: VersionInterval -> Maybe (NonEmpty VersionRange) intervalToVersionRange (VI l m u) | mbEqUB m u = Just (singleton (intervalToVersionRange1 l u)) intervalToVersionRange (VI l m u) = fmap (fmap (ubToVR u)) (intervalToVersionRange2 l m) intervalToVersionRange1 :: LB -> UB -> VersionRange intervalToVersionRange1 (LB v) upper' = case upper' of NoUB -> lowerBound UB u | succVersion v == u -> thisVersion v UB u -> withLowerBound (makeUpperBound u) where lowerBound :: VersionRange lowerBound = lbToVR (LB v) withLowerBound :: VersionRange -> VersionRange withLowerBound vr | isVersion0 v = vr | otherwise = intersectVersionRanges lowerBound vr makeUpperBound :: Version -> VersionRange makeUpperBound = earlierVersion intervalToVersionRange2 :: LB -> MB -> Maybe (NonEmpty VersionRange) intervalToVersionRange2 (LB l) NoMB = Just (singleton lowerBound) where lowerBound :: VersionRange lowerBound = lbToVR (LB l) intervalToVersionRange2 (LB l) (MB m) | supermajor l == supermajor m = go (l :|) (majorUpperBound l) | [a, b] <- versionNumbers m, let m' = mkVersion [a, b - 1], b >= 1, m' > l = Just $ ubToVR (UB m') (lbToVR (LB l)) :| [majorBoundVersion (mkVersion [a, b - 1])] | otherwise = Nothing where go :: ([Version] -> NonEmpty Version) -> Version -> Maybe (NonEmpty VersionRange) go !acc v = case compare v m of LT -> go (snoc acc v) (majorUpperBound v) EQ -> Just (fmap majorBoundVersion (acc [])) GT -> Nothing snoc :: ([a] -> c) -> a -> [a] -> c snoc xs x = xs . (x :) supermajor :: Version -> Int supermajor v = case versionNumbers v of [] -> -1 s : _ -> s ------------------------------------------------------------------------------- -- Normalisation ------------------------------------------------------------------------------- -- | Convert 'VersionRange' to 'VersionIntervals' and back. normaliseVersionRange :: VersionRange -> Either ConversionProblem VersionRange normaliseVersionRange = fromVersionIntervals . toVersionIntervals