Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
f354a7bd
Commit
f354a7bd
authored
Sep 30, 2008
by
Duncan Coutts
Browse files
Add support for specifying source repos in .cabal files
Ticket #58. Does not yet include checking.
parent
bf4ed2e4
Changes
2
Hide whitespace changes
Inline
Side-by-side
Distribution/PackageDescription.hs
View file @
f354a7bd
...
...
@@ -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) =
...
...
Distribution/PackageDescription/Parse.hs
View file @
f354a7bd
...
...
@@ -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'.
--
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment