Merge pull request #6778 from phadej/described-relax-deps

Add Described PackageIdentifier and RelaxDeps

Cabal/Cabal-quickcheck/src/Test/QuickCheck/Instances/Cabal.hs

@@ -15,9 +15,9 @@ import Distribution.Simple.Flag                    (Flag (..))
 import Distribution.SPDX
 import Distribution.System
 import Distribution.Types.Dependency
-import Distribution.Types.Flag
-       (FlagAssignment, FlagName, mkFlagAssignment, mkFlagName)
+import Distribution.Types.Flag                     (FlagAssignment, FlagName, mkFlagAssignment, mkFlagName)
 import Distribution.Types.LibraryName
+import Distribution.Types.PackageId
 import Distribution.Types.PackageName
 import Distribution.Types.PackageVersionConstraint
 import Distribution.Types.SourceRepo
@@ -41,7 +41,7 @@ instance Arbitrary SpecVersion where
     arbitrary = fmap SpecVersion arbitrary
 
 -------------------------------------------------------------------------------
--- PackageName
+-- PackageName and PackageIdentifier
 -------------------------------------------------------------------------------
 
 instance Arbitrary PackageName where
@@ -51,10 +51,16 @@ instance Arbitrary PackageName where
                         `suchThat` (not . all isDigit)
         packageChars  = filter isAlphaNum ['\0'..'\127']
 
+instance Arbitrary PackageIdentifier where
+    arbitrary = PackageIdentifier <$> arbitrary <*> arbitrary
+
+    shrink (PackageIdentifier pn vr) = uncurry PackageIdentifier <$> shrink (pn, vr)
+
 -------------------------------------------------------------------------------
 -- Version
 -------------------------------------------------------------------------------
 
+-- | Does *NOT* generate 'nullVersion'
 instance Arbitrary Version where
   arbitrary = do
       branch <- smallListOf1 $

Cabal/Distribution/Types/PackageId.hs

-{-# LANGUAGE DeriveDataTypeable         #-}
-{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric      #-}
 module Distribution.Types.PackageId
   ( PackageIdentifier(..)
   , PackageId
@@ -8,10 +8,11 @@ module Distribution.Types.PackageId
 import Distribution.Compat.Prelude
 import Prelude ()
 
-import Distribution.Parsec      (Parsec (..), simpleParsec)
+import Distribution.FieldGrammar.Described (Described (..))
+import Distribution.Parsec                 (Parsec (..), simpleParsec)
 import Distribution.Pretty
 import Distribution.Types.PackageName
-import Distribution.Version           (Version, nullVersion)
+import Distribution.Version                (Version, nullVersion)
 
 import qualified Data.List.NonEmpty              as NE
 import qualified Distribution.Compat.CharParsing as P
@@ -36,6 +37,9 @@ instance Pretty PackageIdentifier where
     | v == nullVersion = pretty n -- if no version, don't show version.
     | otherwise        = pretty n <<>> Disp.char '-' <<>> pretty v
 
+instance Described PackageIdentifier where
+    describe _ = describe (Proxy :: Proxy PackageName) <> fromString "-" <> describe (Proxy :: Proxy Version)
+
 -- |
 --
 -- >>> simpleParsec "foo-bar-0" :: Maybe PackageIdentifier

Cabal/tests/UnitTests/Distribution/Described.hs

@@ -21,6 +21,7 @@ import qualified Distribution.Utils.CharSet as CS
 import Distribution.ModuleName                     (ModuleName)
 import Distribution.Types.Dependency               (Dependency)
 import Distribution.Types.Flag                     (FlagName)
+import Distribution.Types.PackageId                (PackageIdentifier)
 import Distribution.Types.PackageName              (PackageName)
 import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint)
 import Distribution.Types.Version                  (Version)
@@ -36,6 +37,7 @@ tests :: TestTree
 tests = testGroup "Described"
     [ testDescribed (Proxy :: Proxy Dependency)
     , testDescribed (Proxy :: Proxy PackageName)
+    , testDescribed (Proxy :: Proxy PackageIdentifier)
     , testDescribed (Proxy :: Proxy PackageVersionConstraint)
     , testDescribed (Proxy :: Proxy Version)
     , testDescribed (Proxy :: Proxy VersionRange)

cabal-install/Distribution/Client/Types/AllowNewer.hs

@@ -14,16 +14,16 @@ module Distribution.Client.Types.AllowNewer (
 import Distribution.Client.Compat.Prelude
 import Prelude ()
 
-import Distribution.Types.PackageId   (PackageId, PackageIdentifier (..))
-import Distribution.Types.PackageName (PackageName, mkPackageName)
-import Distribution.Types.Version     (nullVersion)
+import Distribution.FieldGrammar.Described (Described (..), GrammarRegex (..))
+import Distribution.Parsec                 (CabalParsing, Parsec (..), parsecLeadingCommaNonEmpty)
+import Distribution.Pretty                 (Pretty (..))
+import Distribution.Types.PackageId        (PackageId, PackageIdentifier (..))
+import Distribution.Types.PackageName      (PackageName, mkPackageName)
+import Distribution.Types.Version          (nullVersion)
 
 import qualified Distribution.Compat.CharParsing as P
 import qualified Text.PrettyPrint                as Disp
 
-import Distribution.Parsec (CabalParsing, Parsec (..), parsecLeadingCommaList)
-import Distribution.Pretty (Pretty (..))
-
 -- $setup
 -- >>> import Distribution.Parsec
 
@@ -99,6 +99,18 @@ instance Pretty RelaxedDep where
 instance Parsec RelaxedDep where
     parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP)
 
+instance Described RelaxedDep where
+    describe _ =
+        REOpt (describeRelaxDepScope <> fromString ":" <> REOpt (fromString "^"))
+        <> describe (Proxy :: Proxy RelaxDepSubject)
+      where
+        describeRelaxDepScope = REUnion
+            [ fromString "*"
+            , fromString "all"
+            , RENamed "package-name" (describe (Proxy :: Proxy PackageName))
+            , RENamed "package-id" (describe (Proxy :: Proxy PackageIdentifier))
+            ]
+
 -- continuation after *
 relaxedDepStarP :: CabalParsing m => m RelaxedDep
 relaxedDepStarP =
@@ -136,6 +148,13 @@ instance Parsec RelaxDepSubject where
               then RelaxDepSubjectAll
               else RelaxDepSubjectPkg pn
 
+instance Described RelaxDepSubject where
+    describe _ = REUnion
+        [ fromString "*"
+        , fromString "all"
+        , RENamed "package-name" (describe (Proxy :: Proxy PackageName))
+        ]
+
 instance Pretty RelaxDeps where
   pretty rd | not (isRelaxDeps rd) = Disp.text "none"
   pretty (RelaxDepsSome pkgs)      = Disp.fsep .
@@ -164,17 +183,28 @@ instance Pretty RelaxDeps where
 --
 -- >>> simpleParsec ", all" :: Maybe RelaxDeps
 -- Just RelaxDepsAll
--- 
+--
+-- >>> simpleParsec "" :: Maybe RelaxDeps
+-- Nothing
+--
 instance Parsec RelaxDeps where
     parsec = do
-        xs <- parsecLeadingCommaList parsec
-        pure $ case xs of
+        xs <- parsecLeadingCommaNonEmpty parsec
+        pure $ case toList xs of
             [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]
                 -> RelaxDepsAll
             [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)]
-                | pn == mkPackageName "none"                                
+                | pn == mkPackageName "none"
                 -> mempty
-            _   -> mkRelaxDepSome xs
+            xs' -> mkRelaxDepSome xs'
+
+instance Described RelaxDeps where
+    describe _ = REUnion
+        [ fromString "*"
+        , fromString "all"
+        , fromString "none"
+        , RECommaNonEmpty (describe (Proxy :: Proxy RelaxedDep))
+        ]
 
 instance Binary RelaxDeps
 instance Binary RelaxDepMod
@@ -205,7 +235,7 @@ mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps
 mkRelaxDepSome xs
     | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs
     = RelaxDepsAll
-    
+
     | otherwise
     = RelaxDepsSome xs
 

cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs

@@ -27,11 +27,12 @@ import Distribution.Utils.NubList
 
 import Distribution.Client.BuildReports.Types            (ReportLevel (..))
 import Distribution.Client.CmdInstall.ClientInstallFlags (InstallMethod)
-import Distribution.Client.IndexUtils.ActiveRepos        (ActiveRepos (..), ActiveRepoEntry (..), CombineStrategy (..))
+import Distribution.Client.IndexUtils.ActiveRepos        (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..))
 import Distribution.Client.IndexUtils.IndexState         (RepoIndexState (..), TotalIndexState, makeTotalIndexState)
 import Distribution.Client.IndexUtils.Timestamp          (Timestamp, epochTimeToTimestamp)
 import Distribution.Client.InstallSymlink                (OverwritePolicy)
 import Distribution.Client.Types                         (RepoName (..), WriteGhcEnvironmentFilesPolicy)
+import Distribution.Client.Types.AllowNewer
 
 import Test.QuickCheck
 import Test.QuickCheck.Instances.Cabal ()
@@ -215,3 +216,33 @@ instance Arbitrary ActiveRepoEntry where
 instance Arbitrary CombineStrategy where
     arbitrary = arbitraryBoundedEnum
     shrink    = shrinkBoundedEnum
+
+
+instance Arbitrary AllowNewer where
+    arbitrary = AllowNewer <$> arbitrary
+
+instance Arbitrary AllowOlder where
+    arbitrary = AllowOlder <$> arbitrary
+
+instance Arbitrary RelaxDeps where
+    arbitrary = oneof [ pure mempty
+                      , mkRelaxDepSome <$> shortListOf1 3 arbitrary
+                      , pure RelaxDepsAll
+                      ]
+
+instance Arbitrary RelaxDepMod where
+    arbitrary = elements [RelaxDepModNone, RelaxDepModCaret]
+
+instance Arbitrary RelaxDepScope where
+    arbitrary = oneof [ pure RelaxDepScopeAll
+                      , RelaxDepScopePackage <$> arbitrary
+                      , RelaxDepScopePackageId <$> arbitrary
+                      ]
+
+instance Arbitrary RelaxDepSubject where
+    arbitrary = oneof [ pure RelaxDepSubjectAll
+                      , RelaxDepSubjectPkg <$> arbitrary
+                      ]
+
+instance Arbitrary RelaxedDep where
+    arbitrary = RelaxedDep <$> arbitrary <*> arbitrary <*> arbitrary

cabal-install/tests/UnitTests/Distribution/Client/Described.hs

@@ -11,8 +11,7 @@ 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)
 
@@ -22,6 +21,7 @@ import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepos)
 import Distribution.Client.IndexUtils.IndexState  (RepoIndexState, TotalIndexState)
 import Distribution.Client.IndexUtils.Timestamp   (Timestamp)
 import Distribution.Client.Types                  (RepoName)
+import Distribution.Client.Types.AllowNewer       (RelaxDepSubject, RelaxDeps, RelaxedDep)
 
 import qualified RERE         as RE
 import qualified RERE.CharSet as RE
@@ -36,6 +36,9 @@ tests = testGroup "Described"
     , testDescribed (Proxy :: Proxy TotalIndexState)
     , testDescribed (Proxy :: Proxy RepoName)
     , testDescribed (Proxy :: Proxy ActiveRepos)
+    , testDescribed (Proxy :: Proxy RelaxDepSubject)
+    , testDescribed (Proxy :: Proxy RelaxedDep)
+    , testDescribed (Proxy :: Proxy RelaxDeps)
     ]
 
 -------------------------------------------------------------------------------

cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs

@@ -843,35 +843,6 @@ instance Arbitrary OnlyConstrained where
                       , pure OnlyConstrainedNone
                       ]
 
-instance Arbitrary AllowNewer where
-    arbitrary = AllowNewer <$> arbitrary
-
-instance Arbitrary AllowOlder where
-    arbitrary = AllowOlder <$> arbitrary
-
-instance Arbitrary RelaxDeps where
-    arbitrary = oneof [ pure mempty
-                      , mkRelaxDepSome <$> shortListOf1 3 arbitrary
-                      , pure RelaxDepsAll
-                      ]
-
-instance Arbitrary RelaxDepMod where
-    arbitrary = elements [RelaxDepModNone, RelaxDepModCaret]
-
-instance Arbitrary RelaxDepScope where
-    arbitrary = oneof [ pure RelaxDepScopeAll
-                      , RelaxDepScopePackage <$> arbitrary
-                      , RelaxDepScopePackageId <$> (PackageIdentifier <$> arbitrary <*> arbitrary)
-                      ]
-
-instance Arbitrary RelaxDepSubject where
-    arbitrary = oneof [ pure RelaxDepSubjectAll
-                      , RelaxDepSubjectPkg <$> arbitrary
-                      ]
-
-instance Arbitrary RelaxedDep where
-    arbitrary = RelaxedDep <$> arbitrary <*> arbitrary <*> arbitrary
-
 instance Arbitrary ProfDetailLevel where
     arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ]