Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

808 lines (708 sloc) 31.346 kB
{-# LANGUAGE CPP, DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
#if __GLASGOW_HASKELL__ < 707
{-# LANGUAGE StandaloneDeriving #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Version
-- Copyright : Isaac Jones, Simon Marlow 2003-2004
-- Duncan Coutts 2008
-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- 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\"@.
module Distribution.Version (
-- * Package versions
Version(..),
-- * Version ranges
VersionRange(..),
-- ** Constructing
anyVersion, noVersion,
thisVersion, notThisVersion,
laterVersion, earlierVersion,
orLaterVersion, orEarlierVersion,
unionVersionRanges, intersectVersionRanges,
invertVersionRange,
withinVersion,
betweenVersionsInclusive,
-- ** Inspection
withinRange,
isAnyVersion,
isNoVersion,
isSpecificVersion,
simplifyVersionRange,
foldVersionRange,
foldVersionRange',
-- ** Modification
removeUpperBound,
-- * Version intervals view
asVersionIntervals,
VersionInterval,
LowerBound(..),
UpperBound(..),
Bound(..),
-- ** 'VersionIntervals' abstract type
-- | The 'VersionIntervals' type and the accompanying functions are exposed
-- primarily for completeness and testing purposes. In practice
-- 'asVersionIntervals' is the main function to use to
-- view a 'VersionRange' as a bunch of 'VersionInterval's.
--
VersionIntervals,
toVersionIntervals,
fromVersionIntervals,
withinIntervals,
versionIntervals,
mkVersionIntervals,
unionVersionIntervals,
intersectVersionIntervals,
invertVersionIntervals
) where
import Distribution.Compat.Binary ( Binary(..) )
import Data.Data ( Data )
import Data.Typeable ( Typeable )
import Data.Version ( Version(..) )
import GHC.Generics ( Generic )
import Distribution.Text ( Text(..) )
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP ((+++))
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<>), (<+>))
import qualified Data.Char as Char (isDigit)
import Control.Exception (assert)
-- -----------------------------------------------------------------------------
-- Version ranges
-- Todo: maybe move this to Distribution.Package.Version?
-- (package-specific versioning scheme).
data VersionRange
= AnyVersion
| ThisVersion Version -- = version
| LaterVersion Version -- > version (NB. not >=)
| EarlierVersion Version -- < version
| WildcardVersion Version -- == ver.* (same as >= ver && < ver+1)
| UnionVersionRanges VersionRange VersionRange
| IntersectVersionRanges VersionRange VersionRange
| VersionRangeParens VersionRange -- just '(exp)' parentheses syntax
deriving (Data, Eq, Generic, Read, Show, Typeable)
instance Binary VersionRange
#if __GLASGOW_HASKELL__ < 707
-- starting with ghc-7.7/base-4.7 this instance is provided in "Data.Data"
deriving instance Data Version
#endif
-- Deriving this instance from Generic gives trouble on GHC 7.2 because the
-- Generic instance has to be standalone-derived. So, we hand-roll our own.
-- We can't use a generic Binary instance on later versions because we must
-- maintain compatibility between compiler versions.
instance Binary Version where
get = do
br <- get
tags <- get
return $ Version br tags
put (Version br tags) = put br >> put tags
{-# 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'" #-}
-- | The version range @-any@. That is, a version range containing all
-- versions.
--
-- > withinRange v anyVersion = True
--
anyVersion :: VersionRange
anyVersion = AnyVersion
-- | 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 noVersion = False
--
noVersion :: VersionRange
noVersion = IntersectVersionRanges (LaterVersion v) (EarlierVersion v)
where v = Version [1] []
-- | The version range @== v@
--
-- > withinRange v' (thisVersion v) = v' == v
--
thisVersion :: Version -> VersionRange
thisVersion = ThisVersion
-- | The version range @< v || > v@
--
-- > withinRange v' (notThisVersion v) = v' /= v
--
notThisVersion :: Version -> VersionRange
notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v)
-- | The version range @> v@
--
-- > withinRange v' (laterVersion v) = v' > v
--
laterVersion :: Version -> VersionRange
laterVersion = LaterVersion
-- | The version range @>= v@
--
-- > withinRange v' (orLaterVersion v) = v' >= v
--
orLaterVersion :: Version -> VersionRange
orLaterVersion v = UnionVersionRanges (ThisVersion v) (LaterVersion v)
-- | The version range @< v@
--
-- > withinRange v' (earlierVersion v) = v' < v
--
earlierVersion :: Version -> VersionRange
earlierVersion = EarlierVersion
-- | The version range @<= v@
--
-- > withinRange v' (orEarlierVersion v) = v' <= v
--
orEarlierVersion :: Version -> VersionRange
orEarlierVersion v = UnionVersionRanges (ThisVersion v) (EarlierVersion v)
-- | The version range @vr1 || vr2@
--
-- > withinRange v' (unionVersionRanges vr1 vr2)
-- > = withinRange v' vr1 || withinRange v' vr2
--
unionVersionRanges :: VersionRange -> VersionRange -> VersionRange
unionVersionRanges = UnionVersionRanges
-- | The version range @vr1 && vr2@
--
-- > withinRange v' (intersectVersionRanges vr1 vr2)
-- > = withinRange v' vr1 && withinRange v' vr2
--
intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange
intersectVersionRanges = IntersectVersionRanges
-- | The inverse of a version range
--
-- > withinRange v' (invertVersionRange vr)
-- > = not (withinRange v' vr)
--
invertVersionRange :: VersionRange -> VersionRange
invertVersionRange =
fromVersionIntervals . invertVersionIntervals . VersionIntervals . asVersionIntervals
-- | 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
--
withinVersion :: Version -> VersionRange
withinVersion = WildcardVersion
-- | 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
--
betweenVersionsInclusive :: Version -> Version -> VersionRange
betweenVersionsInclusive v1 v2 =
IntersectVersionRanges (orLaterVersion v1) (orEarlierVersion v2)
{-# DEPRECATED betweenVersionsInclusive
"In practice this is not very useful because we normally use inclusive lower bounds and exclusive upper bounds" #-}
-- | Given a version range, remove the highest upper bound. Example: @(>= 1 && <
-- 3) || (>= 4 && < 5)@ is converted to @(>= 1 && < 3) || (>= 4)@.
removeUpperBound :: VersionRange -> VersionRange
removeUpperBound = fromVersionIntervals . relaxLastInterval . toVersionIntervals
where
relaxLastInterval (VersionIntervals intervals) =
VersionIntervals (relaxLastInterval' intervals)
relaxLastInterval' [] = []
relaxLastInterval' [(l,_)] = [(l, NoUpperBound)]
relaxLastInterval' (i:is) = i : relaxLastInterval' is
-- | Fold over the basic syntactic structure of a 'VersionRange'.
--
-- This provides a syntactic view of the expression defining the version range.
-- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented
-- in terms of the other basic syntax.
--
-- For a semantic view use 'asVersionIntervals'.
--
foldVersionRange :: a -- ^ @\"-any\"@ version
-> (Version -> a) -- ^ @\"== v\"@
-> (Version -> a) -- ^ @\"> v\"@
-> (Version -> a) -- ^ @\"< v\"@
-> (a -> a -> a) -- ^ @\"_ || _\"@ union
-> (a -> a -> a) -- ^ @\"_ && _\"@ intersection
-> VersionRange -> a
foldVersionRange anyv this later earlier union intersect = fold
where
fold AnyVersion = anyv
fold (ThisVersion v) = this v
fold (LaterVersion v) = later v
fold (EarlierVersion v) = earlier v
fold (WildcardVersion v) = fold (wildcard v)
fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2)
fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2)
fold (VersionRangeParens v) = fold v
wildcard v = intersectVersionRanges
(orLaterVersion v)
(earlierVersion (wildcardUpperBound v))
-- | An extended variant of 'foldVersionRange' that also provides a view of
-- in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented
-- explicitly rather than in terms of the other basic syntax.
--
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
-- function is passed the
-- inclusive lower bound and the
-- exclusive upper bounds of the
-- range defined by the wildcard.
-> (a -> a -> a) -- ^ @\"_ || _\"@ union
-> (a -> a -> a) -- ^ @\"_ && _\"@ intersection
-> (a -> a) -- ^ @\"(_)\"@ parentheses
-> VersionRange -> a
foldVersionRange' anyv this later earlier orLater orEarlier
wildcard union intersect parens = fold
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
fold (WildcardVersion v) = wildcard v (wildcardUpperBound v)
fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2)
fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2)
fold (VersionRangeParens v) = parens (fold v)
-- | Does this version fall within the given range?
--
-- This is the evaluation function for the 'VersionRange' type.
--
withinRange :: Version -> VersionRange -> Bool
withinRange v = foldVersionRange
True
(\v' -> versionBranch v == versionBranch v')
(\v' -> versionBranch v > versionBranch v')
(\v' -> versionBranch v < versionBranch v')
(||)
(&&)
-- | 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
-- | 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
isAnyVersion vr = case asVersionIntervals vr of
[(LowerBound v InclusiveBound, NoUpperBound)] | isVersion0 v -> True
_ -> False
-- | 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
isNoVersion vr = case asVersionIntervals vr of
[] -> True
_ -> False
-- | 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
isSpecificVersion vr = case asVersionIntervals vr of
[(LowerBound v InclusiveBound
,UpperBound v' InclusiveBound)]
| v == v' -> Just v
_ -> Nothing
-- | 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.
--
-- If you need a canonical form use
-- @fromVersionIntervals . toVersionIntervals@
--
-- It satisfies the following properties:
--
-- > withinRange v (simplifyVersionRange r) = withinRange v r
--
-- > withinRange v r = withinRange v r'
-- > ==> simplifyVersionRange r = simplifyVersionRange r'
-- > || isNoVersion r
-- > || isNoVersion r'
--
simplifyVersionRange :: VersionRange -> VersionRange
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
----------------------------
-- Wildcard range utilities
--
wildcardUpperBound :: Version -> Version
wildcardUpperBound (Version lowerBound ts) = Version upperBound ts
where
upperBound = init lowerBound ++ [last lowerBound + 1]
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
-- version predicate it uses an increasing sequence of non-overlapping,
-- non-empty intervals.
--
-- The key point is that this representation gives a canonical representation
-- for the semantics of 'VersionRange's. This makes it easier to check things
-- like whether a version range is empty, covers all versions, or requires a
-- certain minimum or maximum version. It also makes it easy to check equality
-- or containment. It also makes it easier to identify \'simple\' version
-- predicates for translation into foreign packaging systems that do not
-- support complex version range expressions.
--
newtype VersionIntervals = VersionIntervals [VersionInterval]
deriving (Eq, Show)
-- | Inspect the list of version intervals.
--
versionIntervals :: VersionIntervals -> [VersionInterval]
versionIntervals (VersionIntervals is) = is
type VersionInterval = (LowerBound, UpperBound)
data LowerBound = LowerBound Version !Bound deriving (Eq, Show)
data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show)
data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show)
minLowerBound :: LowerBound
minLowerBound = LowerBound (Version [0] []) InclusiveBound
isVersion0 :: Version -> Bool
isVersion0 (Version [0] _) = True
isVersion0 _ = False
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
invariant :: VersionIntervals -> Bool
invariant (VersionIntervals intervals) = all validInterval intervals
&& 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 intervals 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
validVersion :: Version -> Bool
validVersion (Version [] _) = False
validVersion (Version vs _) = all (>=0) vs
validInterval :: (LowerBound, UpperBound) -> Bool
validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i
where
validLower (LowerBound v _) = validVersion v
validUpper NoUpperBound = True
validUpper (UpperBound v _) = validVersion v
-- 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))
-- | Test if a version falls within the version intervals.
--
-- It exists mostly for completeness and testing. It satisfies the following
-- properties:
--
-- > 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
withinInterval (lowerBound, upperBound) = withinLower lowerBound
&& withinUpper upperBound
withinLower (LowerBound v' ExclusiveBound) = v' < v
withinLower (LowerBound v' InclusiveBound) = v' <= v
withinUpper NoUpperBound = True
withinUpper (UpperBound v' ExclusiveBound) = v' > v
withinUpper (UpperBound v' InclusiveBound) = v' >= v
-- | Convert a 'VersionRange' to a sequence of version intervals.
--
toVersionIntervals :: VersionRange -> VersionIntervals
toVersionIntervals = foldVersionRange
( chkIvl (minLowerBound, NoUpperBound))
(\v -> chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound))
(\v -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound))
(\v -> if isVersion0 v then VersionIntervals [] else
chkIvl (minLowerBound, UpperBound v ExclusiveBound))
unionVersionIntervals
intersectVersionIntervals
where
chkIvl interval = checkInvariant (VersionIntervals [interval])
-- | 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
interval l u = lowerBound l `intersectVersionRanges'` upperBound u
lowerBound (LowerBound v InclusiveBound)
| isVersion0 v = AnyVersion
| otherwise = orLaterVersion v
lowerBound (LowerBound v ExclusiveBound) = LaterVersion v
upperBound NoUpperBound = AnyVersion
upperBound (UpperBound v InclusiveBound) = orEarlierVersion v
upperBound (UpperBound v ExclusiveBound) = EarlierVersion v
intersectVersionRanges' vr AnyVersion = vr
intersectVersionRanges' AnyVersion vr = vr
intersectVersionRanges' vr vr' = IntersectVersionRanges vr vr'
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'
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'
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'
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'
invertVersionIntervals :: VersionIntervals
-> VersionIntervals
invertVersionIntervals (VersionIntervals xs) =
case xs of
-- Empty interval set
[] -> VersionIntervals [(noLowerBound, NoUpperBound)]
-- Interval with no lower bound
((lb, ub) : more) | lb == noLowerBound -> VersionIntervals $ invertVersionIntervals' ub more
-- Interval with a lower bound
((lb, ub) : more) ->
VersionIntervals $ (noLowerBound, invertLowerBound lb) : invertVersionIntervals' ub more
where
-- Invert subsequent version intervals given the upper bound of
-- the intervals already inverted.
invertVersionIntervals' :: UpperBound
-> [(LowerBound, UpperBound)]
-> [(LowerBound, UpperBound)]
invertVersionIntervals' NoUpperBound [] = []
invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)]
invertVersionIntervals' ub0 [(lb, NoUpperBound)] =
[(invertUpperBound ub0, invertLowerBound lb)]
invertVersionIntervals' ub0 ((lb, ub1) : more) =
(invertUpperBound ub0, invertLowerBound lb)
: invertVersionIntervals' ub1 more
invertLowerBound :: LowerBound -> UpperBound
invertLowerBound (LowerBound v b) = UpperBound v (invertBound b)
invertUpperBound :: UpperBound -> LowerBound
invertUpperBound (UpperBound v b) = LowerBound v (invertBound b)
invertUpperBound NoUpperBound = error "NoUpperBound: unexpected"
invertBound :: Bound -> Bound
invertBound ExclusiveBound = InclusiveBound
invertBound InclusiveBound = ExclusiveBound
noLowerBound :: LowerBound
noLowerBound = LowerBound (Version [0] []) InclusiveBound
-------------------------------
-- Parsing and pretty printing
--
instance Text VersionRange where
disp = fst
. foldVersionRange' -- precedence:
( Disp.text "-any" , 0 :: Int)
(\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))
(\(r, _) -> (Disp.parens r, 0))
where dispWild (Version b _) =
Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))
<> Disp.text ".*"
punct p p' | p < p' = Disp.parens
| otherwise = id
parse = expr
where
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
: parseNoVersion
: parseWildcardRange
: map parseRangeOp rangeOps
parseAnyVersion = Parse.string "-any" >> return AnyVersion
parseNoVersion = Parse.string "-none" >> return noVersion
parseWildcardRange = do
_ <- Parse.string "=="
Parse.skipSpaces
branch <- Parse.sepBy1 digits (Parse.char '.')
_ <- Parse.char '.'
_ <- Parse.char '*'
return (WildcardVersion (Version branch []))
parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces)
(Parse.char ')' >> Parse.skipSpaces)
(do a <- p
Parse.skipSpaces
return (VersionRangeParens a))
digits = do
first <- Parse.satisfy Char.isDigit
if first == '0'
then return 0
else do rest <- Parse.munch Char.isDigit
return (read (first : rest))
parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse
rangeOps = [ ("<", EarlierVersion),
("<=", orEarlierVersion),
(">", LaterVersion),
(">=", orLaterVersion),
("==", ThisVersion) ]
Jump to Line
Something went wrong with that request. Please try again.