Commit 391f9849 authored by Sasa Bogicevic's avatar Sasa Bogicevic 💬

6432 - Split RepoType into type with known VCS and other

parent cf257427
......@@ -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
......
......@@ -5,7 +5,7 @@ import Distribution.Client.Get
import Distribution.Types.PackageId
import Distribution.Types.PackageName
import Distribution.Types.SourceRepo (SourceRepo (..), emptySourceRepo, RepoKind (..), RepoType (..))
import Distribution.Types.SourceRepo (SourceRepo (..), emptySourceRepo, RepoKind (..), RepoType (..), KnownRepoType (..))
import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..))
import Distribution.Verbosity as Verbosity
import Distribution.Version
......@@ -120,7 +120,7 @@ testNoRepoLocation = do
repo = (emptySourceRepo RepoHead) {
repoType = Just repotype
}
repotype = Darcs
repotype = KnownRepoType Darcs
testSelectRepoKind :: Assertion
......@@ -165,7 +165,7 @@ testRepoDestinationExists =
where
pkgrepos = [(pkgidfoo, [repo])]
repo = (emptySourceRepo RepoHead) {
repoType = Just Darcs,
repoType = Just (KnownRepoType Darcs),
repoLocation = Just ""
}
......@@ -175,11 +175,11 @@ testGitFetchFailed =
withTestDir verbosity "repos" $ \tmpdir -> do
let srcdir = tmpdir </> "src"
repo = (emptySourceRepo RepoHead) {
repoType = Just Git,
repoType = Just (KnownRepoType Git),
repoLocation = Just srcdir
}
repo' = SourceRepositoryPackage
{ srpType = Git
{ srpType = KnownRepoType Git
, srpLocation = srcdir
, srpTag = Nothing
, srpBranch = Nothing
......@@ -195,7 +195,7 @@ testNetworkGitClone :: Assertion
testNetworkGitClone =
withTestDir verbosity "repos" $ \tmpdir -> do
let repo1 = (emptySourceRepo RepoHead) {
repoType = Just Git,
repoType = Just (KnownRepoType Git),
repoLocation = Just "https://github.com/haskell/zlib.git"
}
clonePackagesFromSourceRepo verbosity tmpdir Nothing
......@@ -203,7 +203,7 @@ testNetworkGitClone =
assertFileContains (tmpdir </> "zlib1/zlib.cabal") ["name:", "zlib"]
let repo2 = (emptySourceRepo RepoHead) {
repoType = Just Git,
repoType = Just (KnownRepoType Git),
repoLocation = Just (tmpdir </> "zlib1")
}
clonePackagesFromSourceRepo verbosity tmpdir Nothing
......@@ -211,7 +211,7 @@ testNetworkGitClone =
assertFileContains (tmpdir </> "zlib2/zlib.cabal") ["name:", "zlib"]
let repo3 = (emptySourceRepo RepoHead) {
repoType = Just Git,
repoType = Just (KnownRepoType Git),
repoLocation = Just (tmpdir </> "zlib1"),
repoTag = Just "0.5.0.0"
}
......
......@@ -96,6 +96,7 @@ instance ToExpr RepoKind
instance ToExpr RepoName
instance ToExpr ReportLevel
instance ToExpr RepoType
instance ToExpr KnownRepoType
instance ToExpr ShortText
instance ToExpr SourceRepo
instance ToExpr StrongFlags
......
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