Skip to content
GitLab
Menu
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
acc460dc
Commit
acc460dc
authored
Oct 31, 2016
by
John Ericson
Committed by
GitHub
Oct 31, 2016
Browse files
Merge pull request #4057 from Ericson2314/unqual-component-name
[WIP] Use UnqualComponentName newtype instead of String for component names
parents
f26d20ea
be6a94a2
Changes
56
Hide whitespace changes
Inline
Side-by-side
Cabal/Distribution/Backpack/ComponentsGraph.hs
View file @
acc460dc
...
...
@@ -51,24 +51,22 @@ toComponentsGraph enabled pkg_descr =
where
-- The dependencies for the given component
componentDeps
component
=
[
CExeName
toolname
|
Dependency
pkgname
_
<-
buildTools
bi
,
let
toolname
=
unPackageName
pkgname
,
toolname
`
elem
`
map
exeName
(
executables
pkg_descr
)
]
[
CExeName
toolname
|
Dependency
pkgname
_
<-
buildTools
bi
,
let
toolname
=
packageNameToUnqualComponentName
pkgname
,
toolname
`
elem
`
map
exeName
(
executables
pkg_descr
)
]
++
[
if
pkgname
==
packageName
pkg_descr
then
CLibName
else
CSubLibName
toolname
|
Dependency
pkgname
_
<-
targetBuildDepends
bi
,
pkgname
`
elem
`
internalPkgDeps
,
let
toolname
=
unPackageName
pkgname
]
then
CLibName
else
CSubLibName
toolname
|
Dependency
pkgname
_
<-
targetBuildDepends
bi
,
let
toolname
=
packageNameToUnqualComponentName
pkgname
,
toolname
`
elem
`
internalPkgDeps
]
where
bi
=
componentBuildInfo
component
internalPkgDeps
=
map
(
conv
.
libName
)
(
allLibraries
pkg_descr
)
conv
Nothing
=
packageName
pkg_descr
conv
(
Just
s
)
=
mkPackageName
s
conv
Nothing
=
packageNameToUnqualComponentName
$
packageName
pkg_descr
conv
(
Just
s
)
=
s
-- | Error message when there is a cycle; takes the SCC of components.
componentCycleMsg
::
[
ComponentName
]
->
Doc
...
...
Cabal/Distribution/Backpack/ConfiguredComponent.hs
View file @
acc460dc
...
...
@@ -104,7 +104,7 @@ mkConfiguredComponent this_pid this_cid lib_deps exe_deps component =
type
ConfiguredComponentMap
=
(
Map
PackageName
(
ComponentId
,
PackageId
),
-- libraries
Map
String
ComponentId
)
-- executables
Map
UnqualComponentName
ComponentId
)
-- executables
-- Executable map must be different because an executable can
-- have the same name as a library. Ew.
...
...
@@ -141,7 +141,7 @@ toConfiguredComponent pkg_descr this_cid
=
Map
.
toList
external_lib_map
exe_deps
=
[
cid
|
Dependency
pkgname
_
<-
buildTools
bi
,
let
name
=
unP
ackageName
pkgname
,
let
name
=
p
ackageName
ToUnqualComponentName
pkgname
,
Just
cid
<-
[
Map
.
lookup
name
exe_map
]
]
-- | Also computes the 'ComponentId', and sets cc_public if necessary.
...
...
@@ -183,7 +183,7 @@ extendConfiguredComponentMap cc (lib_map, exe_map) =
Map
.
insert
(
pkgName
(
cc_pkgid
cc
))
(
cc_cid
cc
,
cc_pkgid
cc
)
lib_map
CSubLibName
str
->
Map
.
insert
(
mk
PackageName
str
)
Map
.
insert
(
unqualComponentNameTo
PackageName
str
)
(
cc_cid
cc
,
cc_pkgid
cc
)
lib_map
_
->
lib_map
exe_map'
...
...
Cabal/Distribution/Backpack/Id.hs
View file @
acc460dc
...
...
@@ -63,7 +63,7 @@ computeComponentId mb_ipid mb_cid pid cname mb_details =
NoFlag
->
mkComponentId
$
actual_base
++
(
case
componentNameString
cname
of
Nothing
->
""
Just
s
->
"-"
++
s
)
Just
s
->
"-"
++
unUnqualComponentName
s
)
-- | Computes the package name for a library. If this is the public
-- library, it will just be the original package name; otherwise,
...
...
@@ -102,7 +102,8 @@ computeCompatPackageName pkg_name CLibName = pkg_name
computeCompatPackageName
pkg_name
cname
=
mkPackageName
$
"z-"
++
zdashcode
(
display
pkg_name
)
++
(
case
componentNameString
cname
of
Just
cname_str
->
"-z-"
++
zdashcode
cname_str
Just
cname_u
->
"-z-"
++
zdashcode
cname_str
where
cname_str
=
unUnqualComponentName
cname_u
Nothing
->
""
)
zdashcode
::
String
->
String
...
...
Cabal/Distribution/Package.hs
View file @
acc460dc
...
...
@@ -18,7 +18,9 @@
module
Distribution.Package
(
-- * Package ids
UnqualComponentName
,
unUnqualComponentName
,
mkUnqualComponentName
,
PackageName
,
unPackageName
,
mkPackageName
,
packageNameToUnqualComponentName
,
unqualComponentNameToPackageName
,
PackageIdentifier
(
..
),
PackageId
,
...
...
@@ -69,6 +71,54 @@ import Distribution.ModuleName
import
Text.PrettyPrint
((
<+>
),
text
)
-- | An unqualified component name, for any kind of component.
--
-- This is distinguished from a 'ComponentName' and 'ComponentId'. The former
-- also states which of a library, executable, etc the name refers too. The
-- later uniquely identifiers a component and its closure.
--
-- @since 2.0
newtype
UnqualComponentName
=
UnqualComponentName
ShortText
deriving
(
Generic
,
Read
,
Show
,
Eq
,
Ord
,
Typeable
,
Data
,
Semigroup
,
Monoid
)
-- TODO: bad enabler of bad monoids
-- | Convert 'UnqualComponentName' to 'String'
--
-- @since 2.0
unUnqualComponentName
::
UnqualComponentName
->
String
unUnqualComponentName
(
UnqualComponentName
s
)
=
fromShortText
s
-- | Construct a 'UnqualComponentName' from a 'String'
--
-- 'mkUnqualComponentName' is the inverse to 'unUnqualComponentName'
--
-- Note: No validations are performed to ensure that the resulting
-- 'UnqualComponentName' is valid
--
-- @since 2.0
mkUnqualComponentName
::
String
->
UnqualComponentName
mkUnqualComponentName
=
UnqualComponentName
.
toShortText
instance
Binary
UnqualComponentName
parsePackageName
::
Parse
.
ReadP
r
String
parsePackageName
=
do
ns
<-
Parse
.
sepBy1
component
(
Parse
.
char
'-'
)
return
$
intercalate
"-"
ns
where
component
=
do
cs
<-
Parse
.
munch1
isAlphaNum
if
all
isDigit
cs
then
Parse
.
pfail
else
return
cs
-- each component must contain an alphabetic character, to avoid
-- ambiguity in identifiers like foo-1 (the 1 is the version number).
instance
Text
UnqualComponentName
where
disp
=
Disp
.
text
.
unUnqualComponentName
parse
=
mkUnqualComponentName
<$>
parsePackageName
instance
NFData
UnqualComponentName
where
rnf
(
UnqualComponentName
pkg
)
=
rnf
pkg
-- | A package name.
--
-- Use 'mkPackageName' and 'unPackageName' to convert from/to a
...
...
@@ -95,19 +145,32 @@ unPackageName (PackageName s) = fromShortText s
mkPackageName
::
String
->
PackageName
mkPackageName
=
PackageName
.
toShortText
-- | Converts a package name to an unqualified component name
--
-- Useful in legacy situations where a package name may refer to an internal
-- component, if one is defined with that name.
--
-- @since 2.0
packageNameToUnqualComponentName
::
PackageName
->
UnqualComponentName
packageNameToUnqualComponentName
(
PackageName
s
)
=
UnqualComponentName
s
-- | Converts an unqualified component name to a package name
--
-- `packageNameToUnqualComponentName` is the inverse of
-- `unqualComponentNameToPackageName`.
--
-- Useful in legacy situations where a package name may refer to an internal
-- component, if one is defined with that name.
--
-- @since 2.0
unqualComponentNameToPackageName
::
UnqualComponentName
->
PackageName
unqualComponentNameToPackageName
(
UnqualComponentName
s
)
=
PackageName
s
instance
Binary
PackageName
instance
Text
PackageName
where
disp
=
Disp
.
text
.
unPackageName
parse
=
do
ns
<-
Parse
.
sepBy1
component
(
Parse
.
char
'-'
)
return
(
mkPackageName
(
intercalate
"-"
ns
))
where
component
=
do
cs
<-
Parse
.
munch1
isAlphaNum
if
all
isDigit
cs
then
Parse
.
pfail
else
return
cs
-- each component must contain an alphabetic character, to avoid
-- ambiguity in identifiers like foo-1 (the 1 is the version number).
parse
=
mkPackageName
<$>
parsePackageName
instance
NFData
PackageName
where
rnf
(
PackageName
pkg
)
=
rnf
pkg
...
...
Cabal/Distribution/PackageDescription/Check.hs
View file @
acc460dc
...
...
@@ -185,13 +185,15 @@ checkSanity pkg =
++
"Only the non-internal library can have the same name as the package."
,
check
(
not
(
null
duplicateNames
))
$
PackageBuildImpossible
$
"Duplicate sections: "
++
commaSep
duplicateNames
PackageBuildImpossible
$
"Duplicate sections: "
++
commaSep
(
map
unUnqualComponentName
duplicateNames
)
++
". The name of every library, executable, test suite,"
++
" and benchmark section in"
++
" the package must be unique."
-- NB: but it's OK for executables to have the same name!
,
check
(
any
(
==
display
(
packageName
pkg
))
subLibNames
)
$
-- TODO shouldn't need to compare on the string level
,
check
(
any
(
==
display
(
packageName
pkg
))
(
display
<$>
subLibNames
))
$
PackageBuildImpossible
$
"Illegal internal library name "
++
display
(
packageName
pkg
)
++
". Internal libraries cannot have the same name as the package."
...
...
@@ -239,7 +241,7 @@ checkLibrary pkg lib =
PackageDistSuspiciousWarn
$
"Library "
++
(
case
libName
lib
of
Nothing
->
""
Just
n
->
n
Just
n
->
display
n
)
++
"does not expose any modules"
-- check use of signatures sections
...
...
@@ -273,7 +275,7 @@ checkExecutable pkg exe =
check
(
null
(
modulePath
exe
))
$
PackageBuildImpossible
$
"No 'main-is' field found for executable "
++
exeName
exe
"No 'main-is' field found for executable "
++
display
(
exeName
exe
)
,
check
(
not
(
null
(
modulePath
exe
))
&&
(
not
$
fileExtensionSupportedLanguage
$
modulePath
exe
))
$
...
...
@@ -291,14 +293,14 @@ checkExecutable pkg exe =
,
check
(
not
(
null
moduleDuplicates
))
$
PackageBuildImpossible
$
"Duplicate modules in executable '"
++
exeName
exe
++
"': "
"Duplicate modules in executable '"
++
display
(
exeName
exe
)
++
"': "
++
commaSep
(
map
display
moduleDuplicates
)
-- check that all autogen-modules appear on other-modules
,
check
(
not
$
and
$
map
(
flip
elem
(
exeModules
exe
))
(
exeModulesAutogen
exe
))
$
PackageBuildImpossible
$
"On executable '"
++
exeName
exe
++
"' an 'autogen-module' is not "
"On executable '"
++
display
(
exeName
exe
)
++
"' an 'autogen-module' is not "
++
"on 'other-modules'"
]
...
...
@@ -325,7 +327,7 @@ checkTestSuite pkg test =
,
check
(
not
$
null
moduleDuplicates
)
$
PackageBuildImpossible
$
"Duplicate modules in test suite '"
++
testName
test
++
"': "
"Duplicate modules in test suite '"
++
display
(
testName
test
)
++
"': "
++
commaSep
(
map
display
moduleDuplicates
)
,
check
mainIsWrongExt
$
...
...
@@ -346,7 +348,7 @@ checkTestSuite pkg test =
(
testModulesAutogen
test
)
)
$
PackageBuildImpossible
$
"On test suite '"
++
testName
test
++
"' an 'autogen-module' is not "
"On test suite '"
++
display
(
testName
test
)
++
"' an 'autogen-module' is not "
++
"on 'other-modules'"
]
where
...
...
@@ -380,7 +382,7 @@ checkBenchmark _pkg bm =
,
check
(
not
$
null
moduleDuplicates
)
$
PackageBuildImpossible
$
"Duplicate modules in benchmark '"
++
benchmarkName
bm
++
"': "
"Duplicate modules in benchmark '"
++
display
(
benchmarkName
bm
)
++
"': "
++
commaSep
(
map
display
moduleDuplicates
)
,
check
mainIsWrongExt
$
...
...
@@ -395,7 +397,7 @@ checkBenchmark _pkg bm =
(
benchmarkModulesAutogen
bm
)
)
$
PackageBuildImpossible
$
"On benchmark '"
++
benchmarkName
bm
++
"' an 'autogen-module' is "
"On benchmark '"
++
display
(
benchmarkName
bm
)
++
"' an 'autogen-module' is "
++
"not on 'other-modules'"
]
where
...
...
@@ -552,7 +554,7 @@ checkFields pkg =
,
isNoVersion
vr
]
internalLibraries
=
map
(
maybe
(
packageName
pkg
)
mk
PackageName
.
libName
)
map
(
maybe
(
packageName
pkg
)
(
unqualComponentNameTo
PackageName
)
.
libName
)
(
allLibraries
pkg
)
buildDependsRangeOnInternalLibrary
=
[
dep
...
...
Cabal/Distribution/PackageDescription/Configuration.hs
View file @
acc460dc
...
...
@@ -452,7 +452,7 @@ constrainBy left extra =
-- | Collect up the targets in a TargetSet of tagged targets, storing the
-- dependencies as we go.
flattenTaggedTargets
::
TargetSet
PDTagged
->
(
Maybe
Library
,
[(
String
,
Component
)])
flattenTaggedTargets
::
TargetSet
PDTagged
->
(
Maybe
Library
,
[(
UnqualComponentName
,
Component
)])
flattenTaggedTargets
(
TargetSet
targets
)
=
foldr
untag
(
Nothing
,
[]
)
targets
where
untag
(
_
,
Lib
_
)
(
Just
_
,
_
)
=
userBug
"Only one library expected"
...
...
@@ -464,7 +464,7 @@ flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets
}
untag
(
deps
,
SubComp
n
c
)
(
mb_lib
,
comps
)
|
any
((
==
n
)
.
fst
)
comps
=
userBug
$
"There exist several components with the same name: '"
++
n
++
"'"
userBug
$
"There exist several components with the same name: '"
++
unUnqualComponentName
n
++
"'"
|
otherwise
=
(
mb_lib
,
(
n
,
c'
)
:
comps
)
where
...
...
@@ -484,7 +484,7 @@ flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets
--
data
PDTagged
=
Lib
Library
|
SubComp
String
Component
|
SubComp
UnqualComponentName
Component
|
PDNull
deriving
Show
...
...
Cabal/Distribution/PackageDescription/Parse.hs
View file @
acc460dc
...
...
@@ -889,11 +889,11 @@ parsePackageDescription file = do
->
PM
([
SourceRepo
],
[
Flag
]
,
Maybe
SetupBuildInfo
,(
Maybe
(
CondTree
ConfVar
[
Dependency
]
Library
))
,[(
String
,
CondTree
ConfVar
[
Dependency
]
Library
)]
,[(
String
,
CondTree
ConfVar
[
Dependency
]
ForeignLib
)]
,[(
String
,
CondTree
ConfVar
[
Dependency
]
Executable
)]
,[(
String
,
CondTree
ConfVar
[
Dependency
]
TestSuite
)]
,[(
String
,
CondTree
ConfVar
[
Dependency
]
Benchmark
)])
,[(
UnqualComponentName
,
CondTree
ConfVar
[
Dependency
]
Library
)]
,[(
UnqualComponentName
,
CondTree
ConfVar
[
Dependency
]
ForeignLib
)]
,[(
UnqualComponentName
,
CondTree
ConfVar
[
Dependency
]
Executable
)]
,[(
UnqualComponentName
,
CondTree
ConfVar
[
Dependency
]
TestSuite
)]
,[(
UnqualComponentName
,
CondTree
ConfVar
[
Dependency
]
Benchmark
)])
getBody
pkg
=
peekField
>>=
\
mf
->
case
mf
of
Just
(
Section
line_no
sec_type
sec_label
sec_fields
)
|
sec_type
==
"executable"
->
do
...
...
@@ -903,7 +903,7 @@ parsePackageDescription file = do
flds
<-
collectFields
parseExeFields
sec_fields
skipField
(
repos
,
flags
,
csetup
,
mlib
,
sub_libs
,
flibs
,
exes
,
tests
,
bms
)
<-
getBody
pkg
return
(
repos
,
flags
,
csetup
,
mlib
,
sub_libs
,
flibs
,
(
exename
,
flds
)
:
exes
,
tests
,
bms
)
return
(
repos
,
flags
,
csetup
,
mlib
,
sub_libs
,
flibs
,
(
mkUnqualComponentName
exename
,
flds
)
:
exes
,
tests
,
bms
)
|
sec_type
==
"foreign-library"
->
do
when
(
null
sec_label
)
$
lift
$
syntaxError
line_no
...
...
@@ -922,7 +922,7 @@ parsePackageDescription file = do
then
do
skipField
(
repos
,
flags
,
csetup
,
mlib
,
sub_libs
,
flibs
,
exes
,
tests
,
bms
)
<-
getBody
pkg
return
(
repos
,
flags
,
csetup
,
mlib
,
sub_libs
,
(
libname
,
flds
)
:
flibs
,
exes
,
tests
,
bms
)
return
(
repos
,
flags
,
csetup
,
mlib
,
sub_libs
,
(
mkUnqualComponentName
libname
,
flds
)
:
flibs
,
exes
,
tests
,
bms
)
else
lift
$
syntaxError
line_no
$
"Foreign library
\"
"
++
libname
++
"
\"
is missing required field
\"
type
\"
or the field "
...
...
@@ -948,7 +948,7 @@ parsePackageDescription file = do
skipField
(
repos
,
flags
,
csetup
,
mlib
,
sub_libs
,
flibs
,
exes
,
tests
,
bms
)
<-
getBody
pkg
return
(
repos
,
flags
,
csetup
,
mlib
,
sub_libs
,
flibs
,
exes
,
(
testname
,
flds
)
:
tests
,
bms
)
(
mkUnqualComponentName
testname
,
flds
)
:
tests
,
bms
)
else
lift
$
syntaxError
line_no
$
"Test suite
\"
"
++
testname
++
"
\"
is missing required field
\"
type
\"
or the field "
...
...
@@ -974,7 +974,7 @@ parsePackageDescription file = do
skipField
(
repos
,
flags
,
csetup
,
mlib
,
sub_libs
,
flibs
,
exes
,
tests
,
bms
)
<-
getBody
pkg
return
(
repos
,
flags
,
csetup
,
mlib
,
sub_libs
,
flibs
,
exes
,
tests
,
(
benchname
,
flds
)
:
bms
)
tests
,
(
mkUnqualComponentName
benchname
,
flds
)
:
bms
)
else
lift
$
syntaxError
line_no
$
"Benchmark
\"
"
++
benchname
++
"
\"
is missing required field
\"
type
\"
or the field "
...
...
@@ -994,7 +994,7 @@ parsePackageDescription file = do
(
repos
,
flags
,
csetup
,
mlib
,
sub_libs
,
flibs
,
exes
,
tests
,
bms
)
<-
getBody
pkg
case
mb_libname
of
Just
libname
->
return
(
repos
,
flags
,
csetup
,
mlib
,
(
libname
,
flds
)
:
sub_libs
,
flibs
,
exes
,
tests
,
bms
)
return
(
repos
,
flags
,
csetup
,
mlib
,
(
mkUnqualComponentName
libname
,
flds
)
:
sub_libs
,
flibs
,
exes
,
tests
,
bms
)
Nothing
->
do
when
(
isJust
mlib
)
$
lift
$
syntaxError
line_no
"There can only be one (public) library section in a package description."
...
...
@@ -1141,9 +1141,9 @@ parsePackageDescription file = do
checkForUndefinedFlags
::
[
Flag
]
->
Maybe
(
CondTree
ConfVar
[
Dependency
]
Library
)
->
[(
String
,
CondTree
ConfVar
[
Dependency
]
Library
)]
->
[(
String
,
CondTree
ConfVar
[
Dependency
]
Executable
)]
->
[(
String
,
CondTree
ConfVar
[
Dependency
]
TestSuite
)]
->
[(
UnqualComponentName
,
CondTree
ConfVar
[
Dependency
]
Library
)]
->
[(
UnqualComponentName
,
CondTree
ConfVar
[
Dependency
]
Executable
)]
->
[(
UnqualComponentName
,
CondTree
ConfVar
[
Dependency
]
TestSuite
)]
->
PM
()
checkForUndefinedFlags
flags
mlib
sub_libs
exes
tests
=
do
let
definedFlags
=
map
flagName
flags
...
...
@@ -1252,11 +1252,11 @@ parseHookedBuildInfo inp = do
|
lowercase
inFieldName
/=
"executable"
=
liftM
Just
(
parseBI
bi
)
parseLib
_
=
return
Nothing
parseExe
::
[
Field
]
->
ParseResult
(
String
,
BuildInfo
)
parseExe
::
[
Field
]
->
ParseResult
(
UnqualComponentName
,
BuildInfo
)
parseExe
(
F
line
inFieldName
mName
:
bi
)
|
lowercase
inFieldName
==
"executable"
=
do
bis
<-
parseBI
bi
return
(
mName
,
bis
)
return
(
mkUnqualComponentName
mName
,
bis
)
|
otherwise
=
syntaxError
line
"expecting 'executable' at top of stanza"
parseExe
(
_
:
_
)
=
cabalBug
"`parseExe' called on a non-field"
parseExe
[]
=
syntaxError
0
"error in parsing buildinfo file. Expected executable stanza"
...
...
Cabal/Distribution/PackageDescription/Parsec.hs
View file @
acc460dc
...
...
@@ -34,6 +34,7 @@ import qualified Data.ByteString as BS
import
Data.List
(
partition
)
import
qualified
Data.Map
as
Map
import
qualified
Distribution.Compat.SnocList
as
SnocList
import
Distribution.Package
import
Distribution.PackageDescription
import
Distribution.PackageDescription.Parsec.FieldDescr
import
Distribution.Parsec.Class
(
parsec
)
...
...
@@ -215,21 +216,21 @@ parseGenericPackageDescription' lexWarnings fs = do
-- Sublibraries
|
name
==
"library"
=
do
name'
<-
parseName
pos
args
name'
<-
parse
UnqualComponent
Name
pos
args
lib
<-
parseCondTree
libFieldDescrs
storeXFieldsLib
(
targetBuildDepends
.
libBuildInfo
)
emptyLibrary
fields
-- TODO check duplicate name here?
let
gpd'
=
gpd
{
condSubLibraries
=
condSubLibraries
gpd
++
[(
name'
,
lib
)]
}
pure
gpd'
|
name
==
"foreign-library"
=
do
name'
<-
parseName
pos
args
name'
<-
parse
UnqualComponent
Name
pos
args
flib
<-
parseCondTree
foreignLibFieldDescrs
storeXFieldsForeignLib
(
targetBuildDepends
.
foreignLibBuildInfo
)
emptyForeignLib
fields
-- TODO check duplicate name here?
let
gpd'
=
gpd
{
condForeignLibs
=
condForeignLibs
gpd
++
[(
name'
,
flib
)]
}
pure
gpd'
|
name
==
"executable"
=
do
name'
<-
parseName
pos
args
name'
<-
parse
UnqualComponent
Name
pos
args
-- Note: we don't parse the "executable" field here, hence the tail hack. Duncan 2010
exe
<-
parseCondTree
(
tail
executableFieldDescrs
)
storeXFieldsExe
(
targetBuildDepends
.
buildInfo
)
emptyExecutable
fields
-- TODO check duplicate name here?
...
...
@@ -237,7 +238,7 @@ parseGenericPackageDescription' lexWarnings fs = do
pure
gpd'
|
name
==
"test-suite"
=
do
name'
<-
parseName
pos
args
name'
<-
parse
UnqualComponent
Name
pos
args
testStanza
<-
parseCondTree
testSuiteFieldDescrs
storeXFieldsTest
(
targetBuildDepends
.
testStanzaBuildInfo
)
emptyTestStanza
fields
testSuite
<-
traverse
(
validateTestSuite
pos
)
testStanza
-- TODO check duplicate name here?
...
...
@@ -245,7 +246,7 @@ parseGenericPackageDescription' lexWarnings fs = do
pure
gpd'
|
name
==
"benchmark"
=
do
name'
<-
parseName
pos
args
name'
<-
parse
UnqualComponent
Name
pos
args
benchStanza
<-
parseCondTree
benchmarkFieldDescrs
storeXFieldsBenchmark
(
targetBuildDepends
.
benchmarkStanzaBuildInfo
)
emptyBenchmarkStanza
fields
bench
<-
traverse
(
validateBenchmark
pos
)
benchStanza
-- TODO check duplicate name here?
...
...
@@ -363,6 +364,10 @@ parseName pos args = case args of
parseFailure
pos
$
"Invalid name "
++
show
args
pure
""
parseUnqualComponentName
::
Position
->
[
SectionArg
Position
]
->
ParseResult
UnqualComponentName
parseUnqualComponentName
pos
args
=
mkUnqualComponentName
<$>
parseName
pos
args
-- | Parse a non-recursive list of fields, given a list of field descriptions,
-- a structure to accumulate the parsed fields, and a function
-- that can decide what to do with fields which don't match any
...
...
Cabal/Distribution/PackageDescription/Parsec/FieldDescr.hs
View file @
acc460dc
...
...
@@ -231,7 +231,7 @@ executableFieldDescrs =
[
-- note ordering: configuration must come first, for
-- showPackageDescription.
simpleField
"executable"
showToken
parsec
Token
disp
parsec
exeName
(
\
xs
exe
->
exe
{
exeName
=
xs
})
,
simpleField
"main-is"
showFilePath
parsecFilePath
...
...
Cabal/Distribution/PackageDescription/PrettyPrint.hs
View file @
acc460dc
...
...
@@ -126,11 +126,10 @@ ppCondLibrary :: Maybe (CondTree ConfVar [Dependency] Library) -> Doc
ppCondLibrary
Nothing
=
mempty
ppCondLibrary
(
Just
condTree
)
=
emptyLine
$
text
"library"
$+$
nest
indentWith
(
ppCondTree
condTree
Nothing
ppLib
)
ppCondSubLibraries
::
[(
String
,
CondTree
ConfVar
[
Dependency
]
Library
)]
->
Doc
$+$
nest
indentWith
(
ppCondTree
condTree
Nothing
ppLib
)
ppCondSubLibraries
::
[(
UnqualComponentName
,
CondTree
ConfVar
[
Dependency
]
Library
)]
->
Doc
ppCondSubLibraries
libs
=
vcat
[
emptyLine
$
text
(
"library "
++
n
)
vcat
[
emptyLine
$
(
text
"library "
<+>
disp
n
)
$+$
nest
indentWith
(
ppCondTree
condTree
Nothing
ppLib
)
|
(
n
,
condTree
)
<-
libs
]
ppLib
::
Library
->
Maybe
Library
->
Doc
...
...
@@ -139,9 +138,9 @@ ppLib lib Nothing = ppFieldsFiltered libDefaults libFieldDescrs lib
ppLib
lib
(
Just
plib
)
=
ppDiffFields
libFieldDescrs
lib
plib
$$
ppCustomFields
(
customFieldsBI
(
libBuildInfo
lib
))
ppCondExecutables
::
[(
String
,
CondTree
ConfVar
[
Dependency
]
Executable
)]
->
Doc
ppCondExecutables
::
[(
UnqualComponentName
,
CondTree
ConfVar
[
Dependency
]
Executable
)]
->
Doc
ppCondExecutables
exes
=
vcat
[
emptyLine
$
text
(
"executable "
++
n
)
vcat
[
emptyLine
$
(
text
"executable "
<+>
disp
n
)
$+$
nest
indentWith
(
ppCondTree
condTree
Nothing
ppExe
)
|
(
n
,
condTree
)
<-
exes
]
where
ppExe
(
Executable
_
modulePath'
buildInfo'
)
Nothing
=
...
...
@@ -155,9 +154,9 @@ ppCondExecutables exes =
$+$
ppDiffFields
binfoFieldDescrs
buildInfo'
buildInfo2
$+$
ppCustomFields
(
customFieldsBI
buildInfo'
)
ppCondTestSuites
::
[(
String
,
CondTree
ConfVar
[
Dependency
]
TestSuite
)]
->
Doc
ppCondTestSuites
::
[(
UnqualComponentName
,
CondTree
ConfVar
[
Dependency
]
TestSuite
)]
->
Doc
ppCondTestSuites
suites
=
emptyLine
$
vcat
[
text
(
"test-suite "
++
n
)
emptyLine
$
vcat
[
(
text
"test-suite "
<+>
disp
n
)
$+$
nest
indentWith
(
ppCondTree
condTree
Nothing
ppTestSuite
)
|
(
n
,
condTree
)
<-
suites
]
where
...
...
@@ -187,9 +186,9 @@ ppCondTestSuites suites =
TestSuiteLibV09
_
m
->
Just
m
_
->
Nothing
ppCondBenchmarks
::
[(
String
,
CondTree
ConfVar
[
Dependency
]
Benchmark
)]
->
Doc
ppCondBenchmarks
::
[(
UnqualComponentName
,
CondTree
ConfVar
[
Dependency
]
Benchmark
)]
->
Doc
ppCondBenchmarks
suites
=
emptyLine
$
vcat
[
text
(
"benchmark "
++
n
)
emptyLine
$
vcat
[
(
text
"benchmark "
<+>
disp
n
)
$+$
nest
indentWith
(
ppCondTree
condTree
Nothing
ppBenchmark
)
|
(
n
,
condTree
)
<-
suites
]
where
...
...
@@ -299,25 +298,25 @@ ppMaybeLibrary (Just lib) =
ppSubLibraries
::
[
Library
]
->
Doc
ppSubLibraries
libs
=
vcat
[
emptyLine
$
text
"library"
<+>
text
libname
emptyLine
$
text
"library"
<+>
disp
libname
$+$
nest
indentWith
(
ppFields
libFieldDescrs
lib
)
|
lib
@
Library
{
libName
=
Just
libname
}
<-
libs
]
ppForeignLibs
::
[
ForeignLib
]
->
Doc
ppForeignLibs
flibs
=
vcat
[
emptyLine
$
text
"foreign library"
<+>
text
flibname
emptyLine
$
text
"foreign library"
<+>
disp
flibname
$+$
nest
indentWith
(
ppFields
foreignLibFieldDescrs
flib
)
|
flib
@
ForeignLib
{
foreignLibName
=
flibname
}
<-
flibs
]
ppExecutables
::
[
Executable
]
->
Doc
ppExecutables
exes
=
vcat
[
emptyLine
$
text
"executable"
<+>
text
(
exeName
exe
)
emptyLine
$
text
"executable"
<+>
disp
(
exeName
exe
)
$+$
nest
indentWith
(
ppFields
executableFieldDescrs
exe
)
|
exe
<-
exes
]
ppTestSuites
::
[
TestSuite
]
->
Doc
ppTestSuites
tests
=
vcat
[
emptyLine
$
text
"test-suite"
<+>
text
(
testName
test
)
emptyLine
$
text
"test-suite"
<+>
disp
(
testName
test
)
$+$
nest
indentWith
(
ppFields
testSuiteFieldDescrs
test_stanza
)
|
test
<-
tests
,
let
test_stanza
...
...
@@ -346,7 +345,7 @@ testSuiteInterfaceToMaybeModule TestSuiteUnsupported{} = Nothing
ppBenchmarks
::
[
Benchmark
]
->
Doc
ppBenchmarks
benchs
=
vcat
[
emptyLine
$
text
"benchmark"
<+>
text
(
benchmarkName
bench
)
emptyLine
$
text
"benchmark"
<+>
disp
(
benchmarkName
bench
)
$+$
nest
indentWith
(
ppFields
benchmarkFieldDescrs
bench_stanza
)
|
bench
<-
benchs
,
let
bench_stanza
=
BenchmarkStanza
{
...
...
@@ -377,7 +376,7 @@ showHookedBuildInfo (mb_lib_bi, ex_bis) = render $
Nothing
->
mempty
Just
bi
->
ppBuildInfo
bi
)
$$
vcat
[
space
$$
text
"executable:"
<+>
text
name
$$
(
text
"executable:"
<+>
disp
name
)
$$
ppBuildInfo
bi
|
(
name
,
bi
)
<-
ex_bis
]
where
...
...
Cabal/Distribution/Parsec/Class.hs
View file @
acc460dc
...
...
@@ -34,7 +34,9 @@ import Distribution.License (License (..))
import
Distribution.ModuleName
(
ModuleName
)
import
qualified
Distribution.ModuleName
as
ModuleName
import
Distribution.Package
(
Dependency
(
..
),
PackageName
,
mkPackageName
)
(
Dependency
(
..
),
UnqualComponentName
,
mkUnqualComponentName
,
PackageName
,
mkPackageName
)
import
Distribution.System
(
Arch
(
..
),
ClassificationStrictness
(
..
),
OS
(
..
),
classifyArch
,
classifyOS
)
...
...
@@ -86,14 +88,22 @@ parsecWarning t w =
-- TODO: use lexemeParsec
-- TODO avoid String
parsecUnqualComponentName
::
P
.
Stream
s
Identity
Char
=>
P
.
Parsec
s
[
PWarning
]
String
parsecUnqualComponentName
=
intercalate
"-"
<$>
P
.
sepBy1
component
(
P
.
char
'-'
)
where
component
::
P
.
Stream
s
Identity
Char
=>
P
.
Parsec
s
[
PWarning
]
String
component
=
do
cs
<-
P
.
munch1
isAlphaNum
if
all
isDigit
cs
then
fail
"all digits in portion of unqualified component name"
else
return
cs
instance
Parsec
UnqualComponentName
where