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,

    -- * 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. @<v@. @<=x.y.z@ is converted to @<x.y.z.0@.
data UB
  = -- | upper bound
    UB !Version
  | -- | no upper bound (i.e. infinite)
    NoUB
  deriving (Eq, Ord, Show)

-- | Bound variant.
data Bound
  = -- | inclusive: @>=@ 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