content: {-# 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
  