{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE DeriveDataTypeable #-}

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

    -- * 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
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 (VersionIntervals -> VersionIntervals -> Bool
(VersionIntervals -> VersionIntervals -> Bool)
-> (VersionIntervals -> VersionIntervals -> Bool)
-> Eq VersionIntervals
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VersionIntervals -> VersionIntervals -> Bool
== :: VersionIntervals -> VersionIntervals -> Bool
$c/= :: VersionIntervals -> VersionIntervals -> Bool
/= :: VersionIntervals -> VersionIntervals -> Bool
Eq, Int -> VersionIntervals -> ShowS
[VersionIntervals] -> ShowS
VersionIntervals -> String
(Int -> VersionIntervals -> ShowS)
-> (VersionIntervals -> String)
-> ([VersionIntervals] -> ShowS)
-> Show VersionIntervals
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VersionIntervals -> ShowS
showsPrec :: Int -> VersionIntervals -> ShowS
$cshow :: VersionIntervals -> String
show :: VersionIntervals -> String
$cshowList :: [VersionIntervals] -> ShowS
showList :: [VersionIntervals] -> ShowS
Show, Typeable)

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

data VersionInterval = VersionInterval !LowerBound !UpperBound    deriving (VersionInterval -> VersionInterval -> Bool
(VersionInterval -> VersionInterval -> Bool)
-> (VersionInterval -> VersionInterval -> Bool)
-> Eq VersionInterval
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VersionInterval -> VersionInterval -> Bool
== :: VersionInterval -> VersionInterval -> Bool
$c/= :: VersionInterval -> VersionInterval -> Bool
/= :: VersionInterval -> VersionInterval -> Bool
Eq, Int -> VersionInterval -> ShowS
[VersionInterval] -> ShowS
VersionInterval -> String
(Int -> VersionInterval -> ShowS)
-> (VersionInterval -> String)
-> ([VersionInterval] -> ShowS)
-> Show VersionInterval
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VersionInterval -> ShowS
showsPrec :: Int -> VersionInterval -> ShowS
$cshow :: VersionInterval -> String
show :: VersionInterval -> String
$cshowList :: [VersionInterval] -> ShowS
showList :: [VersionInterval] -> ShowS
Show)
data LowerBound      = LowerBound !Version !Bound                 deriving (LowerBound -> LowerBound -> Bool
(LowerBound -> LowerBound -> Bool)
-> (LowerBound -> LowerBound -> Bool) -> Eq LowerBound
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LowerBound -> LowerBound -> Bool
== :: LowerBound -> LowerBound -> Bool
$c/= :: LowerBound -> LowerBound -> Bool
/= :: LowerBound -> LowerBound -> Bool
Eq, Int -> LowerBound -> ShowS
[LowerBound] -> ShowS
LowerBound -> String
(Int -> LowerBound -> ShowS)
-> (LowerBound -> String)
-> ([LowerBound] -> ShowS)
-> Show LowerBound
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LowerBound -> ShowS
showsPrec :: Int -> LowerBound -> ShowS
$cshow :: LowerBound -> String
show :: LowerBound -> String
$cshowList :: [LowerBound] -> ShowS
showList :: [LowerBound] -> ShowS
Show)
data UpperBound      = NoUpperBound | UpperBound !Version !Bound  deriving (UpperBound -> UpperBound -> Bool
(UpperBound -> UpperBound -> Bool)
-> (UpperBound -> UpperBound -> Bool) -> Eq UpperBound
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UpperBound -> UpperBound -> Bool
== :: UpperBound -> UpperBound -> Bool
$c/= :: UpperBound -> UpperBound -> Bool
/= :: UpperBound -> UpperBound -> Bool
Eq, Int -> UpperBound -> ShowS
[UpperBound] -> ShowS
UpperBound -> String
(Int -> UpperBound -> ShowS)
-> (UpperBound -> String)
-> ([UpperBound] -> ShowS)
-> Show UpperBound
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UpperBound -> ShowS
showsPrec :: Int -> UpperBound -> ShowS
$cshow :: UpperBound -> String
show :: UpperBound -> String
$cshowList :: [UpperBound] -> ShowS
showList :: [UpperBound] -> ShowS
Show)
data Bound           = ExclusiveBound | InclusiveBound            deriving (Bound -> Bound -> Bool
(Bound -> Bound -> Bool) -> (Bound -> Bound -> Bool) -> Eq Bound
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Bound -> Bound -> Bool
== :: Bound -> Bound -> Bool
$c/= :: Bound -> Bound -> Bool
/= :: Bound -> Bound -> Bool
Eq, Int -> Bound -> ShowS
[Bound] -> ShowS
Bound -> String
(Int -> Bound -> ShowS)
-> (Bound -> String) -> ([Bound] -> ShowS) -> Show Bound
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Bound -> ShowS
showsPrec :: Int -> Bound -> ShowS
$cshow :: Bound -> String
show :: Bound -> String
$cshowList :: [Bound] -> ShowS
showList :: [Bound] -> ShowS
Show)

zeroLowerBound :: LowerBound
zeroLowerBound :: LowerBound
zeroLowerBound = Version -> Bound -> LowerBound
LowerBound Version
version0 Bound
InclusiveBound

isVersion0 :: Version -> Bool
isVersion0 :: Version -> Bool
isVersion0 = Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
(==) Version
version0

-------------------------------------------------------------------------------
-- Stage1
-------------------------------------------------------------------------------

stage1 :: VersionRange -> [VersionInterval]
stage1 :: VersionRange -> [VersionInterval]
stage1 = (VersionRangeF [VersionInterval] -> [VersionInterval])
-> VersionRange -> [VersionInterval]
forall a. (VersionRangeF a -> a) -> VersionRange -> a
cataVersionRange VersionRangeF [VersionInterval] -> [VersionInterval]
alg where
    -- version range leafs transform into singleton intervals
    alg :: VersionRangeF [VersionInterval] -> [VersionInterval]
alg (ThisVersionF Version
v)                = [LowerBound -> UpperBound -> VersionInterval
VersionInterval (Version -> Bound -> LowerBound
LowerBound Version
v Bound
InclusiveBound) (Version -> Bound -> UpperBound
UpperBound Version
v Bound
InclusiveBound)]
    alg (LaterVersionF Version
v)               = [LowerBound -> UpperBound -> VersionInterval
VersionInterval (Version -> Bound -> LowerBound
LowerBound Version
v Bound
ExclusiveBound) UpperBound
NoUpperBound]
    alg (OrLaterVersionF Version
v)             = [LowerBound -> UpperBound -> VersionInterval
VersionInterval (Version -> Bound -> LowerBound
LowerBound Version
v Bound
InclusiveBound) UpperBound
NoUpperBound]
    alg (EarlierVersionF Version
v)
        | Version -> Bool
isVersion0 Version
v                  = []
        | Bool
otherwise                     = [LowerBound -> UpperBound -> VersionInterval
VersionInterval LowerBound
zeroLowerBound                (Version -> Bound -> UpperBound
UpperBound Version
v Bound
ExclusiveBound)]
    alg (OrEarlierVersionF Version
v)           = [LowerBound -> UpperBound -> VersionInterval
VersionInterval LowerBound
zeroLowerBound                (Version -> Bound -> UpperBound
UpperBound Version
v Bound
InclusiveBound)]

    -- ^>= version-range's upper bound should be MajorBound
    alg (MajorBoundVersionF Version
v)          = [LowerBound -> UpperBound -> VersionInterval
VersionInterval (Version -> Bound -> LowerBound
LowerBound Version
v Bound
InclusiveBound) (Version -> Bound -> UpperBound
UpperBound (Version -> Version
majorUpperBound Version
v) Bound
ExclusiveBound)]

    -- union: just merge the version intervals
    alg (UnionVersionRangesF [VersionInterval]
v1 [VersionInterval]
v2)     = [VersionInterval]
v1 [VersionInterval] -> [VersionInterval] -> [VersionInterval]
forall a. [a] -> [a] -> [a]
++ [VersionInterval]
v2

    -- intersection: pairwise intersect. Strip empty intervals. Sort to restore the invariant.
    alg (IntersectVersionRangesF [VersionInterval]
v1 [VersionInterval]
v2) = (VersionInterval -> Maybe VersionInterval)
-> [VersionInterval] -> [VersionInterval]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VersionInterval -> Maybe VersionInterval
nonEmptyInterval ([VersionInterval] -> [VersionInterval])
-> [VersionInterval] -> [VersionInterval]
forall a b. (a -> b) -> a -> b
$ (VersionInterval -> VersionInterval -> VersionInterval)
-> [VersionInterval] -> [VersionInterval] -> [VersionInterval]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 VersionInterval -> VersionInterval -> VersionInterval
intersectInterval ([VersionInterval] -> [VersionInterval]
stage2and3 [VersionInterval]
v1) ([VersionInterval] -> [VersionInterval]
stage2and3 [VersionInterval]
v2)

-- | Check that interval is non-empty
nonEmptyInterval :: VersionInterval -> Maybe VersionInterval
nonEmptyInterval :: VersionInterval -> Maybe VersionInterval
nonEmptyInterval VersionInterval
i | VersionInterval -> Bool
nonEmptyVI VersionInterval
i = VersionInterval -> Maybe VersionInterval
forall a. a -> Maybe a
Just VersionInterval
i
nonEmptyInterval VersionInterval
_                = Maybe VersionInterval
forall a. Maybe a
Nothing

-------------------------------------------------------------------------------
-- Stage2
-------------------------------------------------------------------------------

stage2 :: [VersionInterval] -> [VersionInterval]
stage2 :: [VersionInterval] -> [VersionInterval]
stage2 = (VersionInterval -> VersionInterval -> Ordering)
-> [VersionInterval] -> [VersionInterval]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy VersionInterval -> VersionInterval -> Ordering
lowerboundCmp

lowerboundCmp :: VersionInterval -> VersionInterval -> Ordering
lowerboundCmp :: VersionInterval -> VersionInterval -> Ordering
lowerboundCmp (VersionInterval (LowerBound Version
v Bound
vb) UpperBound
_) (VersionInterval (LowerBound Version
u Bound
ub) UpperBound
_) =
    Version -> Version -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Version
v Version
u Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` Bound -> Bound -> Ordering
compareBound Bound
vb Bound
ub
  where
    compareBound :: Bound -> Bound -> Ordering
    compareBound :: Bound -> Bound -> Ordering
compareBound Bound
InclusiveBound Bound
InclusiveBound = Ordering
EQ
    compareBound Bound
InclusiveBound Bound
ExclusiveBound = Ordering
LT
    compareBound Bound
ExclusiveBound Bound
InclusiveBound = Ordering
GT
    compareBound Bound
ExclusiveBound Bound
ExclusiveBound = Ordering
EQ

-------------------------------------------------------------------------------
-- Postprocess
-------------------------------------------------------------------------------

-- | Post-processing takes a list of ordered version intervals,
-- but possibly overlapping, and creates 'VersionIntervals'.
--
postprocess :: [VersionInterval] -> VersionIntervals
postprocess :: [VersionInterval] -> VersionIntervals
postprocess = VersionIntervals -> VersionIntervals
checkInvariant (VersionIntervals -> VersionIntervals)
-> ([VersionInterval] -> VersionIntervals)
-> [VersionInterval]
-> VersionIntervals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [VersionInterval] -> VersionIntervals
VersionIntervals ([VersionInterval] -> VersionIntervals)
-> ([VersionInterval] -> [VersionInterval])
-> [VersionInterval]
-> VersionIntervals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [VersionInterval] -> [VersionInterval]
stage2and3

stage2and3 :: [VersionInterval] -> [VersionInterval]
stage2and3 :: [VersionInterval] -> [VersionInterval]
stage2and3 = [VersionInterval] -> [VersionInterval]
stage3 ([VersionInterval] -> [VersionInterval])
-> ([VersionInterval] -> [VersionInterval])
-> [VersionInterval]
-> [VersionInterval]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [VersionInterval] -> [VersionInterval]
stage2

stage3 :: [VersionInterval] -> [VersionInterval]
stage3 :: [VersionInterval] -> [VersionInterval]
stage3 []                                     = []
stage3 (VersionInterval LowerBound
lb UpperBound
ub : [VersionInterval]
rest)         = LowerBound -> UpperBound -> [VersionInterval] -> [VersionInterval]
stage3go LowerBound
lb UpperBound
ub [VersionInterval]
rest

stage3go :: LowerBound -> UpperBound -> [VersionInterval] -> [VersionInterval]
stage3go :: LowerBound -> UpperBound -> [VersionInterval] -> [VersionInterval]
stage3go !LowerBound
lb UpperBound
NoUpperBound [VersionInterval]
_                                 = [LowerBound -> UpperBound -> VersionInterval
VersionInterval LowerBound
lb UpperBound
NoUpperBound]
stage3go !LowerBound
lb !UpperBound
ub          []                                = [LowerBound -> UpperBound -> VersionInterval
VersionInterval LowerBound
lb UpperBound
ub]
stage3go !LowerBound
lb !UpperBound
ub          (VersionInterval LowerBound
lb' UpperBound
ub' : [VersionInterval]
rest')
    | UpperBound -> LowerBound -> Bool
doesNotTouch UpperBound
ub LowerBound
lb'                                   = LowerBound -> UpperBound -> VersionInterval
VersionInterval LowerBound
lb UpperBound
ub VersionInterval -> [VersionInterval] -> [VersionInterval]
forall a. a -> [a] -> [a]
: LowerBound -> UpperBound -> [VersionInterval] -> [VersionInterval]
stage3go LowerBound
lb' UpperBound
ub' [VersionInterval]
rest'
    | Bool
otherwise                                             = LowerBound -> UpperBound -> [VersionInterval] -> [VersionInterval]
stage3go LowerBound
lb (UpperBound -> UpperBound -> UpperBound
unionUpper UpperBound
ub UpperBound
ub') [VersionInterval]
rest'

-------------------------------------------------------------------------------
-- Intersections
-------------------------------------------------------------------------------

intersectInterval :: VersionInterval -> VersionInterval -> VersionInterval
intersectInterval :: VersionInterval -> VersionInterval -> VersionInterval
intersectInterval (VersionInterval LowerBound
lv UpperBound
uv) (VersionInterval LowerBound
lu UpperBound
uu) =
    LowerBound -> UpperBound -> VersionInterval
VersionInterval (LowerBound -> LowerBound -> LowerBound
intersectLower LowerBound
lv LowerBound
lu) (UpperBound -> UpperBound -> UpperBound
intersectUpper UpperBound
uv UpperBound
uu)

intersectLower :: LowerBound -> LowerBound -> LowerBound
intersectLower :: LowerBound -> LowerBound -> LowerBound
intersectLower (LowerBound Version
v Bound
vb) (LowerBound Version
u Bound
ub) = case Version -> Version -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Version
v Version
u of
    Ordering
EQ -> Version -> Bound -> LowerBound
LowerBound Version
v (Bound -> Bound -> Bound
intersectBound Bound
vb Bound
ub)
    Ordering
LT -> Version -> Bound -> LowerBound
LowerBound Version
u Bound
ub
    Ordering
GT -> Version -> Bound -> LowerBound
LowerBound Version
v Bound
vb

intersectUpper :: UpperBound -> UpperBound -> UpperBound
intersectUpper :: UpperBound -> UpperBound -> UpperBound
intersectUpper UpperBound
NoUpperBound      UpperBound
b                 = UpperBound
b
intersectUpper UpperBound
b                 UpperBound
NoUpperBound      = UpperBound
b
intersectUpper (UpperBound Version
v Bound
vb) (UpperBound Version
u Bound
ub) = case Version -> Version -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Version
v Version
u of
    Ordering
EQ -> Version -> Bound -> UpperBound
UpperBound Version
v (Bound -> Bound -> Bound
intersectBound Bound
vb Bound
ub)
    Ordering
LT -> Version -> Bound -> UpperBound
UpperBound Version
v Bound
vb
    Ordering
GT -> Version -> Bound -> UpperBound
UpperBound Version
u Bound
ub

intersectBound :: Bound -> Bound -> Bound
intersectBound :: Bound -> Bound -> Bound
intersectBound Bound
InclusiveBound Bound
InclusiveBound = Bound
InclusiveBound
intersectBound Bound
_              Bound
_              = Bound
ExclusiveBound

-------------------------------------------------------------------------------
-- Unions
-------------------------------------------------------------------------------

unionUpper :: UpperBound -> UpperBound -> UpperBound
unionUpper :: UpperBound -> UpperBound -> UpperBound
unionUpper UpperBound
NoUpperBound      UpperBound
_                 = UpperBound
NoUpperBound
unionUpper UpperBound
_                 UpperBound
NoUpperBound      = UpperBound
NoUpperBound
unionUpper (UpperBound Version
v Bound
vb) (UpperBound Version
u Bound
ub) = case Version -> Version -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Version
v Version
u of
    Ordering
EQ -> Version -> Bound -> UpperBound
UpperBound Version
v (Bound -> Bound -> Bound
unionBound Bound
vb Bound
ub)
    Ordering
LT -> Version -> Bound -> UpperBound
UpperBound Version
u Bound
ub
    Ordering
GT -> Version -> Bound -> UpperBound
UpperBound Version
v Bound
vb

unionBound :: Bound -> Bound -> Bound
unionBound :: Bound -> Bound -> Bound
unionBound Bound
ExclusiveBound Bound
ExclusiveBound = Bound
ExclusiveBound
unionBound Bound
_              Bound
_              = Bound
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 :: VersionRange -> [VersionInterval]
asVersionIntervals = VersionIntervals -> [VersionInterval]
unVersionIntervals (VersionIntervals -> [VersionInterval])
-> (VersionRange -> VersionIntervals)
-> VersionRange
-> [VersionInterval]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionRange -> VersionIntervals
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 :: UpperBound -> LowerBound -> Bool
doesNotTouch UpperBound
NoUpperBound      LowerBound
_                 = Bool
False
doesNotTouch (UpperBound Version
u Bound
ub) (LowerBound Version
l Bound
lb) =
    (Version
u Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
l) Bool -> Bool -> Bool
|| (Version
u Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
l Bool -> Bool -> Bool
&& Bound
ub Bound -> Bound -> Bool
forall a. Eq a => a -> a -> Bool
== Bound
ExclusiveBound Bool -> Bool -> Bool
&& Bound
lb Bound -> Bound -> Bool
forall a. Eq a => a -> a -> Bool
== Bound
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 -> Bool
invariantVersionIntervals (VersionIntervals [VersionInterval]
intervals) =
    (VersionInterval -> Bool) -> [VersionInterval] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all VersionInterval -> Bool
validInterval [VersionInterval]
intervals Bool -> Bool -> Bool
&&
    ((VersionInterval, VersionInterval) -> Bool)
-> [(VersionInterval, VersionInterval)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (VersionInterval, VersionInterval) -> Bool
doesNotTouch' [(VersionInterval, VersionInterval)]
adjacentIntervals
  where
    doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool
    doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool
doesNotTouch' (VersionInterval LowerBound
_ UpperBound
u, VersionInterval LowerBound
l' UpperBound
_) = UpperBound -> LowerBound -> Bool
doesNotTouch UpperBound
u LowerBound
l'

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

checkInvariant :: VersionIntervals -> VersionIntervals
checkInvariant :: VersionIntervals -> VersionIntervals
checkInvariant VersionIntervals
is = Bool -> VersionIntervals -> VersionIntervals
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (VersionIntervals -> Bool
invariantVersionIntervals VersionIntervals
is) VersionIntervals
is
{-# INLINE checkInvariant #-}

validInterval :: VersionInterval -> Bool
validInterval :: VersionInterval -> Bool
validInterval i :: VersionInterval
i@(VersionInterval LowerBound
l UpperBound
u) = LowerBound -> Bool
validLower LowerBound
l Bool -> Bool -> Bool
&& UpperBound -> Bool
validUpper UpperBound
u Bool -> Bool -> Bool
&& VersionInterval -> Bool
nonEmptyVI VersionInterval
i
  where
    validLower :: LowerBound -> Bool
validLower (LowerBound Version
v Bound
_) = Version -> Bool
validVersion Version
v
    validUpper :: UpperBound -> Bool
validUpper UpperBound
NoUpperBound      = Bool
True
    validUpper (UpperBound Version
v Bound
_)  = Version -> Bool
validVersion Version
v

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

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

-- | Convert a 'VersionRange' to a sequence of version intervals.
--
toVersionIntervals :: VersionRange -> VersionIntervals
toVersionIntervals :: VersionRange -> VersionIntervals
toVersionIntervals = [VersionInterval] -> VersionIntervals
postprocess ([VersionInterval] -> VersionIntervals)
-> (VersionRange -> [VersionInterval])
-> VersionRange
-> VersionIntervals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionRange -> [VersionInterval]
stage1

-- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression
-- representing the version intervals.
--
fromVersionIntervals :: VersionIntervals -> VersionRange
fromVersionIntervals :: VersionIntervals -> VersionRange
fromVersionIntervals (VersionIntervals [])     = VersionRange
noVersion
fromVersionIntervals (VersionIntervals (VersionInterval
x:[VersionInterval]
xs)) = (VersionRange -> VersionRange -> VersionRange)
-> NonEmpty VersionRange -> VersionRange
forall a. (a -> a -> a) -> NonEmpty a -> a
foldr1 VersionRange -> VersionRange -> VersionRange
unionVersionRanges ((VersionInterval -> VersionRange)
-> NonEmpty VersionInterval -> NonEmpty VersionRange
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VersionInterval -> VersionRange
intervalToVersionRange (VersionInterval
xVersionInterval -> [VersionInterval] -> NonEmpty VersionInterval
forall a. a -> [a] -> NonEmpty a
:|[VersionInterval]
xs))

intervalToVersionRange :: VersionInterval -> VersionRange
intervalToVersionRange :: VersionInterval -> VersionRange
intervalToVersionRange (VersionInterval (LowerBound Version
v Bound
vb) UpperBound
upper') = case UpperBound
upper' of
    UpperBound
NoUpperBound
        -> VersionRange
lowerBound

    UpperBound Version
u Bound
ub
        | Bound
vb Bound -> Bound -> Bool
forall a. Eq a => a -> a -> Bool
== Bound
InclusiveBound
        , Bound
ub Bound -> Bound -> Bool
forall a. Eq a => a -> a -> Bool
== Bound
InclusiveBound
        , Version
v Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
u
        -> Version -> VersionRange
thisVersion Version
v

    UpperBound Version
u Bound
ub -> VersionRange -> VersionRange
withLowerBound (Version -> Bound -> VersionRange
makeUpperBound Version
u Bound
ub)
  where
    lowerBound :: VersionRange
    lowerBound :: VersionRange
lowerBound = case Bound
vb of
        Bound
InclusiveBound -> Version -> VersionRange
orLaterVersion Version
v
        Bound
ExclusiveBound -> Version -> VersionRange
laterVersion Version
v

    withLowerBound :: VersionRange -> VersionRange
    withLowerBound :: VersionRange -> VersionRange
withLowerBound VersionRange
vr
        | Version -> Bool
isVersion0 Version
v, Bound
vb Bound -> Bound -> Bool
forall a. Eq a => a -> a -> Bool
== Bound
InclusiveBound = VersionRange
vr
        | Bool
otherwise                          = VersionRange -> VersionRange -> VersionRange
intersectVersionRanges VersionRange
lowerBound VersionRange
vr

    makeUpperBound :: Version -> Bound -> VersionRange
    makeUpperBound :: Version -> Bound -> VersionRange
makeUpperBound Version
u Bound
InclusiveBound = Version -> VersionRange
orEarlierVersion Version
u
    makeUpperBound Version
u Bound
ExclusiveBound = Version -> VersionRange
earlierVersion Version
u

-------------------------------------------------------------------------------
-- Normalisation
-------------------------------------------------------------------------------

-- | Since @Cabal-3.6@ this function.. TODO
--
normaliseVersionRange2 :: VersionRange -> VersionRange
normaliseVersionRange2 :: VersionRange -> VersionRange
normaliseVersionRange2 = VersionIntervals -> VersionRange
fromVersionIntervals (VersionIntervals -> VersionRange)
-> (VersionRange -> VersionIntervals)
-> VersionRange
-> VersionRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionRange -> VersionIntervals
toVersionIntervals

-------------------------------------------------------------------------------
-- Relaxation
-------------------------------------------------------------------------------

relaxLastInterval :: VersionIntervals -> VersionIntervals
relaxLastInterval :: VersionIntervals -> VersionIntervals
relaxLastInterval (VersionIntervals [VersionInterval]
xs) = [VersionInterval] -> VersionIntervals
VersionIntervals ([VersionInterval] -> [VersionInterval]
relaxLastInterval' [VersionInterval]
xs)
  where
    relaxLastInterval' :: [VersionInterval] -> [VersionInterval]
relaxLastInterval' []                    = []
    relaxLastInterval' [VersionInterval LowerBound
l UpperBound
_] = [LowerBound -> UpperBound -> VersionInterval
VersionInterval LowerBound
l UpperBound
NoUpperBound]
    relaxLastInterval' (VersionInterval
i:[VersionInterval]
is)                = VersionInterval
i VersionInterval -> [VersionInterval] -> [VersionInterval]
forall a. a -> [a] -> [a]
: [VersionInterval] -> [VersionInterval]
relaxLastInterval' [VersionInterval]
is

relaxHeadInterval :: VersionIntervals -> VersionIntervals
relaxHeadInterval :: VersionIntervals -> VersionIntervals
relaxHeadInterval (VersionIntervals [VersionInterval]
xs) = [VersionInterval] -> VersionIntervals
VersionIntervals ([VersionInterval] -> [VersionInterval]
relaxHeadInterval' [VersionInterval]
xs)
  where
    relaxHeadInterval' :: [VersionInterval] -> [VersionInterval]
relaxHeadInterval' []                         = []
    relaxHeadInterval' (VersionInterval LowerBound
_ UpperBound
u : [VersionInterval]
is) = LowerBound -> UpperBound -> VersionInterval
VersionInterval LowerBound
zeroLowerBound UpperBound
u VersionInterval -> [VersionInterval] -> [VersionInterval]
forall a. a -> [a] -> [a]
: [VersionInterval]
is