Merge pull request #6766 from phadej/described-package-version-constrain

Add Described PackageVersionConstraint
haskell · May 8, 2020 · ae3486a · ae3486a
2 parents 72a3962 + 2c27ddf
commit ae3486a
Show file tree

Hide file tree

Showing 4 changed files with 68 additions and 23 deletions.
diff --git a/Cabal/Cabal-quickcheck/src/Test/QuickCheck/Instances/Cabal.hs b/Cabal/Cabal-quickcheck/src/Test/QuickCheck/Instances/Cabal.hs
@@ -9,20 +9,22 @@ import Distribution.Utils.Generic (lowercase)
 import Test.QuickCheck
 
 import Distribution.CabalSpecVersion
-import Distribution.Simple.Flag                 (Flag (..))
+import Distribution.ModuleName
+import Distribution.Parsec.Newtypes
+import Distribution.Simple.Flag                    (Flag (..))
 import Distribution.SPDX
 import Distribution.System
 import Distribution.Types.Dependency
-import Distribution.Types.Flag                  (FlagAssignment, FlagName, mkFlagName, mkFlagAssignment)
+import Distribution.Types.Flag
+       (FlagAssignment, FlagName, mkFlagAssignment, mkFlagName)
 import Distribution.Types.LibraryName
 import Distribution.Types.PackageName
+import Distribution.Types.PackageVersionConstraint
 import Distribution.Types.SourceRepo
 import Distribution.Types.UnqualComponentName
-import Distribution.ModuleName
 import Distribution.Types.VersionRange.Internal
 import Distribution.Verbosity
 import Distribution.Version
-import Distribution.Parsec.Newtypes
 
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative (pure, (<$>), (<*>))
@@ -169,6 +171,20 @@ instance Arbitrary Dependency where
         | (pn', vr', lb') <- shrink (pn, vr, lb)
         ]
 
+-------------------------------------------------------------------------------
+-- PackageVersionConstraint
+-------------------------------------------------------------------------------
+
+instance Arbitrary PackageVersionConstraint where
+    arbitrary = PackageVersionConstraint
+        <$> arbitrary
+        <*> arbitrary
+
+    shrink (PackageVersionConstraint pn vr) =
+        [ PackageVersionConstraint pn' vr'
+        | (pn', vr') <- shrink (pn, vr)
+        ]
+
 -------------------------------------------------------------------------------
 -- System
 -------------------------------------------------------------------------------

diff --git a/Cabal/Distribution/Types/PackageVersionConstraint.hs b/Cabal/Distribution/Types/PackageVersionConstraint.hs
@@ -10,7 +10,10 @@ import Prelude ()
 import Distribution.Parsec
 import Distribution.Pretty
 import Distribution.Types.PackageName
-import Distribution.Types.VersionRange
+import Distribution.Types.PackageId
+import Distribution.Types.Version
+import Distribution.Types.VersionRange.Internal
+import Distribution.FieldGrammar.Described
 
 import qualified Distribution.Compat.CharParsing as P
 import           Text.PrettyPrint                ((<+>))
@@ -28,13 +31,41 @@ instance Structured PackageVersionConstraint
 instance NFData PackageVersionConstraint where rnf = genericRnf
 
 instance Pretty PackageVersionConstraint where
-  pretty (PackageVersionConstraint name ver) = pretty name <+> pretty ver
+  -- Cannot do: PackageVersionConstraint have to be parseable
+  -- as Dependency, due roundtrip problems. (e.g. talking to old ./Setup).
+  --
+  -- pretty (PackageVersionConstraint name (ThisVersion ver)) =
+  --     pretty (PackageIdentifier name ver)
+  pretty (PackageVersionConstraint name ver) =
+      pretty name <+> pretty ver
 
+-- |
+--
+-- >>> simpleParsec "foo" :: Maybe PackageVersionConstraint
+-- Just (PackageVersionConstraint (PackageName "foo") (OrLaterVersion (mkVersion [0])))
+--
+-- >>> simpleParsec "foo >=2.0" :: Maybe PackageVersionConstraint
+-- Just (PackageVersionConstraint (PackageName "foo") (OrLaterVersion (mkVersion [2,0])))
+--
+-- >>> simpleParsec "foo-2.0" :: Maybe PackageVersionConstraint
+-- Just (PackageVersionConstraint (PackageName "foo") (ThisVersion (mkVersion [2,0])))
+--
 instance Parsec PackageVersionConstraint where
   parsec = do
-      name <- parsec
-      P.spaces
-      ver <- parsec <|> return anyVersion
-      P.spaces
-      return (PackageVersionConstraint name ver)
+      PackageIdentifier name ver <- parsec
+      if ver == nullVersion
+      then do
+          P.spaces
+          vr <- parsec <|> return anyVersion
+          P.spaces
+          return (PackageVersionConstraint name vr)
+      else
+          pure (PackageVersionConstraint name (thisVersion ver))
 
+instance Described PackageVersionConstraint where
+    describe _ = describe (Proxy :: Proxy PackageName) <> REUnion
+        [ fromString "-" <> describe (Proxy :: Proxy Version)
+        -- TODO: change to RESpaces when -any and -none are removed
+        -- Related https://github.com/haskell/cabal/issues/6760
+        , RESpaces1 <> describe (Proxy :: Proxy VersionRange)
+        ]
diff --git a/Cabal/tests/UnitTests/Distribution/Described.hs b/Cabal/tests/UnitTests/Distribution/Described.hs
@@ -11,18 +11,20 @@ import Test.QuickCheck       (Arbitrary (..), Gen, Property, choose, counterexam
 import Test.Tasty            (TestTree, testGroup)
 import Test.Tasty.QuickCheck (testProperty)
 
-import Distribution.FieldGrammar.Described (Described (..), GrammarRegex (..), reComma, reSpacedComma, reSpacedList)
+import Distribution.FieldGrammar.Described
+       (Described (..), GrammarRegex (..), reComma, reSpacedComma, reSpacedList)
 import Distribution.Parsec                 (eitherParsec)
 import Distribution.Pretty                 (prettyShow)
 
 import qualified Distribution.Utils.CharSet as CS
 
-import Distribution.ModuleName         (ModuleName)
-import Distribution.Types.Dependency   (Dependency)
-import Distribution.Types.Flag         (FlagName)
-import Distribution.Types.PackageName  (PackageName)
-import Distribution.Types.Version      (Version)
-import Distribution.Types.VersionRange (VersionRange)
+import Distribution.ModuleName                     (ModuleName)
+import Distribution.Types.Dependency               (Dependency)
+import Distribution.Types.Flag                     (FlagName)
+import Distribution.Types.PackageName              (PackageName)
+import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint)
+import Distribution.Types.Version                  (Version)
+import Distribution.Types.VersionRange             (VersionRange)
 
 import qualified RERE         as RE
 import qualified RERE.CharSet as RE
@@ -34,6 +36,7 @@ tests :: TestTree
 tests = testGroup "Described"
     [ testDescribed (Proxy :: Proxy Dependency)
     , testDescribed (Proxy :: Proxy PackageName)
+    , testDescribed (Proxy :: Proxy PackageVersionConstraint)
     , testDescribed (Proxy :: Proxy Version)
     , testDescribed (Proxy :: Proxy VersionRange)
     , testDescribed (Proxy :: Proxy FlagName)

diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs
@@ -20,8 +20,6 @@ module UnitTests.Distribution.Client.ArbitraryInstances (
 import Distribution.Client.Compat.Prelude
 import Prelude ()
 
-import Distribution.Types.PackageVersionConstraint
-
 import Distribution.Simple.InstallDirs
 import Distribution.Simple.Setup
 
@@ -139,9 +137,6 @@ instance Arbitrary ShortToken where
 arbitraryShortToken :: Gen String
 arbitraryShortToken = getShortToken <$> arbitrary
 
-instance Arbitrary PackageVersionConstraint where
-    arbitrary = PackageVersionConstraint <$> arbitrary <*> arbitrary
-
 instance (Arbitrary a, Ord a) => Arbitrary (NubList a) where
     arbitrary = toNubList <$> arbitrary
     shrink xs = [ toNubList [] | (not . null) (fromNubList xs) ]