Unverified Commit 8874aba7 authored by Oleg Grenrus's avatar Oleg Grenrus Committed by GitHub
Browse files

Merge pull request #6612 from v0d1ch/6432-implement-Representable-container

6432 - Split RepoType into type with known VCS and other
parents 762805a9 391f9849
......@@ -228,7 +228,7 @@ instance Arbitrary Verbosity where
-------------------------------------------------------------------------------
instance Arbitrary RepoType where
arbitrary = elements knownRepoTypes
arbitrary = elements (KnownRepoType <$> knownRepoTypes)
instance Arbitrary RepoKind where
arbitrary = elements [RepoHead, RepoThis]
......
......@@ -106,6 +106,7 @@ module Distribution.PackageDescription (
SourceRepo(..),
RepoKind(..),
RepoType(..),
KnownRepoType (..),
knownRepoTypes,
emptySourceRepo,
......
......@@ -760,7 +760,7 @@ checkSourceRepos pkg =
PackageDistInexcusable
"The source-repository 'location' is a required field."
, check (repoType repo == Just CVS && isNothing (repoModule repo)) $
, check (repoType repo == Just (KnownRepoType CVS) && isNothing (repoModule repo)) $
PackageDistInexcusable
"For a CVS source-repository, the 'module' is a required field."
......@@ -1955,7 +1955,7 @@ checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do
else return []
where
repoDirnames = [ dirname | repo <- knownRepoTypes
, dirname <- repoTypeDirname repo ]
, dirname <- repoTypeDirname repo]
message = "When distributing packages it is encouraged to specify source "
++ "control information in the .cabal file using one or more "
++ "'source-repository' sections. See the Cabal user guide for "
......@@ -1963,17 +1963,15 @@ checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do
checkMissingVcsInfo _ _ = return []
repoTypeDirname :: RepoType -> [FilePath]
repoTypeDirname Darcs = ["_darcs"]
repoTypeDirname Git = [".git"]
repoTypeDirname SVN = [".svn"]
repoTypeDirname CVS = ["CVS"]
repoTypeDirname Mercurial = [".hg"]
repoTypeDirname GnuArch = [".arch-params"]
repoTypeDirname Bazaar = [".bzr"]
repoTypeDirname Monotone = ["_MTN"]
repoTypeDirname _ = []
repoTypeDirname :: KnownRepoType -> [FilePath]
repoTypeDirname Darcs = ["_darcs"]
repoTypeDirname Git = [".git"]
repoTypeDirname SVN = [".svn"]
repoTypeDirname CVS = ["CVS"]
repoTypeDirname Mercurial = [".hg"]
repoTypeDirname GnuArch = [".arch-params"]
repoTypeDirname Bazaar = [".bzr"]
repoTypeDirname Monotone = ["_MTN"]
-- ------------------------------------------------------------
-- * Checks involving files in the package
......
......@@ -5,6 +5,7 @@ module Distribution.Types.SourceRepo (
SourceRepo(..),
RepoKind(..),
RepoType(..),
KnownRepoType (..),
knownRepoTypes,
emptySourceRepo,
classifyRepoType,
......@@ -22,6 +23,7 @@ import Distribution.FieldGrammar.Described
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
import qualified Data.Map.Strict as M
-- ------------------------------------------------------------
-- * Source repos
......@@ -123,8 +125,26 @@ instance NFData RepoKind where rnf = genericRnf
-- 'SourceRepo' depend on the type of repo. The tools and methods used to
-- obtain and track the repo depend on the repo type.
--
data RepoType = Darcs | Git | SVN | CVS
| Mercurial | GnuArch | Bazaar | Monotone
data KnownRepoType = Darcs | Git | SVN | CVS
| Mercurial | GnuArch | Bazaar | Monotone
deriving (Eq, Generic, Ord, Read, Show, Typeable, Data, Enum, Bounded)
instance Binary KnownRepoType
instance Structured KnownRepoType
instance NFData KnownRepoType where rnf = genericRnf
instance Parsec KnownRepoType where
parsec = do
str <- P.munch1 isIdent
maybe
(P.unexpected $ "Could not parse KnownRepoType from " ++ str)
return
(M.lookup str knownRepoTypeMap)
instance Pretty KnownRepoType where
pretty = Disp.text . lowercase . show
data RepoType = KnownRepoType KnownRepoType
| OtherRepoType String
deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)
......@@ -132,11 +152,10 @@ instance Binary RepoType
instance Structured RepoType
instance NFData RepoType where rnf = genericRnf
knownRepoTypes :: [RepoType]
knownRepoTypes = [Darcs, Git, SVN, CVS
,Mercurial, GnuArch, Bazaar, Monotone]
knownRepoTypes :: [KnownRepoType]
knownRepoTypes = [minBound .. maxBound]
repoTypeAliases :: RepoType -> [String]
repoTypeAliases :: KnownRepoType -> [String]
repoTypeAliases Bazaar = ["bzr"]
repoTypeAliases Mercurial = ["hg"]
repoTypeAliases GnuArch = ["arch"]
......@@ -156,23 +175,30 @@ classifyRepoKind name = case lowercase name of
"this" -> RepoThis
_ -> RepoKindUnknown name
instance Pretty RepoType where
pretty (OtherRepoType other) = Disp.text other
pretty other = Disp.text (lowercase (show other))
instance Parsec RepoType where
parsec = classifyRepoType <$> P.munch1 isIdent
instance Described RepoType where
describe _ = reMunch1CS $ csAlphaNum <> csChar '_' <> csChar '-'
instance Pretty RepoType where
pretty (OtherRepoType other) = Disp.text other
pretty (KnownRepoType t) = pretty t
classifyRepoType :: String -> RepoType
classifyRepoType s =
fromMaybe (OtherRepoType s) $ lookup (lowercase s) repoTypeMap
where
repoTypeMap = [ (name, repoType')
| repoType' <- knownRepoTypes
, name <- prettyShow repoType' : repoTypeAliases repoType' ]
maybe
(OtherRepoType s)
KnownRepoType
(M.lookup (lowercase s) knownRepoTypeMap)
knownRepoTypeMap :: Map String KnownRepoType
knownRepoTypeMap =
M.fromList
[ (name, repoType')
| repoType' <- knownRepoTypes
, name <- prettyShow repoType' : repoTypeAliases repoType'
]
isIdent :: Char -> Bool
isIdent c = isAlphaNum c || c == '_' || c == '-'
......@@ -87,6 +87,7 @@ instance ToExpr PackageIdentifier
instance ToExpr PackageName where toExpr = defaultExprViaShow
instance ToExpr PkgconfigDependency where toExpr = defaultExprViaShow
instance ToExpr RepoKind
instance ToExpr KnownRepoType
instance ToExpr RepoType
instance ToExpr SetupBuildInfo
instance ToExpr SourceRepo
......
......@@ -317,7 +317,7 @@ GenericPackageDescription
repoModule = Nothing,
repoSubdir = Nothing,
repoTag = Nothing,
repoType = Just Git}],
repoType = Just (KnownRepoType Git)}],
specVersionRaw = Right (OrLaterVersion `mkVersion [1,8]`),
stability = "beta",
subLibraries = [],
......
......@@ -624,7 +624,7 @@ GenericPackageDescription
repoModule = Nothing,
repoSubdir = Nothing,
repoTag = Nothing,
repoType = Just Git}],
repoType = Just (KnownRepoType Git)}],
specVersionRaw = Left `mkVersion [2,6]`,
stability = "",
subLibraries = [],
......
......@@ -163,7 +163,7 @@ GenericPackageDescription
repoModule = Nothing,
repoSubdir = Nothing,
repoTag = Nothing,
repoType = Just Git}],
repoType = Just (KnownRepoType Git)}],
specVersionRaw = Right (OrLaterVersion `mkVersion [1,10]`),
stability = "",
subLibraries = [],
......
......@@ -652,7 +652,7 @@ GenericPackageDescription
repoModule = Nothing,
repoSubdir = Nothing,
repoTag = Nothing,
repoType = Just Git}],
repoType = Just (KnownRepoType Git)}],
specVersionRaw = Left `mkVersion [2,1]`,
stability = "",
subLibraries = [],
......
......@@ -187,7 +187,7 @@ GenericPackageDescription
repoModule = Nothing,
repoSubdir = Nothing,
repoTag = Nothing,
repoType = Just Git}],
repoType = Just (KnownRepoType Git)}],
specVersionRaw = Left `mkVersion [2,2]`,
stability = "",
subLibraries = [],
......
......@@ -165,7 +165,7 @@ GenericPackageDescription
repoModule = Nothing,
repoSubdir = Nothing,
repoTag = Nothing,
repoType = Just Git}],
repoType = Just (KnownRepoType Git)}],
specVersionRaw = Right (OrLaterVersion `mkVersion [1,10]`),
stability = "",
subLibraries = [],
......
......@@ -361,7 +361,7 @@ GenericPackageDescription
repoModule = Nothing,
repoSubdir = Nothing,
repoTag = Nothing,
repoType = Just Git}],
repoType = Just (KnownRepoType Git)}],
specVersionRaw = Left `mkVersion [2,1]`,
stability = "",
subLibraries = [],
......
......@@ -725,7 +725,7 @@ GenericPackageDescription
repoModule = Nothing,
repoSubdir = Nothing,
repoTag = Nothing,
repoType = Just Git}],
repoType = Just (KnownRepoType Git)}],
specVersionRaw = Right (OrLaterVersion `mkVersion [1,10]`),
stability = "",
subLibraries = [],
......
......@@ -382,7 +382,7 @@ GenericPackageDescription
repoModule = Nothing,
repoSubdir = Nothing,
repoTag = Nothing,
repoType = Just Git}],
repoType = Just (KnownRepoType Git)}],
specVersionRaw = Left `mkVersion [2,2]`,
stability = "",
subLibraries = [],
......
......@@ -161,7 +161,7 @@ GenericPackageDescription
repoModule = Nothing,
repoSubdir = Nothing,
repoTag = Nothing,
repoType = Just Git}],
repoType = Just (KnownRepoType Git)}],
specVersionRaw = Right (OrLaterVersion `mkVersion [1,10]`),
stability = "",
subLibraries = [],
......
......@@ -2132,7 +2132,7 @@ GenericPackageDescription
repoModule = Nothing,
repoSubdir = Nothing,
repoTag = Nothing,
repoType = Just Git}],
repoType = Just (KnownRepoType Git)}],
specVersionRaw = Right (OrLaterVersion `mkVersion [1,18]`),
stability = "",
subLibraries = [],
......
......@@ -508,7 +508,7 @@ GenericPackageDescription
repoModule = Nothing,
repoSubdir = Nothing,
repoTag = Nothing,
repoType = Just Git}],
repoType = Just (KnownRepoType Git)}],
specVersionRaw = Right (OrLaterVersion `mkVersion [1,10]`),
stability = "experimental",
subLibraries = [],
......
......@@ -194,7 +194,7 @@ GenericPackageDescription
repoModule = Nothing,
repoSubdir = Nothing,
repoTag = Nothing,
repoType = Just Git}],
repoType = Just (KnownRepoType Git)}],
specVersionRaw = Right (OrLaterVersion `mkVersion [1,6]`),
stability = "",
subLibraries = [],
......
......@@ -23,6 +23,6 @@ tests = testGroup "Distribution.Utils.Structured"
, testCase "SPDX.License" $ structureHash (Proxy :: Proxy License) @?= Fingerprint 0xd3d4a09f517f9f75 0xbc3d16370d5a853a
-- The difference is in encoding of newtypes
#if MIN_VERSION_base(4,7,0)
, testCase "LocalBuildInfo" $ structureHash (Proxy :: Proxy LocalBuildInfo) @?= Fingerprint 0x2b983b5312a676b1 0x3edb7b476c2fd11e
, testCase "LocalBuildInfo" $ structureHash (Proxy :: Proxy LocalBuildInfo) @?= Fingerprint 0xe2909c4dccc1d2de 0xa065d96aa3d0d915
#endif
]
......@@ -34,7 +34,7 @@ import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Types.SourceRepo
( RepoType(..) )
( RepoType(..), KnownRepoType (..) )
import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy)
import Distribution.Client.RebuildMonad
( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence )
......@@ -234,7 +234,7 @@ knownVCSs = Map.fromList [ (vcsRepoType vcs, vcs) | vcs <- vcss ]
vcsBzr :: VCS Program
vcsBzr =
VCS {
vcsRepoType = Bazaar,
vcsRepoType = KnownRepoType Bazaar,
vcsProgram = bzrProgram,
vcsCloneRepo,
vcsSyncRepos
......@@ -280,7 +280,7 @@ bzrProgram = (simpleProgram "bzr") {
vcsDarcs :: VCS Program
vcsDarcs =
VCS {
vcsRepoType = Darcs,
vcsRepoType = KnownRepoType Darcs,
vcsProgram = darcsProgram,
vcsCloneRepo,
vcsSyncRepos
......@@ -325,7 +325,7 @@ darcsProgram = (simpleProgram "darcs") {
vcsGit :: VCS Program
vcsGit =
VCS {
vcsRepoType = Git,
vcsRepoType = KnownRepoType Git,
vcsProgram = gitProgram,
vcsCloneRepo,
vcsSyncRepos
......@@ -418,7 +418,7 @@ gitProgram = (simpleProgram "git") {
vcsHg :: VCS Program
vcsHg =
VCS {
vcsRepoType = Mercurial,
vcsRepoType = KnownRepoType Mercurial,
vcsProgram = hgProgram,
vcsCloneRepo,
vcsSyncRepos
......@@ -464,7 +464,7 @@ hgProgram = (simpleProgram "hg") {
vcsSvn :: VCS Program
vcsSvn =
VCS {
vcsRepoType = SVN,
vcsRepoType = KnownRepoType SVN,
vcsProgram = svnProgram,
vcsCloneRepo,
vcsSyncRepos
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment