haskell · phadej · Apr 27, 2020 · Apr 24, 2020
diff --git a/Cabal/Cabal-quickcheck/src/Test/QuickCheck/Instances/Cabal.hs b/Cabal/Cabal-quickcheck/src/Test/QuickCheck/Instances/Cabal.hs
@@ -63,6 +63,7 @@ instance Arbitrary Version where
                             ,(1, return 0xfffd)
                             ,(1, return 0xfffe) -- max fitting into packed W64
                             ,(1, return 0xffff)
+                            ,(1, return 999999998)
                             ,(1, return 999999999)
                             ,(1, return 0x10000)]
       return (mkVersion branch)
@@ -84,7 +85,7 @@ instance Arbitrary VersionRange where
         , (1, fmap earlierVersion arbitrary)
         , (1, fmap orEarlierVersion arbitrary)
         , (1, fmap orEarlierVersion' arbitrary)
-        , (1, fmap withinVersion arbitrary)
+        , (1, fmap withinVersion arbitraryV)
         , (1, fmap majorBoundVersion arbitrary)
         ] ++ if n == 0 then [] else
         [ (2, liftA2 unionVersionRanges     verRangeExp2 verRangeExp2)
@@ -93,18 +94,19 @@ instance Arbitrary VersionRange where
         where
           verRangeExp2 = verRangeExp (n `div` 2)
 
+      arbitraryV :: Gen Version
+      arbitraryV = arbitrary `suchThat` \v -> all (< 999999999) (versionNumbers v)
+
       orLaterVersion'   v =
         unionVersionRanges (LaterVersion v)   (ThisVersion v)
       orEarlierVersion' v =
         unionVersionRanges (EarlierVersion v) (ThisVersion v)
 
-  shrink AnyVersion                   = []
   shrink (ThisVersion v)              = map ThisVersion (shrink v)
   shrink (LaterVersion v)             = map LaterVersion (shrink v)
   shrink (EarlierVersion v)           = map EarlierVersion (shrink v)
   shrink (OrLaterVersion v)           = LaterVersion v : map OrLaterVersion (shrink v)
   shrink (OrEarlierVersion v)         = EarlierVersion v : map OrEarlierVersion (shrink v)
-  shrink (WildcardVersion v)          = map WildcardVersion ( shrink v)
   shrink (MajorBoundVersion v)        = map MajorBoundVersion (shrink v)
   shrink (UnionVersionRanges a b)     = a : b : map (uncurry UnionVersionRanges) (shrink (a, b))
   shrink (IntersectVersionRanges a b) = a : b : map (uncurry IntersectVersionRanges) (shrink (a, b))

diff --git a/Cabal/Distribution/Types/Dependency.hs b/Cabal/Distribution/Types/Dependency.hs
@@ -15,7 +15,8 @@ import Distribution.Compat.Prelude
 import Prelude ()
 
 import Distribution.Version
-       (VersionRange, anyVersion, notThisVersion, simplifyVersionRange, thisVersion)
+       (VersionRange, anyVersion,notThisVersion, simplifyVersionRange, thisVersion)
+import Distribution.Types.VersionRange (isAnyVersionLight)
 
 import Distribution.CabalSpecVersion
 import Distribution.Compat.CharParsing        (char, spaces)
@@ -76,8 +77,12 @@ instance Structured Dependency
 instance NFData Dependency where rnf = genericRnf
 
 instance Pretty Dependency where
-    pretty (Dependency name ver sublibs) = withSubLibs (pretty name) <+> pretty ver
+    pretty (Dependency name ver sublibs) = withSubLibs (pretty name) <+> pver
       where
+        -- TODO: change to isAnyVersion after #6736
+        pver | isAnyVersionLight ver = PP.empty
+             | otherwise             = pretty ver
+
         withSubLibs doc
             | sublibs == mainLib = doc
             | otherwise          = doc <<>> PP.colon <<>> PP.braces prettySublibs
@@ -90,13 +95,13 @@ instance Pretty Dependency where
 -- |
 --
 -- >>> simpleParsec "mylib:sub" :: Maybe Dependency
--- Just (Dependency (PackageName "mylib") AnyVersion (fromList [LSubLibName (UnqualComponentName "sub")]))
+-- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromList [LSubLibName (UnqualComponentName "sub")]))
 --
 -- >>> simpleParsec "mylib:{sub1,sub2}" :: Maybe Dependency
--- Just (Dependency (PackageName "mylib") AnyVersion (fromList [LSubLibName (UnqualComponentName "sub1"),LSubLibName (UnqualComponentName "sub2")]))
+-- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromList [LSubLibName (UnqualComponentName "sub1"),LSubLibName (UnqualComponentName "sub2")]))
 --
 -- >>> simpleParsec "mylib:{ sub1 , sub2 }" :: Maybe Dependency
--- Just (Dependency (PackageName "mylib") AnyVersion (fromList [LSubLibName (UnqualComponentName "sub1"),LSubLibName (UnqualComponentName "sub2")]))
+-- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromList [LSubLibName (UnqualComponentName "sub1"),LSubLibName (UnqualComponentName "sub2")]))
 --
 -- >>> simpleParsec "mylib:{ sub1 , sub2 } ^>= 42" :: Maybe Dependency
 -- Just (Dependency (PackageName "mylib") (MajorBoundVersion (mkVersion [42])) (fromList [LSubLibName (UnqualComponentName "sub1"),LSubLibName (UnqualComponentName "sub2")]))
@@ -105,9 +110,9 @@ instance Pretty Dependency where
 -- Just (Dependency (PackageName "mylib") (MajorBoundVersion (mkVersion [42])) (fromList []))
 --
 -- >>> traverse_ print (map simpleParsec ["mylib:mylib", "mylib:{mylib}", "mylib:{mylib,sublib}" ] :: [Maybe Dependency])
--- Just (Dependency (PackageName "mylib") AnyVersion (fromList [LMainLibName]))
--- Just (Dependency (PackageName "mylib") AnyVersion (fromList [LMainLibName]))
--- Just (Dependency (PackageName "mylib") AnyVersion (fromList [LMainLibName,LSubLibName (UnqualComponentName "sublib")]))
+-- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromList [LMainLibName]))
+-- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromList [LMainLibName]))
+-- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromList [LMainLibName,LSubLibName (UnqualComponentName "sublib")]))
 --
 -- Spaces around colon are not allowed:
 --
@@ -117,7 +122,7 @@ instance Pretty Dependency where
 -- Sublibrary syntax is accepted since @cabal-version: 3.0@
 --
 -- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe Dependency]
--- [Nothing,Just (Dependency (PackageName "mylib") AnyVersion (fromList [LSubLibName (UnqualComponentName "sub")]))]
+-- [Nothing,Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromList [LSubLibName (UnqualComponentName "sub")]))]
 --
 instance Parsec Dependency where
     parsec = do
@@ -157,7 +162,7 @@ mainLib = Set.singleton LMainLibName
 instance Described Dependency where
     describe _ = REAppend
         [ RENamed "pkg-name" (describe (Proxy :: Proxy PackageName))
-        , REOpt $ 
+        , REOpt $
                reChar ':'
             <> REUnion
                 [ reUnqualComponent
@@ -168,7 +173,7 @@ instance Described Dependency where
                     , REMunch reSpacedComma reUnqualComponent
                     , RESpaces
                     , reChar '}'
-                    ] 
+                    ]
                 ]
         -- TODO: RESpaces1 should be just RESpaces, but we are able
         -- to generate non-parseable strings without mandatory space

diff --git a/Cabal/Distribution/Types/ExeDependency.hs b/Cabal/Distribution/Types/ExeDependency.hs
@@ -14,10 +14,10 @@ import Distribution.Pretty
 import Distribution.Types.ComponentName
 import Distribution.Types.PackageName
 import Distribution.Types.UnqualComponentName
-import Distribution.Version                   (VersionRange, anyVersion)
+import Distribution.Version                   (VersionRange, anyVersion, isAnyVersion)
 
 import qualified Distribution.Compat.CharParsing as P
-import           Text.PrettyPrint                (text, (<+>))
+import qualified Text.PrettyPrint as PP
 
 -- | Describes a dependency on an executable from a package
 --
@@ -33,14 +33,17 @@ instance NFData ExeDependency where rnf = genericRnf
 
 instance Pretty ExeDependency where
   pretty (ExeDependency name exe ver) =
-    (pretty name <<>> text ":" <<>> pretty exe) <+> pretty ver
+      pretty name <<>> PP.colon <<>> pretty exe PP.<+> pver
+    where
+      pver | isAnyVersion ver = PP.empty
+           | otherwise        = pretty ver
 
 -- | 
 --
 -- Examples
 --
 -- >>> simpleParsec "happy:happy" :: Maybe ExeDependency
--- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") AnyVersion)
+-- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [0])))
 --
 -- >>> simpleParsec "happy:happy >= 1.19.12" :: Maybe ExeDependency
 -- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [1,19,12])))

diff --git a/Cabal/Distribution/Types/PkgconfigDependency.hs b/Cabal/Distribution/Types/PkgconfigDependency.hs
@@ -30,8 +30,8 @@ instance Structured PkgconfigDependency
 instance NFData PkgconfigDependency where rnf = genericRnf
 
 instance Pretty PkgconfigDependency where
-  pretty (PkgconfigDependency name ver) =
-    pretty name <+> pretty ver
+    pretty (PkgconfigDependency name PcAnyVersion) = pretty name
+    pretty (PkgconfigDependency name ver)          = pretty name <+> pretty ver
 
 instance Parsec PkgconfigDependency where
     parsec = do

diff --git a/Cabal/Distribution/Types/PkgconfigVersionRange.hs b/Cabal/Distribution/Types/PkgconfigVersionRange.hs
@@ -18,6 +18,7 @@ import Distribution.Parsec
 import Distribution.Pretty
 import Distribution.Types.PkgconfigVersion
 import Distribution.Types.Version
+import Distribution.Types.VersionInterval
 import Distribution.Types.VersionRange
 
 import qualified Data.ByteString.Char8           as BS8
@@ -142,10 +143,19 @@ versionToPkgconfigVersion :: Version -> PkgconfigVersion
 versionToPkgconfigVersion = PkgconfigVersion . BS8.pack . prettyShow
 
 versionRangeToPkgconfigVersionRange :: VersionRange -> PkgconfigVersionRange
-versionRangeToPkgconfigVersionRange = foldVersionRange
-    anyPkgconfigVersion
-    (PcThisVersion . versionToPkgconfigVersion)
-    (PcLaterVersion . versionToPkgconfigVersion)
-    (PcEarlierVersion . versionToPkgconfigVersion)
-    PcUnionVersionRanges
-    PcIntersectVersionRanges
+versionRangeToPkgconfigVersionRange vr
+    | isAnyVersion vr
+    = PcAnyVersion
+    | otherwise
+    = case asVersionIntervals vr of
+        []     -> PcEarlierVersion (PkgconfigVersion (BS8.pack "0"))
+        (i:is) -> foldl (\r j -> PcUnionVersionRanges r (conv j)) (conv i) is
+  where
+    conv (LowerBound v b, NoUpperBound)   = convL v b
+    conv (LowerBound v b, UpperBound u c) = PcIntersectVersionRanges (convL v b) (convU u c)
+
+    convL v ExclusiveBound = PcLaterVersion (versionToPkgconfigVersion v)
+    convL v InclusiveBound = PcOrLaterVersion (versionToPkgconfigVersion v)
+
+    convU v ExclusiveBound = PcEarlierVersion (versionToPkgconfigVersion v)
+    convU v InclusiveBound = PcOrEarlierVersion (versionToPkgconfigVersion v)
diff --git a/Cabal/Distribution/Types/VersionInterval.hs b/Cabal/Distribution/Types/VersionInterval.hs
@@ -26,7 +26,7 @@ import Distribution.Compat.Prelude
 import Control.Exception (assert)
 
 import Distribution.Types.Version
-import Distribution.Types.VersionRange
+import Distribution.Types.VersionRange.Internal
 
 -- NonEmpty
 import qualified Prelude (foldr1)
@@ -200,15 +200,18 @@ withinIntervals v (VersionIntervals intervals) = any withinInterval intervals
 -- | 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
+toVersionIntervals = cataVersionRange alg where
+    alg (ThisVersionF v)                = chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)
+    alg (LaterVersionF v)               = chkIvl (LowerBound v ExclusiveBound, NoUpperBound)
+    alg (OrLaterVersionF v)             = chkIvl (LowerBound v InclusiveBound, NoUpperBound)
+    alg (EarlierVersionF v)
+        | isVersion0 v                  = VersionIntervals []
+        | otherwise                     = chkIvl (minLowerBound,               UpperBound v ExclusiveBound)
+    alg (OrEarlierVersionF v)           = chkIvl (minLowerBound,               UpperBound v InclusiveBound)
+    alg (MajorBoundVersionF v)          = chkIvl (LowerBound v InclusiveBound, UpperBound (majorUpperBound v) ExclusiveBound)
+    alg (UnionVersionRangesF v1 v2)     = unionVersionIntervals v1 v2
+    alg (IntersectVersionRangesF v1 v2) = intersectVersionIntervals v1 v2
+
     chkIvl interval = checkInvariant (VersionIntervals [interval])
 
 -- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression
@@ -223,9 +226,6 @@ fromVersionIntervals (VersionIntervals intervals) =
     interval (LowerBound v  InclusiveBound)
              (UpperBound v' InclusiveBound) | v == v'
                  = thisVersion v
-    interval (LowerBound v  InclusiveBound)
-             (UpperBound v' ExclusiveBound) | isWildcardRange v v'
-                 = withinVersion v
     interval l u = lowerBound l `intersectVersionRanges'` upperBound u
 
     lowerBound (LowerBound v InclusiveBound)

diff --git a/Cabal/Distribution/Types/VersionRange.hs b/Cabal/Distribution/Types/VersionRange.hs
@@ -30,6 +30,8 @@ module Distribution.Types.VersionRange (
     embedVersionRange,
 
     -- ** Utilities
+    isAnyVersion,
+    isAnyVersionLight,
     wildcardUpperBound,
     majorUpperBound,
     isWildcardRange,
@@ -38,8 +40,8 @@ module Distribution.Types.VersionRange (
 
 import Distribution.Compat.Prelude
 import Distribution.Types.Version
+import Distribution.Types.VersionInterval
 import Distribution.Types.VersionRange.Internal
-import Distribution.Utils.Generic
 import Prelude ()
 
 -- | Fold over the basic syntactic structure of a 'VersionRange'.
@@ -57,25 +59,19 @@ foldVersionRange :: a                         -- ^ @\"-any\"@ version
                  -> (a -> a -> a)             -- ^ @\"_ || _\"@ union
                  -> (a -> a -> a)             -- ^ @\"_ && _\"@ intersection
                  -> VersionRange -> a
-foldVersionRange anyv this later earlier union intersect = fold
+foldVersionRange _any this later earlier union intersect = fold
   where
     fold = cataVersionRange alg
 
-    alg AnyVersionF                     = anyv
     alg (ThisVersionF v)                = this v
     alg (LaterVersionF v)               = later v
     alg (OrLaterVersionF v)             = union (this v) (later v)
     alg (EarlierVersionF v)             = earlier v
     alg (OrEarlierVersionF v)           = union (this v) (earlier v)
-    alg (WildcardVersionF v)            = fold (wildcard v)
     alg (MajorBoundVersionF v)          = fold (majorBound v)
     alg (UnionVersionRangesF v1 v2)     = union v1 v2
     alg (IntersectVersionRangesF v1 v2) = intersect v1 v2
 
-    wildcard v = intersectVersionRanges
-                   (orLaterVersion v)
-                   (earlierVersion (wildcardUpperBound v))
-
     majorBound v = intersectVersionRanges
                      (orLaterVersion v)
                      (earlierVersion (majorUpperBound v))
@@ -122,16 +118,35 @@ withinRange v = foldVersionRange
                    (||)
                    (&&)
 
+-- | 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)] -> v == version0
+    _                                             -> False
+
+-- A fast and non-precise version of 'isAnyVersion',
+-- returns 'True' only for @>= 0@ 'VersionRange's.
+--
+-- /Do not use/. The "VersionIntervals don't destroy MajorBoundVersion"
+-- https://github.com/haskell/cabal/pull/6736 pull-request
+-- will change 'simplifyVersionRange' to properly preserve semantics.
+-- Then we can use it to normalise 'VersionRange's in tests.
+--
+isAnyVersionLight :: VersionRange -> Bool
+isAnyVersionLight (OrLaterVersion v) = v == version0
+isAnyVersionLight _vr                = False
+
 ----------------------------
 -- Wildcard range utilities
 --
 
--- | @since 2.2
-wildcardUpperBound :: Version -> Version
-wildcardUpperBound = alterVersion $
-    \lowerBound -> case unsnoc lowerBound of
-        Nothing      -> []
-        Just (xs, x) -> xs ++ [x + 1]
 
 isWildcardRange :: Version -> Version -> Bool
 isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2)