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

Distribution/PackageDescription/Check.hs

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

Distribution/Version.hs

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

tests/Test/Distribution/Version.hs

@@ -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 ".*"