cabal-fmt-0.1.9: src-interval/VersionInterval.hs
{-# LANGUAGE BangPatterns #-}
-- |
--
-- Author: Oleg Grenrus <oleg.grenrus@iki.fi>
-- 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,
unVersionIntervals,
-- * 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.Applicative (liftA2)
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)
-- | Inspect the list of version intervals.
--
unVersionIntervals :: VersionIntervals -> [VersionInterval]
unVersionIntervals (VersionIntervals is) = is
-- | 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@.
--
data LB = LB !Version
deriving (Eq, Ord, Show)
-- | Upper bound.
--
-- All upper bounds are exclusive, i.e. @<v@. @<=x.y.z@ is converted to @<x.y.z.0@.
--
--
data UB
= UB !Version -- ^ upper bound
| NoUB -- ^ no upper bound (i.e. infinite)
deriving (Eq, Ord, Show)
-- | Bound variant.
data Bound
= Incl -- ^ inclusive: @>=@ or @<=@
| Excl -- ^ exclusive: @>@ or @<@
deriving (Eq, Ord, Show)
-- | Middle bound.
data MB
= MB !Version -- ^ major bound.
| NoMB -- ^ no major bound (i.e. infinite)
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 $ liftA2 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
= NoOverlap -- ^ no overlap, next interval's @l@ is greater than @u@
| OverlapM -- ^ overlaps, next interval's @l@ is less than @m@
| OverlapU -- ^ overlaps, next interval's @l@ is less than @u@ (but greater than @m@)
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 (tail 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 u = earlierVersion u
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 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