VersionInterval.hs

{-# LANGUAGE BangPatterns #-}

-- | 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 Distribution.Types.VersionInterval
  ( -- * Version intervals
    VersionIntervals
  , unVersionIntervals
  , mkVersionIntervals

    -- * Conversions
  , toVersionIntervals
  , fromVersionIntervals

    -- ** Normalisation
  , normaliseVersionRange2

    -- * Relaxation
  , relaxLastInterval
  , relaxHeadInterval

    -- * Version intervals view
  , asVersionIntervals
  , VersionInterval (..)
  , LowerBound (..)
  , UpperBound (..)
  , Bound (..)

    -- * Invariants
  , invariantVersionIntervals
  ) where

import Control.Applicative (liftA2)
import Control.Exception (assert)
import Distribution.Compat.Prelude hiding (Applicative (..))
import Prelude ()

import Distribution.Types.Version
import Distribution.Types.VersionRange.Internal

-- To test this module, and to run version range normalisation benchmarks:
--
-- cabal run Cabal-tests: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)

-- | Inspect the list of version intervals.
unVersionIntervals :: VersionIntervals -> [VersionInterval]
unVersionIntervals (VersionIntervals is) = is

-- | Directly construct a 'VersionIntervals' from a list of intervals.
mkVersionIntervals :: [VersionInterval] -> Maybe VersionIntervals
mkVersionIntervals intervals
  | invariantVersionIntervals (VersionIntervals intervals) = Just . VersionIntervals $ intervals
  | otherwise = Nothing

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 leaves 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)

-- | Check 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
-------------------------------------------------------------------------------

-- | 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 = unVersionIntervals . toVersionIntervals

-------------------------------------------------------------------------------
-- Helpers
-------------------------------------------------------------------------------

-- | 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)

-------------------------------------------------------------------------------
-- Invariants
-------------------------------------------------------------------------------

-- | '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' (VersionInterval _ u, VersionInterval l' _) = doesNotTouch u l'

    adjacentIntervals :: [(VersionInterval, VersionInterval)]
    adjacentIntervals = case intervals of
      [] -> []
      (_ : tl) -> zip intervals tl

checkInvariant :: VersionIntervals -> VersionIntervals
checkInvariant is = assert (invariantVersionIntervals is) is
{-# INLINE checkInvariant #-}

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

-- Check an interval is non-empty
--
nonEmptyVI :: VersionInterval -> Bool
nonEmptyVI (VersionInterval _ NoUpperBound) = True
nonEmptyVI (VersionInterval (LowerBound l lb) (UpperBound u ub)) =
  (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound)

-------------------------------------------------------------------------------
-- Conversions
-------------------------------------------------------------------------------

-- | Convert a 'VersionRange' to a sequence of version intervals.
toVersionIntervals :: VersionRange -> VersionIntervals
toVersionIntervals = postprocess . stage1

-- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression
-- representing the version intervals.
fromVersionIntervals :: VersionIntervals -> VersionRange
fromVersionIntervals (VersionIntervals []) = noVersion
fromVersionIntervals (VersionIntervals (x : xs)) = foldr1 unionVersionRanges (fmap intervalToVersionRange (x :| xs))

intervalToVersionRange :: VersionInterval -> VersionRange
intervalToVersionRange (VersionInterval (LowerBound v vb) upper') = case upper' of
  NoUpperBound ->
    lowerBound
  UpperBound u ub
    | vb == InclusiveBound
    , ub == InclusiveBound
    , v == u ->
        thisVersion v
  UpperBound u ub -> withLowerBound (makeUpperBound u ub)
  where
    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' [VersionInterval l _] = [VersionInterval l NoUpperBound]
    relaxLastInterval' (i : is) = i : relaxLastInterval' is

relaxHeadInterval :: VersionIntervals -> VersionIntervals
relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs)
  where
    relaxHeadInterval' [] = []
    relaxHeadInterval' (VersionInterval _ u : is) = VersionInterval zeroLowerBound u : is