Skip to content

GitLab

Commit f6b41f5a authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Modify foldVersionRange and add foldVersionRange' 

Now foldVersionRange gives a view with no syntactic sugar
while foldVersionRange' gives a view with the syntactic sugar.
parent 3d773abc
Hide whitespace changes
Inline Side-by-side
Distribution/PackageDescription/Check.hs
View file @ f6b41f5a
......@@ -83,9 +83,10 @@ import Distribution.Simple.Utils
import Distribution.Version
( Version(..)
, VersionRange, withinRange, foldVersionRange
, VersionRange, withinRange, foldVersionRange, foldVersionRange'
, anyVersion, noVersion, thisVersion, laterVersion, earlierVersion
, orLaterVersion, unionVersionRanges, intersectVersionRanges
, orLaterVersion, orEarlierVersion
, unionVersionRanges, intersectVersionRanges
, asVersionIntervals, LowerBound(..), UpperBound(..) )
import Distribution.Package
( PackageName(PackageName), packageName, packageVersion
......@@ -766,24 +767,28 @@ checkCabalVersion pkg =
versionRangeExpressions =
[ dep | dep@(Dependency _ vr) <- buildDepends pkg
, depth vr > (2::Int) ]
where depth = foldVersionRange 1 (const 1) (const 1) (const 1)
(const (const 1)) (+) (+)
where depth = foldVersionRange
1 (const 1)
(const 1) (const 1)
(+) (+)
depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg
, usesWildcardSyntax vr ]
usesWildcardSyntax :: VersionRange -> Bool
usesWildcardSyntax =
foldVersionRange
foldVersionRange'
False (const False)
(const False) (const False)
(const False) (const False)
(\_ _ -> True) -- the wildcard case
(||) (||)
eliminateWildcardSyntax =
foldVersionRange
foldVersionRange'
anyVersion thisVersion
laterVersion earlierVersion
orLaterVersion orEarlierVersion
(\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v'))
intersectVersionRanges unionVersionRanges
......
Distribution/Version.hs
View file @ f6b41f5a
......@@ -65,6 +65,7 @@ module Distribution.Version (
isSpecificVersion,
simplifyVersionRange,
foldVersionRange,
foldVersionRange',
-- * Version intervals view
asVersionIntervals,
......@@ -228,25 +229,75 @@ betweenVersionsInclusive v1 v2 =
"In practice this is not very useful because we normally use inclusive lower bounds and exclusive upper bounds"
#-}
-- | Fold over the syntactic structure of a 'VersionRange'.
-- | Fold over the basic syntactic structure of a 'VersionRange'.
--
-- This provides a syntacic 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 -> (Version -> a) -> (Version -> a) -> (Version -> a)
-> (Version -> Version -> a)
-> (a -> a -> a) -> (a -> a -> a)
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 wildcard union intersect = fold
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)
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
-> VersionRange -> a
foldVersionRange' anyv this later earlier orLater orEarlier
wildcard union intersect = 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)
-- | Does this version fall within the given range?
--
-- This is the evaluation function for the 'VersionRange' type.
......@@ -257,8 +308,6 @@ withinRange v = foldVersionRange
(\v' -> versionBranch v == versionBranch v')
(\v' -> versionBranch v > versionBranch v')
(\v' -> versionBranch v < versionBranch v')
(\l u -> versionBranch v >= versionBranch l
&& versionBranch v < versionBranch u)
(||)
(&&)
......@@ -498,7 +547,6 @@ toVersionIntervals = foldVersionRange
(\v -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound))
(\v -> if isVersion0 v then VersionIntervals [] else
chkIvl (minLowerBound, UpperBound v ExclusiveBound))
(\v v' -> chkIvl (LowerBound v InclusiveBound, UpperBound v' ExclusiveBound))
unionVersionIntervals
intersectVersionIntervals
where
......
tests/Test/Distribution/Version.hs
View file @ f6b41f5a
......@@ -34,6 +34,7 @@ properties =
, property prop_intersectVersionRanges
, property prop_withinVersion
, property prop_foldVersionRange
, property prop_foldVersionRange'
-- the semantic query functions
, property prop_isAnyVersion1
......@@ -93,8 +94,10 @@ instance Arbitrary VersionRange where
, (1, liftM thisVersion arbitrary)
, (1, liftM laterVersion arbitrary)
, (1, liftM orLaterVersion arbitrary)
, (1, liftM orLaterVersion' arbitrary)
, (1, liftM earlierVersion arbitrary)
, (1, liftM orEarlierVersion arbitrary)
, (1, liftM orEarlierVersion' arbitrary)
, (1, liftM withinVersion arbitrary)
] ++ if n == 0 then [] else
[ (2, liftM2 unionVersionRanges verRangeExp2 verRangeExp2)
......@@ -103,6 +106,11 @@ instance Arbitrary VersionRange where
where
verRangeExp2 = verRangeExp (n `div` 2)
orLaterVersion' v =
UnionVersionRanges (LaterVersion v) (ThisVersion v)
orEarlierVersion' v =
UnionVersionRanges (EarlierVersion v) (ThisVersion v)
---------------------------
-- VersionRange properties
--
......@@ -167,12 +175,48 @@ prop_withinVersion v v' =
prop_foldVersionRange :: VersionRange -> Bool
prop_foldVersionRange range =
range
expandWildcard range
== foldVersionRange anyVersion thisVersion
laterVersion earlierVersion
(\v _ -> withinVersion v)
unionVersionRanges intersectVersionRanges
range
where
expandWildcard (WildcardVersion v) =
intersectVersionRanges (orLaterVersion v) (earlierVersion (upper v))
where
upper (Version lower t) = Version (init lower ++ [last lower + 1]) t
expandWildcard (UnionVersionRanges v1 v2) =
UnionVersionRanges (expandWildcard v1) (expandWildcard v2)
expandWildcard (IntersectVersionRanges v1 v2) =
IntersectVersionRanges (expandWildcard v1) (expandWildcard v2)
expandWildcard v = v
prop_foldVersionRange' :: VersionRange -> Bool
prop_foldVersionRange' range =
canonicalise range
== foldVersionRange' anyVersion thisVersion
laterVersion earlierVersion
orLaterVersion orEarlierVersion
(\v _ -> withinVersion v)
unionVersionRanges intersectVersionRanges
range
where
canonicalise (UnionVersionRanges (LaterVersion v)
(ThisVersion v')) | v == v'
= UnionVersionRanges (ThisVersion v')
(LaterVersion v)
canonicalise (UnionVersionRanges (EarlierVersion v)
(ThisVersion v')) | v == v'
= UnionVersionRanges (ThisVersion v')
(EarlierVersion v)
canonicalise (UnionVersionRanges v1 v2) =
UnionVersionRanges (canonicalise v1) (canonicalise v2)
canonicalise (IntersectVersionRanges v1 v2) =
IntersectVersionRanges (canonicalise v1) (canonicalise v2)
canonicalise v = v
prop_isAnyVersion1 :: VersionRange -> Version -> Property
prop_isAnyVersion1 range version =
......@@ -182,7 +226,7 @@ prop_isAnyVersion2 :: VersionRange -> Property
prop_isAnyVersion2 range =
isAnyVersion range ==>
foldVersionRange True (\_ -> False) (\_ -> False) (\_ -> False)
(\_ _ -> False) (\_ _ -> False) (\_ _ -> False)
(\_ _ -> False) (\_ _ -> False)
(simplifyVersionRange range)
prop_isNoVersion :: VersionRange -> Version -> Property
......@@ -202,7 +246,7 @@ prop_isSpecificVersion2 :: VersionRange -> Property
prop_isSpecificVersion2 range =
isJust version ==>
foldVersionRange Nothing Just (\_ -> Nothing) (\_ -> Nothing)
(\_ _ -> Nothing) (\_ _ -> Nothing) (\_ _ -> Nothing)
(\_ _ -> Nothing) (\_ _ -> Nothing)
(simplifyVersionRange range)
== version
......@@ -473,8 +517,7 @@ equivalentVersionRange vr1 vr2 =
in all (\v -> withinRange v vr1 == withinRange v vr2) probeVersions
where
versionsUsed = foldVersionRange [] (\x->[x]) (\x->[x]) (\x->[x])
(\x y -> [x,y]) (++) (++)
versionsUsed = foldVersionRange [] (\x->[x]) (\x->[x]) (\x->[x]) (++) (++)
intermediateVersions (v1:v2:vs) = v1 : intermediateVersion v1 v2
: intermediateVersions (v2:vs)
intermediateVersions vs = vs
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment