Version.hs 28.7 KB
Newer Older
1
{-# LANGUAGE CPP, DeriveDataTypeable, StandaloneDeriving #-}
2
3
4
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Version
simonmar's avatar
simonmar committed
5
-- Copyright   :  Isaac Jones, Simon Marlow 2003-2004
6
--                Duncan Coutts 2008
7
--
Duncan Coutts's avatar
Duncan Coutts committed
8
-- Maintainer  :  cabal-devel@haskell.org
ijones's avatar
ijones committed
9
-- Portability :  portable
10
--
Duncan Coutts's avatar
Duncan Coutts committed
11
12
13
-- Exports the 'Version' type along with a parser and pretty printer. A version
-- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data
-- types. Version ranges are like @\">= 1.2 && < 2\"@.
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45

{- Copyright (c) 2003-2004, Isaac Jones
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Isaac Jones nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}

simonmar's avatar
simonmar committed
46
47
module Distribution.Version (
  -- * Package versions
simonmar's avatar
simonmar committed
48
  Version(..),
simonmar's avatar
simonmar committed
49

simonmar's avatar
simonmar committed
50
  -- * Version ranges
51
52
53
54
55
56
  VersionRange(..),

  -- ** Constructing
  anyVersion, noVersion,
  thisVersion, notThisVersion,
  laterVersion, earlierVersion,
simonmar's avatar
simonmar committed
57
  orLaterVersion, orEarlierVersion,
58
  unionVersionRanges, intersectVersionRanges,
59
  withinVersion,
simonmar's avatar
simonmar committed
60
  betweenVersionsInclusive,
61

62
  -- ** Inspection
simonmar's avatar
simonmar committed
63
  withinRange,
64
  isAnyVersion,
65
  isNoVersion,
66
67
68
  isSpecificVersion,
  simplifyVersionRange,
  foldVersionRange,
69
  foldVersionRange',
simonmar's avatar
simonmar committed
70

71
  -- * Version intervals view
72
73
  asVersionIntervals,
  VersionInterval,
74
75
76
  LowerBound(..),
  UpperBound(..),
  Bound(..),
77
78
79

  -- ** 'VersionIntervals' abstract type
  -- | The 'VersionIntervals' type and the accompanying functions are exposed
80
  -- primarily for completeness and testing purposes. In practice
81
82
83
84
  -- 'asVersionIntervals' is the main function to use to
  -- view a 'VersionRange' as a bunch of 'VersionInterval's.
  --
  VersionIntervals,
85
86
87
  toVersionIntervals,
  fromVersionIntervals,
  withinIntervals,
88
  versionIntervals,
89
90
91
  mkVersionIntervals,
  unionVersionIntervals,
  intersectVersionIntervals,
92

simonmar's avatar
simonmar committed
93
94
 ) where

95
import Data.Data        ( Data )
96
import Data.Typeable    ( Typeable )
97
import Data.Version     ( Version(..) )
simonmar's avatar
simonmar committed
98

99
100
101
102
import Distribution.Text ( Text(..) )
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP ((+++))
import qualified Text.PrettyPrint as Disp
103
import Text.PrettyPrint ((<>), (<+>))
Duncan Coutts's avatar
Duncan Coutts committed
104
import qualified Data.Char as Char (isDigit)
105
import Control.Exception (assert)
106

simonmar's avatar
simonmar committed
107
108
109
110
111
-- -----------------------------------------------------------------------------
-- Version ranges

-- Todo: maybe move this to Distribution.Package.Version?
-- (package-specific versioning scheme).
112
113
114

data VersionRange
  = AnyVersion
115
116
117
  | ThisVersion            Version -- = version
  | LaterVersion           Version -- > version  (NB. not >=)
  | EarlierVersion         Version -- < version
118
  | WildcardVersion        Version -- == ver.*   (same as >= ver && < ver+1)
119
120
121
  | UnionVersionRanges     VersionRange VersionRange
  | IntersectVersionRanges VersionRange VersionRange
  | VersionRangeParens     VersionRange -- just '(exp)' parentheses syntax
122
123
  deriving (Show,Read,Eq,Typeable,Data)

124
125
#if __GLASGOW_HASKELL__ < 707
-- starting with ghc-7.7/base-4.7 this instance is provided in "Data.Data"
126
deriving instance Data Version
127
#endif
128

129
130
131
132
133
134
135
{-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}
{-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}
{-# DEPRECATED LaterVersion "use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}
{-# DEPRECATED EarlierVersion "use 'earlierVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}
{-# DEPRECATED WildcardVersion "use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}
{-# DEPRECATED UnionVersionRanges "use 'unionVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-}
{-# DEPRECATED IntersectVersionRanges "use 'intersectVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-}
136

137
138
139
140
141
-- | The version range @-any@. That is, a version range containing all
-- versions.
--
-- > withinRange v anyVersion = True
--
142
143
anyVersion :: VersionRange
anyVersion = AnyVersion
144

145
146
147
148
149
150
151
-- | The empty version range, that is a version range containing no versions.
--
-- This can be constructed using any unsatisfiable version range expression,
-- for example @> 1 && < 1@.
--
-- > withinRange v anyVersion = False
--
152
153
154
155
noVersion :: VersionRange
noVersion = IntersectVersionRanges (LaterVersion v) (EarlierVersion v)
  where v = Version [1] []

156
157
158
159
-- | The version range @== v@
--
-- > withinRange v' (thisVersion v) = v' == v
--
160
161
162
thisVersion :: Version -> VersionRange
thisVersion = ThisVersion

163
164
165
166
-- | The version range @< v || > v@
--
-- > withinRange v' (notThisVersion v) = v' /= v
--
167
168
169
notThisVersion :: Version -> VersionRange
notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v)

170
171
172
173
-- | The version range @> v@
--
-- > withinRange v' (laterVersion v) = v' > v
--
174
175
176
laterVersion :: Version -> VersionRange
laterVersion = LaterVersion

177
178
179
180
-- | The version range @>= v@
--
-- > withinRange v' (orLaterVersion v) = v' >= v
--
ijones's avatar
cleanup    
ijones committed
181
orLaterVersion :: Version -> VersionRange
simonmar's avatar
simonmar committed
182
orLaterVersion   v = UnionVersionRanges (ThisVersion v) (LaterVersion v)
ijones's avatar
cleanup    
ijones committed
183

184
185
186
187
-- | The version range @< v@
--
-- > withinRange v' (earlierVersion v) = v' < v
--
188
189
190
earlierVersion :: Version -> VersionRange
earlierVersion = EarlierVersion

191
192
193
194
-- | The version range @<= v@
--
-- > withinRange v' (orEarlierVersion v) = v' <= v
--
ijones's avatar
cleanup    
ijones committed
195
orEarlierVersion :: Version -> VersionRange
simonmar's avatar
simonmar committed
196
197
orEarlierVersion v = UnionVersionRanges (ThisVersion v) (EarlierVersion v)

198
199
200
201
202
-- | The version range @vr1 || vr2@
--
-- >   withinRange v' (unionVersionRanges vr1 vr2)
-- > = withinRange v' vr1 || withinRange v' vr2
--
203
204
205
unionVersionRanges :: VersionRange -> VersionRange -> VersionRange
unionVersionRanges = UnionVersionRanges

206
207
208
209
210
-- | The version range @vr1 && vr2@
--
-- >   withinRange v' (intersectVersionRanges vr1 vr2)
-- > = withinRange v' vr1 && withinRange v' vr2
--
211
212
intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange
intersectVersionRanges = IntersectVersionRanges
ijones's avatar
cleanup    
ijones committed
213

214
215
216
217
218
219
220
221
222
-- | The version range @== v.*@.
--
-- For example, for version @1.2@, the version range @== 1.2.*@ is the same as
-- @>= 1.2 && < 1.3@
--
-- > withinRange v' (laterVersion v) = v' >= v && v' < upper v
-- >   where
-- >     upper (Version lower t) = Version (init lower ++ [last lower + 1]) t
--
223
224
225
withinVersion :: Version -> VersionRange
withinVersion = WildcardVersion

226
227
228
229
230
231
232
-- | The version range @>= v1 && <= v2@.
--
-- In practice this is not very useful because we normally use inclusive lower
-- bounds and exclusive upper bounds.
--
-- > withinRange v' (laterVersion v) = v' > v
--
ijones's avatar
cleanup    
ijones committed
233
betweenVersionsInclusive :: Version -> Version -> VersionRange
simonmar's avatar
simonmar committed
234
235
betweenVersionsInclusive v1 v2 =
  IntersectVersionRanges (orLaterVersion v1) (orEarlierVersion v2)
236

237
{-# DEPRECATED betweenVersionsInclusive
238
    "In practice this is not very useful because we normally use inclusive lower bounds and exclusive upper bounds" #-}
239

240
-- | Fold over the basic syntactic structure of a 'VersionRange'.
241
242
--
-- This provides a syntacic view of the expression defining the version range.
Duncan Coutts's avatar
Duncan Coutts committed
243
-- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented
244
245
-- in terms of the other basic syntax.
--
246
247
-- For a semantic view use 'asVersionIntervals'.
--
Duncan Coutts's avatar
Duncan Coutts committed
248
249
250
251
252
253
foldVersionRange :: a                         -- ^ @\"-any\"@ version
                 -> (Version -> a)            -- ^ @\"== v\"@
                 -> (Version -> a)            -- ^ @\"> v\"@
                 -> (Version -> a)            -- ^ @\"< v\"@
                 -> (a -> a -> a)             -- ^ @\"_ || _\"@ union
                 -> (a -> a -> a)             -- ^ @\"_ && _\"@ intersection
254
                 -> VersionRange -> a
255
foldVersionRange anyv this later earlier union intersect = fold
256
257
258
259
260
  where
    fold AnyVersion                     = anyv
    fold (ThisVersion v)                = this v
    fold (LaterVersion v)               = later v
    fold (EarlierVersion v)             = earlier v
261
262
263
    fold (WildcardVersion v)            = fold (wildcard v)
    fold (UnionVersionRanges v1 v2)     = union (fold v1) (fold v2)
    fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2)
264
265
    fold (VersionRangeParens v)         = fold v

266
267
268
269
270
    wildcard v = intersectVersionRanges
                   (orLaterVersion v)
                   (earlierVersion (wildcardUpperBound v))

-- | An extended variant of 'foldVersionRange' that also provides a view of
Duncan Coutts's avatar
Duncan Coutts committed
271
-- in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented
272
273
-- explicitly rather than in terms of the other basic syntax.
--
Duncan Coutts's avatar
Duncan Coutts committed
274
275
276
277
278
279
280
foldVersionRange' :: a                         -- ^ @\"-any\"@ version
                  -> (Version -> a)            -- ^ @\"== v\"@
                  -> (Version -> a)            -- ^ @\"> v\"@
                  -> (Version -> a)            -- ^ @\"< v\"@
                  -> (Version -> a)            -- ^ @\">= v\"@
                  -> (Version -> a)            -- ^ @\"<= v\"@
                  -> (Version -> Version -> a) -- ^ @\"== v.*\"@ wildcard. The
281
282
283
284
                                               -- function is passed the
                                               -- inclusive lower bound and the
                                               -- exclusive upper bounds of the
                                               -- range defined by the wildcard.
Duncan Coutts's avatar
Duncan Coutts committed
285
286
                  -> (a -> a -> a)             -- ^ @\"_ || _\"@ union
                  -> (a -> a -> a)             -- ^ @\"_ && _\"@ intersection
Ian Lynagh's avatar
Ian Lynagh committed
287
                  -> (a -> a)                  -- ^ @\"(_)\"@ parentheses
288
289
                  -> VersionRange -> a
foldVersionRange' anyv this later earlier orLater orEarlier
290
                  wildcard union intersect parens = fold
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
  where
    fold AnyVersion                     = anyv
    fold (ThisVersion v)                = this v
    fold (LaterVersion v)               = later v
    fold (EarlierVersion v)             = earlier v

    fold (UnionVersionRanges (ThisVersion    v)
                             (LaterVersion   v')) | v==v' = orLater v
    fold (UnionVersionRanges (LaterVersion   v)
                             (ThisVersion    v')) | v==v' = orLater v
    fold (UnionVersionRanges (ThisVersion    v)
                             (EarlierVersion v')) | v==v' = orEarlier v
    fold (UnionVersionRanges (EarlierVersion v)
                             (ThisVersion    v')) | v==v' = orEarlier v

306
307
    fold (WildcardVersion v)            = wildcard v (wildcardUpperBound v)
    fold (UnionVersionRanges v1 v2)     = union (fold v1) (fold v2)
308
    fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2)
309
    fold (VersionRangeParens v)         = parens (fold v)
310

311

312
313
314
315
-- | Does this version fall within the given range?
--
-- This is the evaluation function for the 'VersionRange' type.
--
316
withinRange :: Version -> VersionRange -> Bool
317
318
319
320
321
322
323
324
withinRange v = foldVersionRange
                   True
                   (\v'  -> versionBranch v == versionBranch v')
                   (\v'  -> versionBranch v >  versionBranch v')
                   (\v'  -> versionBranch v <  versionBranch v')
                   (||)
                   (&&)

325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
-- | 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 = versionIntervals . toVersionIntervals

350
351
352
353
354
355
356
357
358
-- | Does this 'VersionRange' place any restriction on the 'Version' or is it
-- in fact equivalent to 'AnyVersion'.
--
-- Note this is a semantic check, not simply a syntactic check. So for example
-- the following is @True@ (for all @v@).
--
-- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v)
--
isAnyVersion :: VersionRange -> Bool
359
isAnyVersion vr = case asVersionIntervals vr of
360
361
  [(LowerBound v InclusiveBound, NoUpperBound)] | isVersion0 v -> True
  _                                                            -> False
362
363
364
365
366
367
368
369
370

-- | This is the converse of 'isAnyVersion'. It check if the version range is
-- empty, if there is no possible version that satisfies the version range.
--
-- For example this is @True@ (for all @v@):
--
-- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v)
--
isNoVersion :: VersionRange -> Bool
371
372
373
isNoVersion vr = case asVersionIntervals vr of
  [] -> True
  _  -> False
374
375
376
377
378
379
380

-- | Is this version range in fact just a specific version?
--
-- For example the version range @\">= 3 && <= 3\"@ contains only the version
-- @3@.
--
isSpecificVersion :: VersionRange -> Maybe Version
381
382
383
384
385
isSpecificVersion vr = case asVersionIntervals vr of
  [(LowerBound v  InclusiveBound
   ,UpperBound v' InclusiveBound)]
    | v == v' -> Just v
  _           -> Nothing
386

387
388
389
-- | Simplify a 'VersionRange' expression. For non-empty version ranges
-- this produces a canonical form. Empty or inconsistent version ranges
-- are left as-is because that provides more information.
390
--
391
392
-- If you need a canonical form use
-- @fromVersionIntervals . toVersionIntervals@
393
--
394
395
396
397
398
399
-- It satisfies the following properties:
--
-- > withinRange v (simplifyVersionRange r) = withinRange v r
--
-- >     withinRange v r = withinRange v r'
-- > ==> simplifyVersionRange r = simplifyVersionRange r'
400
401
-- >  || isNoVersion r
-- >  || isNoVersion r'
402
--
403
simplifyVersionRange :: VersionRange -> VersionRange
404
405
406
407
408
409
410
411
simplifyVersionRange vr
    -- If the version range is inconsistent then we just return the
    -- original since that has more information than ">1 && < 1", which
    -- is the canonical inconsistent version range.
    | null (versionIntervals vi) = vr
    | otherwise                  = fromVersionIntervals vi
  where
    vi = toVersionIntervals vr
412

413
414
415
416
417
----------------------------
-- Wildcard range utilities
--

wildcardUpperBound :: Version -> Version
EyalLotem's avatar
EyalLotem committed
418
wildcardUpperBound (Version lowerBound ts) = Version upperBound ts
419
420
  where
    upperBound = init lowerBound ++ [last lowerBound + 1]
421

422
423
424
425
426
427
428
429
430
431
432
isWildcardRange :: Version -> Version -> Bool
isWildcardRange (Version branch1 _) (Version branch2 _) = check branch1 branch2
  where check (n:[]) (m:[]) | n+1 == m = True
        check (n:ns) (m:ms) | n   == m = check ns ms
        check _      _                 = False

------------------
-- Intervals view
--

-- | A complementary representation of a 'VersionRange'. Instead of a boolean
433
434
-- version predicate it uses an increasing sequence of non-overlapping,
-- non-empty intervals.
435
436
437
438
439
440
441
442
443
444
445
446
--
-- 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)

447
448
449
450
451
-- | Inspect the list of version intervals.
--
versionIntervals :: VersionIntervals -> [VersionInterval]
versionIntervals (VersionIntervals is) = is

452
type VersionInterval = (LowerBound, UpperBound)
453
data LowerBound =                LowerBound Version !Bound deriving (Eq, Show)
454
455
456
data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show)
data Bound      = ExclusiveBound | InclusiveBound          deriving (Eq, Show)

457
458
459
460
461
462
463
minLowerBound :: LowerBound
minLowerBound = LowerBound (Version [0] []) InclusiveBound

isVersion0 :: Version -> Bool
isVersion0 (Version [0] _) = True
isVersion0 _               = False

464
465
466
467
468
469
470
471
472
473
474
475
476
477
instance Ord LowerBound where
  LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of
    LT -> True
    EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound)
    GT -> False

instance Ord UpperBound where
  _            <= NoUpperBound   = True
  NoUpperBound <= UpperBound _ _ = False
  UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of
    LT -> True
    EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound)
    GT -> False

478
invariant :: VersionIntervals -> Bool
479
invariant (VersionIntervals intervals) = all validInterval intervals
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
                                      && all doesNotTouch' adjacentIntervals
  where
    doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool
    doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l'

    adjacentIntervals :: [(VersionInterval, VersionInterval)]
    adjacentIntervals
      | null intervals = []
      | otherwise      = zip intervals (tail intervals)

checkInvariant :: VersionIntervals -> VersionIntervals
checkInvariant is = assert (invariant is) is

-- | Directly construct a 'VersionIntervals' from a list of intervals.
--
-- Each interval must be non-empty. The sequence must be in increasing order
-- and no invervals may overlap or touch. If any of these conditions are not
-- satisfied the function returns @Nothing@.
--
mkVersionIntervals :: [VersionInterval] -> Maybe VersionIntervals
mkVersionIntervals intervals
  | invariant (VersionIntervals intervals) = Just (VersionIntervals intervals)
  | otherwise                              = Nothing

504
505
506
507
validVersion :: Version -> Bool
validVersion (Version [] _) = False
validVersion (Version vs _) = all (>=0) vs

508
validInterval :: (LowerBound, UpperBound) -> Bool
509
510
511
512
513
514
validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i
  where
    validLower (LowerBound v _) = validVersion v
    validUpper NoUpperBound     = True
    validUpper (UpperBound v _) = validVersion v

515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
-- Check an interval is non-empty
--
nonEmpty :: VersionInterval -> Bool
nonEmpty (_,               NoUpperBound   ) = True
nonEmpty (LowerBound l lb, UpperBound u ub) =
  (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound)

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

-- | Check an upper bound does not intersect a lower bound:
--
--   ---|      or  ---)     or  ---]     or  ---)     but not  ---]
--       |---         (---         (---         [---              [---
--
doesNotIntersect :: UpperBound -> LowerBound -> Bool
doesNotIntersect NoUpperBound _ = False
doesNotIntersect (UpperBound u ub) (LowerBound l lb) =
      u <  l
  || (u == l && not (ub == InclusiveBound && lb == InclusiveBound))

544
545
-- | Test if a version falls within the version intervals.
--
546
547
-- It exists mostly for completeness and testing. It satisfies the following
-- properties:
548
549
550
551
552
553
554
--
-- > withinIntervals v (toVersionIntervals vr) = withinRange v vr
-- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs)
--
withinIntervals :: Version -> VersionIntervals -> Bool
withinIntervals v (VersionIntervals intervals) = any withinInterval intervals
  where
555
556
    withinInterval (lowerBound, upperBound)    = withinLower lowerBound
                                              && withinUpper upperBound
557
558
559
560
    withinLower (LowerBound v' ExclusiveBound) = v' <  v
    withinLower (LowerBound v' InclusiveBound) = v' <= v

    withinUpper NoUpperBound                   = True
561
562
    withinUpper (UpperBound v' ExclusiveBound) = v' >  v
    withinUpper (UpperBound v' InclusiveBound) = v' >= v
563

564
-- | Convert a 'VersionRange' to a sequence of version intervals.
565
566
--
toVersionIntervals :: VersionRange -> VersionIntervals
567
toVersionIntervals = foldVersionRange
568
  (         chkIvl (minLowerBound,               NoUpperBound))
569
570
  (\v    -> chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound))
  (\v    -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound))
571
572
  (\v    -> if isVersion0 v then VersionIntervals [] else
            chkIvl (minLowerBound,               UpperBound v ExclusiveBound))
573
574
  unionVersionIntervals
  intersectVersionIntervals
575
  where
576
    chkIvl interval = checkInvariant (VersionIntervals [interval])
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592

-- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression
-- representing the version intervals.
--
fromVersionIntervals :: VersionIntervals -> VersionRange
fromVersionIntervals (VersionIntervals []) = noVersion
fromVersionIntervals (VersionIntervals intervals) =
    foldr1 UnionVersionRanges [ interval l u | (l, u) <- intervals ]

  where
    interval (LowerBound v  InclusiveBound)
             (UpperBound v' InclusiveBound) | v == v'
                 = ThisVersion v
    interval (LowerBound v  InclusiveBound)
             (UpperBound v' ExclusiveBound) | isWildcardRange v v'
                 = WildcardVersion v
593
    interval l u = lowerBound l `intersectVersionRanges'` upperBound u
594

595
596
597
    lowerBound (LowerBound v InclusiveBound)
                              | isVersion0 v = AnyVersion
                              | otherwise    = orLaterVersion v
598
599
600
601
602
603
    lowerBound (LowerBound v ExclusiveBound) = LaterVersion v

    upperBound NoUpperBound                  = AnyVersion
    upperBound (UpperBound v InclusiveBound) = orEarlierVersion v
    upperBound (UpperBound v ExclusiveBound) = EarlierVersion v

604
605
606
    intersectVersionRanges' vr AnyVersion = vr
    intersectVersionRanges' AnyVersion vr = vr
    intersectVersionRanges' vr vr'        = IntersectVersionRanges vr vr'
607

608
609
610
611
612
613
614
615
616
617
618
619
620
unionVersionIntervals :: VersionIntervals -> VersionIntervals
                      -> VersionIntervals
unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) =
  checkInvariant (VersionIntervals (union is0 is'0))
  where
    union is []  = is
    union [] is' = is'
    union (i:is) (i':is') = case unionInterval i i' of
      Left  Nothing    -> i  : union      is  (i' :is')
      Left  (Just i'') ->      union      is  (i'':is')
      Right Nothing    -> i' : union (i  :is)      is'
      Right (Just i'') ->      union (i'':is)      is'

621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
unionInterval :: VersionInterval -> VersionInterval
              -> Either (Maybe VersionInterval) (Maybe VersionInterval)
unionInterval (lower , upper ) (lower', upper')

  -- Non-intersecting intervals with the left interval ending first
  | upper `doesNotTouch` lower' = Left Nothing

  -- Non-intersecting intervals with the right interval first
  | upper' `doesNotTouch` lower = Right Nothing

  -- Complete or partial overlap, with the left interval ending first
  | upper <= upper' = lowerBound `seq`
                      Left (Just (lowerBound, upper'))

  -- Complete or partial overlap, with the left interval ending first
  | otherwise = lowerBound `seq`
                Right (Just (lowerBound, upper))
  where
    lowerBound = min lower lower'

641
642
643
644
645
646
647
648
649
650
651
652
intersectVersionIntervals :: VersionIntervals -> VersionIntervals
                          -> VersionIntervals
intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) =
  checkInvariant (VersionIntervals (intersect is0 is'0))
  where
    intersect _  [] = []
    intersect [] _  = []
    intersect (i:is) (i':is') = case intersectInterval i i' of
      Left  Nothing    ->       intersect is (i':is')
      Left  (Just i'') -> i'' : intersect is (i':is')
      Right Nothing    ->       intersect (i:is) is'
      Right (Just i'') -> i'' : intersect (i:is) is'
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673

intersectInterval :: VersionInterval -> VersionInterval
                  -> Either (Maybe VersionInterval) (Maybe VersionInterval)
intersectInterval (lower , upper ) (lower', upper')

  -- Non-intersecting intervals with the left interval ending first
  | upper `doesNotIntersect` lower' = Left Nothing

  -- Non-intersecting intervals with the right interval first
  | upper' `doesNotIntersect` lower = Right Nothing

  -- Complete or partial overlap, with the left interval ending first
  | upper <= upper' = lowerBound `seq`
                      Left (Just (lowerBound, upper))

  -- Complete or partial overlap, with the right interval ending first
  | otherwise = lowerBound `seq`
                Right (Just (lowerBound, upper'))
  where
    lowerBound = max lower lower'

674
675
676
-------------------------------
-- Parsing and pretty printing
--
simonmar's avatar
simonmar committed
677

678
instance Text VersionRange where
679
680
  disp = fst
       . foldVersionRange'                         -- precedence:
Duncan Coutts's avatar
Duncan Coutts committed
681
           (         Disp.text "-any"                           , 0 :: Int)
682
683
684
685
686
687
688
689
           (\v   -> (Disp.text "==" <> disp v                   , 0))
           (\v   -> (Disp.char '>'  <> disp v                   , 0))
           (\v   -> (Disp.char '<'  <> disp v                   , 0))
           (\v   -> (Disp.text ">=" <> disp v                   , 0))
           (\v   -> (Disp.text "<=" <> disp v                   , 0))
           (\v _ -> (Disp.text "==" <> dispWild v               , 0))
           (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2))
           (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1))
690
           (\(r, p)   -> (Disp.parens r, p))
691

692
693
694
    where dispWild (Version b _) =
               Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))
            <> Disp.text ".*"
695
696
          punct p p' | p < p'    = Disp.parens
                     | otherwise = id
697

698
  parse = expr
699
   where
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
        expr   = do Parse.skipSpaces
                    t <- term
                    Parse.skipSpaces
                    (do _  <- Parse.string "||"
                        Parse.skipSpaces
                        e <- expr
                        return (UnionVersionRanges t e)
                     +++
                     return t)
        term   = do f <- factor
                    Parse.skipSpaces
                    (do _  <- Parse.string "&&"
                        Parse.skipSpaces
                        t <- term
                        return (IntersectVersionRanges f t)
                     +++
                     return f)
        factor = Parse.choice $ parens expr
                              : parseAnyVersion
                              : parseWildcardRange
                              : map parseRangeOp rangeOps
Duncan Coutts's avatar
Duncan Coutts committed
721
        parseAnyVersion    = Parse.string "-any" >> return AnyVersion
722
723

        parseWildcardRange = do
724
          _ <- Parse.string "=="
725
726
          Parse.skipSpaces
          branch <- Parse.sepBy1 digits (Parse.char '.')
727
728
          _ <- Parse.char '.'
          _ <- Parse.char '*'
729
730
          return (WildcardVersion (Version branch []))

731
732
733
734
        parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces)
                                 (Parse.char ')' >> Parse.skipSpaces)
                                 (do a <- p
                                     Parse.skipSpaces
735
                                     return (VersionRangeParens a))
736

737
738
739
740
741
742
743
        digits = do
          first <- Parse.satisfy Char.isDigit
          if first == '0'
            then return 0
            else do rest <- Parse.munch Char.isDigit
                    return (read (first : rest))

744
        parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse
ka2_mail's avatar
ka2_mail committed
745
        rangeOps = [ ("<",  EarlierVersion),
746
747
748
749
                     ("<=", orEarlierVersion),
                     (">",  LaterVersion),
                     (">=", orLaterVersion),
                     ("==", ThisVersion) ]