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

Fix QA check on version range syntax to detect use of ()'s

The problem was that we do the QA check on using the new version range
syntax after parsing. The new syntax allows ()'s but previously the
code threw them away in the parser stage. We now retain them in the
AST and deal with them appropriately. This now allows the QA check to
be accurate and detect things like "build-depends: base (>= 4.2)".
parent 9a6702ad
......@@ -91,8 +91,12 @@ import Distribution.Version
import Distribution.Package
( PackageName(PackageName), packageName, packageVersion
, Dependency(..) )
import Distribution.Text
( display )
( display, disp )
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<>), (<+>))
import qualified Language.Haskell.Extension as Extension
import Language.Haskell.Extension (Extension(..))
import System.FilePath
......@@ -694,7 +698,7 @@ checkCabalVersion pkg =
PackageDistInexcusable $
"The package uses full version-range expressions "
++ "in a 'build-depends' field: "
++ commaSep (map display versionRangeExpressions)
++ commaSep (map displayRawDependency versionRangeExpressions)
++ ". To use this new syntax the package needs to specify at least "
++ "'cabal-version: >= 1.8'. Alternatively, if broader compatibility "
++ "is important, then convert to conjunctive normal form, and use "
......@@ -716,7 +720,7 @@ checkCabalVersion pkg =
PackageDistInexcusable $
"The package uses full version-range expressions "
++ "in a 'tested-with' field: "
++ commaSep (map display testedWithVersionRangeExpressions)
++ commaSep (map displayRawDependency testedWithVersionRangeExpressions)
++ ". To use this new syntax the package needs to specify at least "
++ "'cabal-version: >= 1.8'."
......@@ -806,20 +810,24 @@ checkCabalVersion pkg =
versionRangeExpressions =
[ dep | dep@(Dependency _ vr) <- buildDepends pkg
, versionExpDepth vr > 2 ]
, usesNewVersionRangeSyntax vr ]
testedWithVersionRangeExpressions =
[ Dependency (PackageName (display compiler)) vr
| (compiler, vr) <- testedWith pkg
, versionExpDepth vr > 2 ]
versionExpDepth :: VersionRange -> Int
versionExpDepth = foldVersionRange'
1 (const 1)
(const 1) (const 1)
(const 1) (const 1)
(const (const 1))
(+) (+)
, usesNewVersionRangeSyntax vr ]
usesNewVersionRangeSyntax :: VersionRange -> Bool
usesNewVersionRangeSyntax =
(> 2) -- uses the new syntax if depth is more than 2
. foldVersionRange'
(1 :: Int)
(const 1)
(const 1) (const 1)
(const 1) (const 1)
(const (const 1))
(+) (+)
(const 3) -- uses new ()'s syntax
depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg
, usesWildcardSyntax vr ]
......@@ -835,7 +843,7 @@ checkCabalVersion pkg =
(const False) (const False)
(const False) (const False)
(\_ _ -> True) -- the wildcard case
(||) (||)
(||) (||) id
eliminateWildcardSyntax =
foldVersionRange'
......@@ -843,7 +851,7 @@ checkCabalVersion pkg =
laterVersion earlierVersion
orLaterVersion orEarlierVersion
(\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v'))
intersectVersionRanges unionVersionRanges
intersectVersionRanges unionVersionRanges id
compatLicenses = [ GPL Nothing, LGPL Nothing, BSD3, BSD4
, PublicDomain, AllRightsReserved, OtherLicense ]
......@@ -882,6 +890,39 @@ checkCabalVersion pkg =
, ConstrainedClassMethods
]
-- | A variation on the normal 'Text' instance, shows any ()'s in the original
-- textual syntax. We need to show these otherwise it's confusing to users when
-- we complain of their presense but do not pretty print them!
--
displayRawVersionRange :: VersionRange -> String
displayRawVersionRange =
Disp.render
. fst
. foldVersionRange' -- precedence:
-- All the same as the usual pretty printer, except for the parens
( 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)) -- parens
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
displayRawDependency :: Dependency -> String
displayRawDependency (Dependency pkg vr) =
display pkg ++ " " ++ displayRawVersionRange vr
-- ------------------------------------------------------------
-- * Checks on the GenericPackageDescription
-- ------------------------------------------------------------
......
......@@ -113,8 +113,9 @@ data VersionRange
| LaterVersion Version -- > version (NB. not >=)
| EarlierVersion Version -- < version
| WildcardVersion Version -- == ver.* (same as >= ver && < ver+1)
| UnionVersionRanges VersionRange VersionRange
| IntersectVersionRanges VersionRange VersionRange
| UnionVersionRanges VersionRange VersionRange
| IntersectVersionRanges VersionRange VersionRange
| VersionRangeParens VersionRange -- just '(exp)' parentheses syntax
deriving (Show,Read,Eq)
{-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}
......@@ -253,7 +254,8 @@ foldVersionRange anyv this later earlier union intersect = fold
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))
......@@ -275,9 +277,10 @@ foldVersionRange' :: a -- ^ @\"-any\"@ version
-- 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 = fold
wildcard union intersect parens = fold
where
fold AnyVersion = anyv
fold (ThisVersion v) = this v
......@@ -296,6 +299,7 @@ foldVersionRange' anyv this later earlier orLater orEarlier
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?
......@@ -676,6 +680,7 @@ instance Text VersionRange where
(\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))
id
where dispWild (Version b _) =
Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))
......@@ -720,7 +725,7 @@ instance Text VersionRange where
(Parse.char ')' >> Parse.skipSpaces)
(do a <- p
Parse.skipSpaces
return a)
return (VersionRangeParens a))
digits = do
first <- Parse.satisfy Char.isDigit
......
......@@ -4,6 +4,9 @@ module Test.Distribution.Version (properties) where
import Distribution.Version
import Distribution.Text
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<>), (<+>))
import Test.QuickCheck
import Test.QuickCheck.Utils
import qualified Test.Laws as Laws
......@@ -71,7 +74,9 @@ properties =
, property prop_intersect_union_distributive
-- parsing an pretty printing
, property prop_parse_disp
, property prop_parse_disp1
, property prop_parse_disp2
, property prop_parse_disp3
]
instance Arbitrary Version where
......@@ -103,6 +108,7 @@ instance Arbitrary VersionRange where
, (1, liftM orEarlierVersion arbitrary)
, (1, liftM orEarlierVersion' arbitrary)
, (1, liftM withinVersion arbitrary)
, (2, liftM VersionRangeParens arbitrary)
] ++ if n == 0 then [] else
[ (2, liftM2 unionVersionRanges verRangeExp2 verRangeExp2)
, (2, liftM2 intersectVersionRanges verRangeExp2 verRangeExp2)
......@@ -194,6 +200,7 @@ prop_foldVersionRange range =
UnionVersionRanges (expandWildcard v1) (expandWildcard v2)
expandWildcard (IntersectVersionRanges v1 v2) =
IntersectVersionRanges (expandWildcard v1) (expandWildcard v2)
expandWildcard (VersionRangeParens v) = expandWildcard v
expandWildcard v = v
......@@ -204,7 +211,7 @@ prop_foldVersionRange' range =
laterVersion earlierVersion
orLaterVersion orEarlierVersion
(\v _ -> withinVersion v)
unionVersionRanges intersectVersionRanges
unionVersionRanges intersectVersionRanges id
range
where
canonicalise (UnionVersionRanges (LaterVersion v)
......@@ -219,6 +226,7 @@ prop_foldVersionRange' range =
UnionVersionRanges (canonicalise v1) (canonicalise v2)
canonicalise (IntersectVersionRanges v1 v2) =
IntersectVersionRanges (canonicalise v1) (canonicalise v2)
canonicalise (VersionRangeParens v) = canonicalise v
canonicalise v = v
......@@ -280,6 +288,7 @@ prop_simplifyVersionRange2' r r' =
r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==>
r `equivalentVersionRange` r'
--FIXME: see equivalentVersionRange for details
prop_simplifyVersionRange2'' :: VersionRange -> VersionRange -> Property
prop_simplifyVersionRange2'' r r' =
r /= r' && r `equivalentVersionRange` r' ==>
......@@ -332,7 +341,7 @@ instance Arbitrary VersionIntervals' where
doesNotTouch (UpperBound u ub) (LowerBound l lb) =
u < l
|| (u == l && ub == ExclusiveBound && lb == ExclusiveBound)
fixEmpty (LowerBound l _, UpperBound u _)
| l == u = (LowerBound l InclusiveBound, UpperBound u InclusiveBound)
fixEmpty i = i
......@@ -510,6 +519,12 @@ prop_equivalentVersionRange range range' version =
equivalentVersionRange range range' && range /= range' ==>
withinRange version range == withinRange version range'
--FIXME: this is wrong. consider version ranges "<=1" and "<1.0"
-- this algorithm cannot distinguish them because there is no version
-- that is included by one that is excluded by the other.
-- Alternatively we must reconsider the semantics of '<' and '<='
-- in version ranges / version intervals. Perhaps the canonical
-- representation should use just < v and interpret "<= v" as "< v.0".
equivalentVersionRange :: VersionRange -> VersionRange -> Bool
equivalentVersionRange vr1 vr2 =
let allVersionsUsed = nub (sort (versionsUsed vr1 ++ versionsUsed vr2))
......@@ -556,9 +571,9 @@ adjacentVersions (Version v1 _) (Version v2 _) = v1 ++ [0] == v2
-- Parsing and pretty printing
--
prop_parse_disp :: VersionRange -> Bool
prop_parse_disp vr =
simpleParse (display vr) == Just (canonicalise vr)
prop_parse_disp1 :: VersionRange -> Bool
prop_parse_disp1 vr =
fmap stripParens (simpleParse (display vr)) == Just (canonicalise vr)
where
canonicalise = swizzle . swap
......@@ -574,6 +589,7 @@ prop_parse_disp vr =
UnionVersionRanges (swizzle v1) (swizzle v2)
swizzle (IntersectVersionRanges v1 v2) =
IntersectVersionRanges (swizzle v1) (swizzle v2)
swizzle (VersionRangeParens v) = swizzle v
swizzle v = v
isOrLaterVersion (ThisVersion v) (LaterVersion v') = v == v'
......@@ -587,4 +603,42 @@ prop_parse_disp vr =
laterVersion earlierVersion
orLaterVersion orEarlierVersion
(\v _ -> withinVersion v)
unionVersionRanges intersectVersionRanges
unionVersionRanges intersectVersionRanges id
stripParens :: VersionRange -> VersionRange
stripParens (VersionRangeParens v) = stripParens v
stripParens (UnionVersionRanges v1 v2) =
UnionVersionRanges (stripParens v1) (stripParens v2)
stripParens (IntersectVersionRanges v1 v2) =
IntersectVersionRanges (stripParens v1) (stripParens v2)
stripParens v = v
prop_parse_disp2 :: VersionRange -> Bool
prop_parse_disp2 vr =
fmap (display :: VersionRange -> String) (simpleParse (display vr))
== Just (display vr)
prop_parse_disp3 :: VersionRange -> Bool
prop_parse_disp3 vr =
fmap displayRaw (simpleParse (display vr)) == Just (display vr)
displayRaw :: VersionRange -> String
displayRaw =
Disp.render
. foldVersionRange' -- precedence:
-- All the same as the usual pretty printer, except for the parens
( Disp.text "-any")
(\v -> Disp.text "==" <> disp v)
(\v -> Disp.char '>' <> disp v)
(\v -> Disp.char '<' <> disp v)
(\v -> Disp.text ">=" <> disp v)
(\v -> Disp.text "<=" <> disp v)
(\v _ -> Disp.text "==" <> dispWild v)
(\r1 r2 -> r1 <+> Disp.text "||" <+> r2)
(\r1 r2 -> r1 <+> Disp.text "&&" <+> r2)
(\r -> Disp.parens r) -- parens
where
dispWild (Version b _) =
Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))
<> Disp.text ".*"
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