Commit f354a7bd authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Add support for specifying source repos in .cabal files

Ticket #58. Does not yet include checking.
parent bf4ed2e4
......@@ -85,13 +85,16 @@ module Distribution.PackageDescription (
GenericPackageDescription(..),
Flag(..), FlagName(..), FlagAssignment,
CondTree(..), ConfVar(..), Condition(..),
-- * Source repositories
SourceRepo(..), RepoKind(..), RepoType(..),
) where
import Data.List (nub)
import Data.Monoid (Monoid(mempty, mappend))
import Text.PrettyPrint.HughesPJ as Disp
import qualified Distribution.Compat.ReadP as Parse
import qualified Data.Char as Char (isAlphaNum)
import qualified Data.Char as Char (isAlphaNum, toLower)
import Distribution.Package
( PackageName(PackageName), PackageIdentifier(PackageIdentifier)
......@@ -102,7 +105,7 @@ import Distribution.License (License(AllRightsReserved))
import Distribution.Compiler (CompilerFlavor)
import Distribution.System (OS, Arch)
import Distribution.Text
( Text(..) )
( Text(..), display )
import Language.Haskell.Extension (Extension)
-- -----------------------------------------------------------------------------
......@@ -127,6 +130,7 @@ data PackageDescription
testedWith :: [(CompilerFlavor,VersionRange)],
homepage :: String,
pkgUrl :: String,
sourceRepos :: [SourceRepo],
synopsis :: String, -- ^A one-line summary of this package
description :: String, -- ^A more verbose description of this package
category :: String,
......@@ -166,6 +170,7 @@ emptyPackageDescription
buildDepends = [],
homepage = "",
pkgUrl = "",
sourceRepos = [],
synopsis = "",
description = "",
category = "",
......@@ -408,6 +413,138 @@ hcOptions hc bi = [ opt | (hc',opts) <- options bi
, hc' == hc
, opt <- opts ]
-- ------------------------------------------------------------
-- * Source repos
-- ------------------------------------------------------------
-- | Information about the source revision control system for a package.
--
-- When specifying a repo it is useful to know the meaning or intention of the
-- information as doing so enables automation. There are two obvious common
-- purposes: one is to find the repo for the latest development version, the
-- other is to find the repo for this specific release. The 'ReopKind'
-- specifies which one we mean (or another custom one).
--
-- A package can specify one or the other kind or both. Most will specify just
-- a head repo but some may want to specify a repo to reconstruct the sources
-- for this package release.
--
-- The required information is the 'RepoType' which tells us if it's using
-- 'Darcs', 'Git' for example. The 'repoLocation' and other details are
-- interpreted according to the repo type.
--
data SourceRepo = SourceRepo {
-- | The kind of repo. This field is required.
repoKind :: RepoKind,
-- | The type of the source repository system for this repo, eg 'Darcs' or
-- 'Git'. This field is required.
repoType :: Maybe RepoType,
-- | The location of the repository. For most 'RepoType's this is a URL.
-- This field is required.
repoLocation :: Maybe String,
-- | 'CVS' can put multiple \"modules\" on one server and requires a
-- module name in addition to the location to identify a particular repo.
-- Logically this is part of the location but unfortunately has to be
-- specified separately. This field is required for the 'CVS' 'RepoType' and
-- should not be given otherwise.
repoModule :: Maybe String,
-- | The name or identifier of the branch, if any. Many source control
-- systems have the notion of multiple branches in a repo that exist in the
-- same location. For example 'Git' and 'CVS' use this while systems like
-- 'Darcs' use different locations for different branches. This field is
-- optional but should be used if necessary to identify the sources,
-- especially for the 'RepoThis' repo kind.
repoBranch :: Maybe String,
-- | The tag identify a particular state of the repository. This should be
-- given for the 'RepoThis' repo kind and not for 'RepoHead' kind.
--
repoTag :: Maybe String,
-- | Some repositories contain multiple projects in different subdirectories
-- This field specifies the subdirectory where this packages sources can be
-- found, eg the subdirectory containing the @.cabal@ file. It is interpreted
-- relative to the root of the repository. This field is optional. If not
-- given the default is \".\" ie no subdirectory.
repoSubdir :: Maybe FilePath
}
deriving (Eq, Read, Show)
-- | What this repo info is for, what it represents.
--
data RepoKind =
-- | The repository for the \"head\" or development version of the project.
-- This repo is where we should track the latest development activity or
-- the usual repo people should get to contribute patches.
RepoHead
-- | The repository containing the sources for this exact package version
-- or release. For this kind of repo a tag should be given to give enough
-- information to re-create the exact sources.
| RepoThis
-- | Some other specific named kind of repo. We do not give this a
-- particular interpretation or convention but could be used in-house for
-- special purposes for example if there are multiple related branches.
| RepoSpecific String
deriving (Eq, Ord, Read, Show)
-- | An enumeration of common source control systems. The fields used in the
-- '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
| OtherRepoType String
deriving (Eq, Ord, Read, Show)
knownRepoTypes :: [RepoType]
knownRepoTypes = [Darcs, Git, SVN, CVS
,Mercurial, GnuArch, Bazaar, Monotone]
repoTypeAliases :: RepoType -> [String]
repoTypeAliases Bazaar = ["bzr"]
repoTypeAliases Mercurial = ["hg"]
repoTypeAliases GnuArch = ["arch"]
repoTypeAliases _ = []
instance Text RepoKind where
disp RepoHead = Disp.text "head"
disp RepoThis = Disp.text "this"
disp (RepoSpecific other) = Disp.text other
parse = do
name <- ident
return $ case lowercase name of
"head" -> RepoHead
"this" -> RepoThis
_ -> RepoSpecific name
instance Text RepoType where
disp (OtherRepoType other) = Disp.text other
disp other = Disp.text (lowercase (show other))
parse = fmap classifyRepoType ident
classifyRepoType :: String -> RepoType
classifyRepoType s =
case lookup (lowercase s) repoTypeMap of
Just repoType' -> repoType'
Nothing -> OtherRepoType s
where
repoTypeMap = [ (name, repoType')
| repoType' <- knownRepoTypes
, name <- display repoType' : repoTypeAliases repoType' ]
ident :: Parse.ReadP r String
ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
lowercase :: String -> String
lowercase = map Char.toLower
-- ------------------------------------------------------------
-- * Utils
-- ------------------------------------------------------------
......@@ -450,7 +587,7 @@ data GenericPackageDescription =
condLibrary :: Maybe (CondTree ConfVar [Dependency] Library),
condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)]
}
deriving (Show)
deriving (Show, Eq)
instance Package GenericPackageDescription where
packageId = packageId . packageDescription
......@@ -484,7 +621,7 @@ data Flag = MkFlag
, flagDefault :: Bool
, flagManual :: Bool
}
deriving Show
deriving (Show, Eq)
-- | A 'FlagName' is the name of a user-defined configuration flag
newtype FlagName = FlagName String
......@@ -517,7 +654,7 @@ data Condition c = Var c
| CNot (Condition c)
| COr (Condition c) (Condition c)
| CAnd (Condition c) (Condition c)
deriving Show
deriving (Show, Eq)
--instance Text c => Text (Condition c) where
-- disp (Var x) = text (show x)
......@@ -533,7 +670,7 @@ data CondTree v c a = CondNode
, CondTree v c a
, Maybe (CondTree v c a))]
}
deriving Show
deriving (Show, Eq)
--instance (Text v, Text c) => Text (CondTree v c a) where
-- disp (CondNode _dat cs ifs) =
......
......@@ -289,6 +289,30 @@ flagFieldDescrs =
flagManual (\val fl -> fl{ flagManual = val })
]
------------------------------------------------------------------------------
sourceRepoFieldDescrs :: [FieldDescr SourceRepo]
sourceRepoFieldDescrs =
[ simpleField "type"
(maybe empty disp) (fmap Just parse)
repoType (\val repo -> repo { repoType = val })
, simpleField "location"
(maybe empty showFreeText) (fmap Just parseFreeText)
repoLocation (\val repo -> repo { repoLocation = val })
, simpleField "module"
(maybe empty showToken) (fmap Just parseTokenQ)
repoModule (\val repo -> repo { repoModule = val })
, simpleField "branch"
(maybe empty showToken) (fmap Just parseTokenQ)
repoBranch (\val repo -> repo { repoBranch = val })
, simpleField "tag"
(maybe empty showToken) (fmap Just parseTokenQ)
repoTag (\val repo -> repo { repoTag = val })
, simpleField "subdir"
(maybe empty showFilePath) (fmap Just parseFilePathQ)
repoSubdir (\val repo -> repo { repoSubdir = val })
]
-- ---------------------------------------------------------------
-- Parsing
......@@ -480,12 +504,14 @@ parsePackageDescription file = do
-- 'getBody' assumes that the remaining fields only consist of
-- flags, lib and exe sections.
(flags, mlib, exes) <- getBody
(repos, flags, mlib, exes) <- getBody
warnIfRest -- warn if getBody did not parse up to the last field.
when (not (oldSyntax fields0)) $ -- warn if we use new syntax
maybeWarnCabalVersion pkg -- without Cabal >= 1.2
checkForUndefinedFlags flags mlib exes
return (GenericPackageDescription pkg flags mlib exes)
return $ GenericPackageDescription
pkg { sourceRepos = repos }
flags mlib exes
where
oldSyntax flds = all isSimpleField flds
......@@ -569,11 +595,11 @@ parsePackageDescription file = do
_ -> return (reverse acc)
--
-- body ::= { flag | library | executable }+ -- at most one lib
-- body ::= { repo | flag | library | executable }+ -- at most one lib
--
-- The body consists of an optional sequence of declarations of flags and
-- an arbitrary number of executables and at most one library.
getBody :: PM ([Flag]
getBody :: PM ([SourceRepo], [Flag]
,Maybe (CondTree ConfVar [Dependency] Library)
,[(String, CondTree ConfVar [Dependency] Executable)])
getBody = peekField >>= \mf -> case mf of
......@@ -584,18 +610,18 @@ parsePackageDescription file = do
exename <- lift $ runP line_no "executable" parseTokenQ sec_label
flds <- collectFields parseExeFields sec_fields
skipField
(flags, lib, exes) <- getBody
return (flags, lib, exes ++ [(exename, flds)])
(repos, flags, lib, exes) <- getBody
return (repos, flags, lib, exes ++ [(exename, flds)])
| sec_type == "library" -> do
when (not (null sec_label)) $ lift $
syntaxError line_no "'library' expects no argument"
flds <- collectFields parseLibFields sec_fields
skipField
(flags, lib, exes) <- getBody
(repos, flags, lib, exes) <- getBody
when (isJust lib) $ lift $ syntaxError line_no
"There can only be one library section in a package description."
return (flags, Just flds, exes)
return (repos, flags, Just flds, exes)
| sec_type == "flag" -> do
when (null sec_label) $ lift $
......@@ -606,8 +632,33 @@ parsePackageDescription file = do
(MkFlag (FlagName (lowercase sec_label)) "" True False)
sec_fields
skipField
(flags, lib, exes) <- getBody
return (flag:flags, lib, exes)
(repos, flags, lib, exes) <- getBody
return (repos, flag:flags, lib, exes)
| sec_type == "source-repository" -> do
when (null sec_label) $ lift $ syntaxError line_no $
"'source-repository' needs one argument, "
++ "the repo kind which is usually 'head' or 'this'"
kind <- case simpleParse sec_label of
Just kind -> return kind
Nothing -> lift $ syntaxError line_no $
"could not parse repo kind: " ++ sec_label
repo <- lift $ parseFields
sourceRepoFieldDescrs
warnUnrec
(SourceRepo {
repoKind = kind,
repoType = Nothing,
repoLocation = Nothing,
repoModule = Nothing,
repoBranch = Nothing,
repoTag = Nothing,
repoSubdir = Nothing
})
sec_fields
skipField
(repos, flags, lib, exes) <- getBody
return (repo:repos, flags, lib, exes)
| otherwise -> do
lift $ warning $ "Ignoring unknown section type: " ++ sec_type
......@@ -618,7 +669,7 @@ parsePackageDescription file = do
"Construct not supported at this position: " ++ show f
skipField
getBody
Nothing -> return ([], Nothing, [])
Nothing -> return ([], [], Nothing, [])
-- Extracts all fields in a block and returns a 'CondTree'.
--
......
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