Merge pull request #6593 from phadej/described-flagname-reponame

Add Described FlagName and RepoName instances

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

@@ -2,21 +2,24 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Test.QuickCheck.Instances.Cabal () where
 
-import Control.Applicative (liftA2)
-import Data.Char (isAlphaNum, isDigit)
-import Data.List (intercalate)
+import Control.Applicative        (liftA2)
+import Data.Char                  (isAlphaNum, isDigit)
+import Data.List                  (intercalate)
+import Distribution.Utils.Generic (lowercase)
 import Test.QuickCheck
 
+import Distribution.Simple.Flag                 (Flag (..))
 import Distribution.SPDX
-import Distribution.Version
+import Distribution.System
 import Distribution.Types.Dependency
-import Distribution.Types.UnqualComponentName
-import Distribution.Simple.Flag (Flag (..))
+import Distribution.Types.Flag                  (FlagAssignment, FlagName, mkFlagName, mkFlagAssignment)
 import Distribution.Types.LibraryName
 import Distribution.Types.PackageName
+import Distribution.Types.SourceRepo
+import Distribution.Types.UnqualComponentName
 import Distribution.Types.VersionRange.Internal
-import Distribution.System
 import Distribution.Verbosity
+import Distribution.Version
 
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative (pure, (<$>), (<*>))
@@ -167,10 +170,14 @@ instance Arbitrary LibraryName where
         [ LSubLibName <$> arbitrary
         , pure LMainLibName
         ]
-    
+
     shrink (LSubLibName _) = [LMainLibName]
     shrink _               = []
 
+-------------------------------------------------------------------------------
+-- option flags
+-------------------------------------------------------------------------------
+
 instance Arbitrary a => Arbitrary (Flag a) where
     arbitrary = arbitrary1
 
@@ -184,13 +191,37 @@ instance Arbitrary1 Flag where
         else frequency [ (1, pure NoFlag)
                        , (3, Flag <$> genA) ]
 
+-------------------------------------------------------------------------------
+-- GPD flags
+-------------------------------------------------------------------------------
+
+instance Arbitrary FlagName where
+    arbitrary = mkFlagName <$> flagident
+      where
+        flagident   = lowercase <$> shortListOf1 5 (elements flagChars)
+                      `suchThat` (("-" /=) . take 1)
+        flagChars   = "-_" ++ ['a'..'z']
+
+instance Arbitrary FlagAssignment where
+    arbitrary = mkFlagAssignment <$> arbitrary
+
 -------------------------------------------------------------------------------
 -- Verbosity
 -------------------------------------------------------------------------------
 
 instance Arbitrary Verbosity where
     arbitrary = elements [minBound..maxBound]
 
+-------------------------------------------------------------------------------
+-- SourceRepo
+-------------------------------------------------------------------------------
+
+instance Arbitrary RepoType where
+    arbitrary = elements knownRepoTypes
+
+instance Arbitrary RepoKind where
+    arbitrary = elements [RepoHead, RepoThis]
+
 -------------------------------------------------------------------------------
 -- SPDX
 -------------------------------------------------------------------------------

Cabal/Distribution/Types/Flag.hs

@@ -27,6 +27,7 @@ import Distribution.Utils.Generic (lowercase)
 
 import Distribution.Parsec
 import Distribution.Pretty
+import Distribution.FieldGrammar.Described
 
 import qualified Data.Map as Map
 import qualified Text.PrettyPrint as Disp
@@ -107,6 +108,12 @@ instance Parsec FlagName where
         lead = P.satisfy (\c ->  isAlphaNum c || c == '_')
         rest = P.munch (\c -> isAlphaNum c ||  c == '_' || c == '-')
 
+instance Described FlagName where
+    describe _ = lead <> rest
+      where
+        lead = RECharSet $ csAlphaNum <> fromString "_"
+        rest = reMunchCS $ csAlphaNum <> fromString "_-"
+
 -- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to
 -- 'Bool' flag values. It represents the flags chosen by the user or
 -- discovered during configuration. For example @--flags=foo --flags=-bar@

Cabal/tests/UnitTests/Distribution/Described.hs

@@ -18,6 +18,7 @@ import Distribution.Pretty                 (prettyShow)
 import qualified Distribution.Utils.CharSet as CS
 
 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)
@@ -34,6 +35,7 @@ tests = testGroup "Described"
     , testDescribed (Proxy :: Proxy PackageName)
     , testDescribed (Proxy :: Proxy Version)
     , testDescribed (Proxy :: Proxy VersionRange)
+    , testDescribed (Proxy :: Proxy FlagName)
     ]
 
 -------------------------------------------------------------------------------

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

@@ -29,9 +29,8 @@ import GHC.Generics (Generic)
 import Distribution.Compat.Binary (Binary)
 import Distribution.Utils.Structured (Structured)
 
-
 data ReportLevel = NoReports | AnonymousReports | DetailedReports
-  deriving (Eq, Ord, Enum, Show, Generic)
+  deriving (Eq, Ord, Enum, Bounded, Show, Generic)
 
 instance Binary ReportLevel
 instance Structured ReportLevel

cabal-install/Distribution/Client/Types.hs

@@ -1,8 +1,8 @@
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 -----------------------------------------------------------------------------
 -- |
@@ -77,6 +77,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS
 
 import Distribution.Pretty (Pretty (..))
 import Distribution.Parsec (Parsec (..))
+import Distribution.FieldGrammar.Described (Described (..), reMunch1CS, csAlphaNum)
 
 
 newtype Username = Username { unUsername :: String }
@@ -292,6 +293,9 @@ instance Parsec RepoName where
     parsec = RepoName <$>
         P.munch1 (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.')
 
+instance Described RepoName where
+    describe _ = reMunch1CS $ csAlphaNum <> "_-."
+
 type UnresolvedPkgLoc = PackageLocation (Maybe FilePath)
 
 type ResolvedPkgLoc = PackageLocation FilePath
@@ -363,7 +367,7 @@ instance Parsec RemoteRepo where
     parsec = do
         name <- parsec
         _ <- P.char ':'
-        uriStr <- P.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~")
+        uriStr <- P.munch1 (\c -> isAlphaNum c || c `elem` ("+-=._/*()@'$:;&!?~" :: String))
         uri <- maybe (fail $ "Cannot parse URI:" ++ uriStr) return (parseAbsoluteURI uriStr)
         return RemoteRepo
             { remoteRepoName           = name

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

@@ -16,17 +16,55 @@ import Prelude ()
 
 import Distribution.Types.PackageVersionConstraint
 
-import Distribution.Simple.Setup
 import Distribution.Simple.InstallDirs
+import Distribution.Simple.Setup
 
 import Distribution.Utils.NubList
 
-import Distribution.Client.Types
-import Distribution.Client.IndexUtils.Timestamp
+import Distribution.Client.BuildReports.Types            (ReportLevel (..))
+import Distribution.Client.CmdInstall.ClientInstallFlags (InstallMethod)
+import Distribution.Client.IndexUtils.Timestamp          (IndexState (..), Timestamp, epochTimeToTimestamp)
+import Distribution.Client.InstallSymlink                (OverwritePolicy)
+import Distribution.Client.Types                         (RepoName (..), WriteGhcEnvironmentFilesPolicy)
 
 import Test.QuickCheck
 import Test.QuickCheck.Instances.Cabal ()
 
+import Network.URI (URI (..), URIAuth (..), isUnreserved)
+
+-- note: there are plenty of instances defined in ProjectConfig test file.
+-- they should be moved here or into Cabal-quickcheck
+
+-------------------------------------------------------------------------------
+-- Non-Cabal instances
+-------------------------------------------------------------------------------
+
+instance Arbitrary URI where
+    arbitrary =
+      URI <$> elements ["file:", "http:", "https:"]
+          <*> (Just <$> arbitrary)
+          <*> (('/':) <$> arbitraryURIToken)
+          <*> (('?':) <$> arbitraryURIToken)
+          <*> pure ""
+
+instance Arbitrary URIAuth where
+    arbitrary =
+      URIAuth <$> pure ""   -- no password as this does not roundtrip
+              <*> arbitraryURIToken
+              <*> arbitraryURIPort
+
+arbitraryURIToken :: Gen String
+arbitraryURIToken =
+    shortListOf1 6 (elements (filter isUnreserved ['\0'..'\255']))
+
+arbitraryURIPort :: Gen String
+arbitraryURIPort =
+    oneof [ pure "", (':':) <$> shortListOf1 4 (choose ('0','9')) ]
+
+-------------------------------------------------------------------------------
+-- cabal-install (and Cabal) types
+-------------------------------------------------------------------------------
+
 adjustSize :: (Int -> Int) -> Gen a -> Gen a
 adjustSize adjust gen = sized (\n -> resize (adjust n) gen)
 
@@ -108,3 +146,16 @@ instance Arbitrary WriteGhcEnvironmentFilesPolicy where
 
 arbitraryFlag :: Gen a -> Gen (Flag a)
 arbitraryFlag = liftArbitrary
+
+instance Arbitrary RepoName where
+    arbitrary = RepoName <$> listOf1 (elements
+        [ c | c <- [ '\NUL' .. '\255' ], isAlphaNum c || c `elem` "_-."])
+
+instance Arbitrary ReportLevel where
+    arbitrary = arbitraryBoundedEnum
+
+instance Arbitrary OverwritePolicy where
+    arbitrary = arbitraryBoundedEnum
+
+instance Arbitrary InstallMethod where
+    arbitrary = arbitraryBoundedEnum

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

@@ -1,6 +1,5 @@
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-deprecations #-}
 module UnitTests.Distribution.Client.Described where
 
 import Distribution.Client.Compat.Prelude
@@ -19,6 +18,7 @@ import Distribution.Pretty                 (prettyShow)
 import qualified Distribution.Utils.CharSet as CS
 
 import Distribution.Client.IndexUtils.Timestamp (IndexState, Timestamp)
+import Distribution.Client.Types                (RepoName)
 
 import qualified RERE         as RE
 import qualified RERE.CharSet as RE
@@ -30,6 +30,7 @@ tests :: TestTree
 tests = testGroup "Described"
     [ testDescribed (Proxy :: Proxy Timestamp)
     , testDescribed (Proxy :: Proxy IndexState)
+    , testDescribed (Proxy :: Proxy RepoName)
     ]
 
 -------------------------------------------------------------------------------

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

@@ -11,7 +11,7 @@ import Control.Applicative
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.List
-import Data.Char (isAlphaNum)
+import Network.URI (URI)
 
 import Distribution.Deprecated.ParseUtils
 import Distribution.Deprecated.Text as Text
@@ -24,20 +24,16 @@ import Distribution.Version
 import Distribution.Simple.Compiler
 import Distribution.Simple.Setup
 import Distribution.Simple.InstallDirs
-import Distribution.Simple.Utils
 import Distribution.Simple.Program.Types
 import Distribution.Simple.Program.Db
 import Distribution.Types.PackageVersionConstraint
 
 import Distribution.Client.Types
 import Distribution.Client.CmdInstall.ClientInstallFlags
-import Distribution.Client.InstallSymlink
 import Distribution.Client.Dependency.Types
-import Distribution.Client.BuildReports.Types
 import Distribution.Client.Targets
 import Distribution.Client.SourceRepo
 import Distribution.Utils.NubList
-import Network.URI
 
 import Distribution.Solver.Types.PackageConstraint
 import Distribution.Solver.Types.ConstraintSource
@@ -357,12 +353,6 @@ arbitraryGlobLikeStr = outerTerm
     braces s   = "{" ++ s ++ "}"
 
 
-instance Arbitrary OverwritePolicy where
-    arbitrary = arbitraryBoundedEnum
-
-instance Arbitrary InstallMethod where
-    arbitrary = arbitraryBoundedEnum
-
 instance Arbitrary ClientInstallFlags where
     arbitrary =
       ClientInstallFlags
@@ -563,9 +553,6 @@ projectConfigConstraintSource =
 instance Arbitrary ProjectConfigProvenance where
     arbitrary = elements [Implicit, Explicit "cabal.project"]
 
-instance Arbitrary FlagAssignment where
-    arbitrary = mkFlagAssignment <$> arbitrary
-
 instance Arbitrary PackageConfig where
     arbitrary =
       PackageConfig
@@ -794,12 +781,6 @@ instance f ~ [] => Arbitrary (SourceRepositoryPackage f) where
           (x1, ShortToken x2, fmap ShortToken x3, fmap ShortToken x4, fmap ShortToken x5)
         ]
 
-instance Arbitrary RepoType where
-    arbitrary = elements knownRepoTypes
-
-instance Arbitrary ReportLevel where
-    arbitrary = elements [NoReports .. DetailedReports]
-
 instance Arbitrary CompilerFlavor where
     arbitrary = elements knownCompilerFlavors
 
@@ -837,10 +818,6 @@ instance Arbitrary LocalRepo where
         <*> elements ["/tmp/foo", "/tmp/bar"] -- TODO: generate valid absolute paths
         <*> arbitrary
 
-instance Arbitrary RepoName where
-    arbitrary = RepoName <$> shortListOf1 10 (elements repochars) where
-        repochars = [ c | c <- [ '\NUL' .. '\255' ], isAlphaNum c || c `elem` ".-_" ]
-
 instance Arbitrary UserConstraintScope where
     arbitrary = oneof [ UserQualified <$> arbitrary <*> arbitrary
                       , UserAnySetupQualifier <$> arbitrary
@@ -869,13 +846,6 @@ instance Arbitrary PackageProperty where
 instance Arbitrary OptionalStanza where
     arbitrary = elements [minBound..maxBound]
 
-instance Arbitrary FlagName where
-    arbitrary = mkFlagName <$> flagident
-      where
-        flagident   = lowercase <$> shortListOf1 5 (elements flagChars)
-                      `suchThat` (("-" /=) . take 1)
-        flagChars   = "-_" ++ ['a'..'z']
-
 instance Arbitrary PreSolver where
     arbitrary = elements [minBound..maxBound]
 
@@ -942,25 +912,3 @@ instance Arbitrary OptimisationLevel where
 
 instance Arbitrary DebugInfoLevel where
     arbitrary = elements [minBound..maxBound]
-
-instance Arbitrary URI where
-    arbitrary =
-      URI <$> elements ["file:", "http:", "https:"]
-          <*> (Just <$> arbitrary)
-          <*> (('/':) <$> arbitraryURIToken)
-          <*> (('?':) <$> arbitraryURIToken)
-          <*> pure ""
-
-instance Arbitrary URIAuth where
-    arbitrary =
-      URIAuth <$> pure ""   -- no password as this does not roundtrip
-              <*> arbitraryURIToken
-              <*> arbitraryURIPort
-
-arbitraryURIToken :: Gen String
-arbitraryURIToken =
-    shortListOf1 6 (elements (filter isUnreserved ['\0'..'\255']))
-
-arbitraryURIPort :: Gen String
-arbitraryURIPort =
-    oneof [ pure "", (':':) <$> shortListOf1 4 (choose ('0','9')) ]