Cabal-syntax/src/Distribution/Types/VersionInterval.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3
   4 -- | This module implements a view of a 'VersionRange' as a finite
   5 -- list of separated version intervals.
   6 --
   7 -- In conversion from and to 'VersionRange' it makes some effort to
   8 -- preserve the caret operator @^>=x.y@.  This constraint a priori
   9 -- specifies the same interval as @==x.y.*@, but indicates that newer
  10 -- versions could be acceptable (@allow-newer: ^@).
  11 module Distribution.Types.VersionInterval
  12   ( -- * Version intervals
  13     VersionIntervals
  14   , unVersionIntervals
  15   , mkVersionIntervals
  16
  17     -- * Conversions
  18   , toVersionIntervals
  19   , fromVersionIntervals
  20
  21     -- ** Normalisation
  22   , normaliseVersionRange2
  23
  24     -- * Relaxation
  25   , relaxLastInterval
  26   , relaxHeadInterval
  27
  28     -- * Version intervals view
  29   , asVersionIntervals
  30   , VersionInterval (..)
  31   , LowerBound (..)
  32   , UpperBound (..)
  33   , Bound (..)
  34
  35     -- * Invariants
  36   , invariantVersionIntervals
  37   ) where
  38
  39 import Control.Applicative (liftA2)
  40 import Control.Exception (assert)
  41 import Distribution.Compat.Prelude hiding (Applicative (..))
  42 import Prelude ()
  43
  44 import Distribution.Types.Version
  45 import Distribution.Types.VersionRange.Internal
  46
  47 -- To test this module, and to run version range normalisation benchmarks:
  48 --
  49 -- cabal run Cabal-tests:unit-tests -- -p Distribution.Version
  50 -- cabal run cabal-benchmarks -- -o bench.html normaliseVersionRange
  51
  52 -------------------------------------------------------------------------------
  53 -- Data
  54 -------------------------------------------------------------------------------
  55
  56 -- | A complementary representation of a 'VersionRange'. Instead of a boolean
  57 -- version predicate it uses an increasing sequence of non-overlapping,
  58 -- non-empty intervals.
  59 --
  60 -- The key point is that this representation gives a canonical representation
  61 -- for the semantics of 'VersionRange's. This makes it easier to check things
  62 -- like whether a version range is empty, covers all versions, or requires a
  63 -- certain minimum or maximum version. It also makes it easy to check equality
  64 -- or containment. It also makes it easier to identify \'simple\' version
  65 -- predicates for translation into foreign packaging systems that do not
  66 -- support complex version range expressions.
  67 newtype VersionIntervals = VersionIntervals [VersionInterval]
  68   deriving (Eq, Show, Typeable)
  69
  70 -- | Inspect the list of version intervals.
  71 unVersionIntervals :: VersionIntervals -> [VersionInterval]
  72 unVersionIntervals (VersionIntervals is) = is
  73
  74 -- | Directly construct a 'VersionIntervals' from a list of intervals.
  75 mkVersionIntervals :: [VersionInterval] -> Maybe VersionIntervals
  76 mkVersionIntervals intervals
  77   | invariantVersionIntervals (VersionIntervals intervals) = Just . VersionIntervals $ intervals
  78   | otherwise = Nothing
  79
  80 data VersionInterval = VersionInterval !LowerBound !UpperBound deriving (Eq, Show)
  81 data LowerBound = LowerBound !Version !Bound deriving (Eq, Show)
  82 data UpperBound = NoUpperBound | UpperBound !Version !Bound deriving (Eq, Show)
  83 data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show)
  84
  85 zeroLowerBound :: LowerBound
  86 zeroLowerBound = LowerBound version0 InclusiveBound
  87
  88 isVersion0 :: Version -> Bool
  89 isVersion0 = (==) version0
  90
  91 -------------------------------------------------------------------------------
  92 -- Stage1
  93 -------------------------------------------------------------------------------
  94
  95 stage1 :: VersionRange -> [VersionInterval]
  96 stage1 = cataVersionRange alg
  97   where
  98     -- version range leafs transform into singleton intervals
  99     alg (ThisVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound v InclusiveBound)]
 100     alg (LaterVersionF v) = [VersionInterval (LowerBound v ExclusiveBound) NoUpperBound]
 101     alg (OrLaterVersionF v) = [VersionInterval (LowerBound v InclusiveBound) NoUpperBound]
 102     alg (EarlierVersionF v)
 103       | isVersion0 v = []
 104       | otherwise = [VersionInterval zeroLowerBound (UpperBound v ExclusiveBound)]
 105     alg (OrEarlierVersionF v) = [VersionInterval zeroLowerBound (UpperBound v InclusiveBound)]
 106     -- \^>= version-range's upper bound should be MajorBound
 107     alg (MajorBoundVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound (majorUpperBound v) ExclusiveBound)]
 108     -- union: just merge the version intervals
 109     alg (UnionVersionRangesF v1 v2) = v1 ++ v2
 110     -- intersection: pairwise intersect. Strip empty intervals. Sort to restore the invariant.
 111     alg (IntersectVersionRangesF v1 v2) = mapMaybe nonEmptyInterval $ liftA2 intersectInterval (stage2and3 v1) (stage2and3 v2)
 112
 113 -- | Check that interval is non-empty
 114 nonEmptyInterval :: VersionInterval -> Maybe VersionInterval
 115 nonEmptyInterval i | nonEmptyVI i = Just i
 116 nonEmptyInterval _ = Nothing
 117
 118 -------------------------------------------------------------------------------
 119 -- Stage2
 120 -------------------------------------------------------------------------------
 121
 122 stage2 :: [VersionInterval] -> [VersionInterval]
 123 stage2 = sortBy lowerboundCmp
 124
 125 lowerboundCmp :: VersionInterval -> VersionInterval -> Ordering
 126 lowerboundCmp (VersionInterval (LowerBound v vb) _) (VersionInterval (LowerBound u ub) _) =
 127   compare v u `mappend` compareBound vb ub
 128   where
 129     compareBound :: Bound -> Bound -> Ordering
 130     compareBound InclusiveBound InclusiveBound = EQ
 131     compareBound InclusiveBound ExclusiveBound = LT
 132     compareBound ExclusiveBound InclusiveBound = GT
 133     compareBound ExclusiveBound ExclusiveBound = EQ
 134
 135 -------------------------------------------------------------------------------
 136 -- Postprocess
 137 -------------------------------------------------------------------------------
 138
 139 -- | Post-processing takes a list of ordered version intervals,
 140 -- but possibly overlapping, and creates 'VersionIntervals'.
 141 postprocess :: [VersionInterval] -> VersionIntervals
 142 postprocess = checkInvariant . VersionIntervals . stage2and3
 143
 144 stage2and3 :: [VersionInterval] -> [VersionInterval]
 145 stage2and3 = stage3 . stage2
 146
 147 stage3 :: [VersionInterval] -> [VersionInterval]
 148 stage3 [] = []
 149 stage3 (VersionInterval lb ub : rest) = stage3go lb ub rest
 150
 151 stage3go :: LowerBound -> UpperBound -> [VersionInterval] -> [VersionInterval]
 152 stage3go !lb NoUpperBound _ = [VersionInterval lb NoUpperBound]
 153 stage3go !lb !ub [] = [VersionInterval lb ub]
 154 stage3go !lb !ub (VersionInterval lb' ub' : rest')
 155   | doesNotTouch ub lb' = VersionInterval lb ub : stage3go lb' ub' rest'
 156   | otherwise = stage3go lb (unionUpper ub ub') rest'
 157
 158 -------------------------------------------------------------------------------
 159 -- Intersections
 160 -------------------------------------------------------------------------------
 161
 162 intersectInterval :: VersionInterval -> VersionInterval -> VersionInterval
 163 intersectInterval (VersionInterval lv uv) (VersionInterval lu uu) =
 164   VersionInterval (intersectLower lv lu) (intersectUpper uv uu)
 165
 166 intersectLower :: LowerBound -> LowerBound -> LowerBound
 167 intersectLower (LowerBound v vb) (LowerBound u ub) = case compare v u of
 168   EQ -> LowerBound v (intersectBound vb ub)
 169   LT -> LowerBound u ub
 170   GT -> LowerBound v vb
 171
 172 intersectUpper :: UpperBound -> UpperBound -> UpperBound
 173 intersectUpper NoUpperBound b = b
 174 intersectUpper b NoUpperBound = b
 175 intersectUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of
 176   EQ -> UpperBound v (intersectBound vb ub)
 177   LT -> UpperBound v vb
 178   GT -> UpperBound u ub
 179
 180 intersectBound :: Bound -> Bound -> Bound
 181 intersectBound InclusiveBound InclusiveBound = InclusiveBound
 182 intersectBound _ _ = ExclusiveBound
 183
 184 -------------------------------------------------------------------------------
 185 -- Unions
 186 -------------------------------------------------------------------------------
 187
 188 unionUpper :: UpperBound -> UpperBound -> UpperBound
 189 unionUpper NoUpperBound _ = NoUpperBound
 190 unionUpper _ NoUpperBound = NoUpperBound
 191 unionUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of
 192   EQ -> UpperBound v (unionBound vb ub)
 193   LT -> UpperBound u ub
 194   GT -> UpperBound v vb
 195
 196 unionBound :: Bound -> Bound -> Bound
 197 unionBound ExclusiveBound ExclusiveBound = ExclusiveBound
 198 unionBound _ _ = InclusiveBound
 199
 200 -------------------------------------------------------------------------------
 201 -- VersionRange
 202 -------------------------------------------------------------------------------
 203
 204 -- | View a 'VersionRange' as a union of intervals.
 205 --
 206 -- This provides a canonical view of the semantics of a 'VersionRange' as
 207 -- opposed to the syntax of the expression used to define it. For the syntactic
 208 -- view use 'foldVersionRange'.
 209 --
 210 -- Each interval is non-empty. The sequence is in increasing order and no
 211 -- intervals overlap or touch. Therefore only the first and last can be
 212 -- unbounded. The sequence can be empty if the range is empty
 213 -- (e.g. a range expression like @< 1 && > 2@).
 214 --
 215 -- Other checks are trivial to implement using this view. For example:
 216 --
 217 -- > isNoVersion vr | [] <- asVersionIntervals vr = True
 218 -- >                | otherwise                   = False
 219 --
 220 -- > isSpecificVersion vr
 221 -- >    | [(LowerBound v  InclusiveBound
 222 -- >       ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr
 223 -- >    , v == v'   = Just v
 224 -- >    | otherwise = Nothing
 225 asVersionIntervals :: VersionRange -> [VersionInterval]
 226 asVersionIntervals = unVersionIntervals . toVersionIntervals
 227
 228 -------------------------------------------------------------------------------
 229 -- Helpers
 230 -------------------------------------------------------------------------------
 231
 232 -- | Check an upper bound does not intersect, or even touch a lower bound:
 233 --
 234 -- @
 235 --   ---|      or  ---)     but not  ---]     or  ---)     or  ---]
 236 --       |---         (---              (---         [---         [---
 237 -- @
 238 doesNotTouch :: UpperBound -> LowerBound -> Bool
 239 doesNotTouch NoUpperBound _ = False
 240 doesNotTouch (UpperBound u ub) (LowerBound l lb) =
 241   (u < l) || (u == l && ub == ExclusiveBound && lb == ExclusiveBound)
 242
 243 -------------------------------------------------------------------------------
 244 -- Invariants
 245 -------------------------------------------------------------------------------
 246
 247 -- | 'VersionIntervals' invariant:
 248 --
 249 -- * all intervals are valid (lower bound is less then upper bound, i.e. non-empty)
 250 -- * intervals doesn't touch each other (distinct)
 251 invariantVersionIntervals :: VersionIntervals -> Bool
 252 invariantVersionIntervals (VersionIntervals intervals) =
 253   all validInterval intervals
 254     && all doesNotTouch' adjacentIntervals
 255   where
 256     doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool
 257     doesNotTouch' (VersionInterval _ u, VersionInterval l' _) = doesNotTouch u l'
 258
 259     adjacentIntervals :: [(VersionInterval, VersionInterval)]
 260     adjacentIntervals = case intervals of
 261       [] -> []
 262       (_ : tl) -> zip intervals tl
 263
 264 checkInvariant :: VersionIntervals -> VersionIntervals
 265 checkInvariant is = assert (invariantVersionIntervals is) is
 266 {-# INLINE checkInvariant #-}
 267
 268 validInterval :: VersionInterval -> Bool
 269 validInterval i@(VersionInterval l u) = validLower l && validUpper u && nonEmptyVI i
 270   where
 271     validLower (LowerBound v _) = validVersion v
 272     validUpper NoUpperBound = True
 273     validUpper (UpperBound v _) = validVersion v
 274
 275 -- Check an interval is non-empty
 276 --
 277 nonEmptyVI :: VersionInterval -> Bool
 278 nonEmptyVI (VersionInterval _ NoUpperBound) = True
 279 nonEmptyVI (VersionInterval (LowerBound l lb) (UpperBound u ub)) =
 280   (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound)
 281
 282 -------------------------------------------------------------------------------
 283 -- Conversions
 284 -------------------------------------------------------------------------------
 285
 286 -- | Convert a 'VersionRange' to a sequence of version intervals.
 287 toVersionIntervals :: VersionRange -> VersionIntervals
 288 toVersionIntervals = postprocess . stage1
 289
 290 -- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression
 291 -- representing the version intervals.
 292 fromVersionIntervals :: VersionIntervals -> VersionRange
 293 fromVersionIntervals (VersionIntervals []) = noVersion
 294 fromVersionIntervals (VersionIntervals (x : xs)) = foldr1 unionVersionRanges (fmap intervalToVersionRange (x :| xs))
 295
 296 intervalToVersionRange :: VersionInterval -> VersionRange
 297 intervalToVersionRange (VersionInterval (LowerBound v vb) upper') = case upper' of
 298   NoUpperBound ->
 299     lowerBound
 300   UpperBound u ub
 301     | vb == InclusiveBound
 302     , ub == InclusiveBound
 303     , v == u ->
 304         thisVersion v
 305   UpperBound u ub -> withLowerBound (makeUpperBound u ub)
 306   where
 307     lowerBound :: VersionRange
 308     lowerBound = case vb of
 309       InclusiveBound -> orLaterVersion v
 310       ExclusiveBound -> laterVersion v
 311
 312     withLowerBound :: VersionRange -> VersionRange
 313     withLowerBound vr
 314       | isVersion0 v, vb == InclusiveBound = vr
 315       | otherwise = intersectVersionRanges lowerBound vr
 316
 317     makeUpperBound :: Version -> Bound -> VersionRange
 318     makeUpperBound u InclusiveBound = orEarlierVersion u
 319     makeUpperBound u ExclusiveBound = earlierVersion u
 320
 321 -------------------------------------------------------------------------------
 322 -- Normalisation
 323 -------------------------------------------------------------------------------
 324
 325 -- | Since @Cabal-3.6@ this function.. TODO
 326 normaliseVersionRange2 :: VersionRange -> VersionRange
 327 normaliseVersionRange2 = fromVersionIntervals . toVersionIntervals
 328
 329 -------------------------------------------------------------------------------
 330 -- Relaxation
 331 -------------------------------------------------------------------------------
 332
 333 relaxLastInterval :: VersionIntervals -> VersionIntervals
 334 relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs)
 335   where
 336     relaxLastInterval' [] = []
 337     relaxLastInterval' [VersionInterval l _] = [VersionInterval l NoUpperBound]
 338     relaxLastInterval' (i : is) = i : relaxLastInterval' is
 339
 340 relaxHeadInterval :: VersionIntervals -> VersionIntervals
 341 relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs)
 342   where
 343     relaxHeadInterval' [] = []
 344     relaxHeadInterval' (VersionInterval _ u : is) = VersionInterval zeroLowerBound u : is