{-# LANGUAGE CPP, DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} #if __GLASGOW_HASKELL__ < 707 {-# LANGUAGE StandaloneDeriving #-} #endif -- Hack approach to support bootstrapping. -- When MIN_VERSION_binary macro is available, use it. But it's not available -- during bootstrapping (or anyone else building Setup.hs directly). If the -- builder specifies -DMIN_VERSION_binary_0_8_0=1 or =0 then we respect that. -- Otherwise we pick a default based on GHC version: assume binary <0.8 when -- GHC < 8.0, and binary >=0.8 when GHC >= 8.0. #ifdef MIN_VERSION_binary #define MIN_VERSION_binary_0_8_0 MIN_VERSION_binary(0,8,0) #else #ifndef MIN_VERSION_binary_0_8_0 #if __GLASGOW_HASKELL__ >= 800 #define MIN_VERSION_binary_0_8_0 1 #else #define MIN_VERSION_binary_0_8_0 0 #endif #endif #endif #if !MIN_VERSION_binary_0_8_0 {-# OPTIONS_GHC -fno-warn-orphans #-} #endif ----------------------------------------------------------------------------- -- | -- 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', hasUpperBound, hasLowerBound, -- ** 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 import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP hiding (get) 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 #if !(MIN_VERSION_binary_0_8_0) -- 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 #endif {-# 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 the -- expression 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) ] -- | Does the version range have an upper bound? -- -- @since 1.24.0.0 hasUpperBound :: VersionRange -> Bool hasUpperBound = foldVersionRange False (const True) (const False) (const True) (&&) (||) -- | Does the version range have an explicit lower bound? -- -- Note: this function only considers the user-specified lower bounds, but not -- the implicit >=0 lower bound. -- -- @since 1.24.0.0 hasLowerBound :: VersionRange -> Bool hasLowerBound = foldVersionRange False (const True) (const True) (const False) (&&) (||)