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
GHC
Commits
9c218adf
Commit
9c218adf
authored
Jan 22, 2015
by
Andrey Mokhov
Browse files
Restrict ShowArgs and args to accept only lists.
parent
7c2279b5
Changes
5
Hide whitespace changes
Inline
Side-by-side
src/Base.hs
View file @
9c218adf
...
...
@@ -12,7 +12,6 @@ module Base (
ShowArg
(
..
),
ShowArgs
(
..
),
arg
,
args
,
Condition
(
..
),
(
<+>
),
filterOut
,
productArgs
,
concatArgs
)
where
...
...
@@ -49,34 +48,26 @@ instance ShowArg String where
instance
ShowArg
a
=>
ShowArg
(
Action
a
)
where
showArg
=
(
showArg
=<<
)
-- Using the Creators' trick for overlapping String instances
class
ShowArgs
a
where
showArgs
::
a
->
Args
showListArgs
::
[
a
]
->
Args
showListArgs
=
mconcat
.
map
showArgs
showArgs
::
a
->
Args
instance
ShowArgs
Char
where
showArgs
c
=
return
[[
c
]]
showListArgs
s
=
return
[
s
]
instance
ShowArgs
[
String
]
where
showArgs
=
return
instance
ShowArgs
a
=>
ShowArgs
[
a
]
where
showArgs
=
showListArgs
instance
ShowArgs
[
Arg
]
where
showArgs
=
sequence
instance
ShowArgs
[
Args
]
where
showArgs
=
mconcat
instance
ShowArgs
a
=>
ShowArgs
(
Action
a
)
where
showArgs
=
(
showArgs
=<<
)
-- TODO: improve args type safety
args
::
ShowArgs
a
=>
a
->
Args
args
=
showArgs
arg
::
ShowArg
a
=>
a
->
Args
arg
=
args
.
showArg
-- Combine two heterogeneous ShowArgs values
(
<+>
)
::
(
ShowArgs
a
,
ShowArgs
b
)
=>
a
->
b
->
Args
a
<+>
b
=
(
<>
)
<$>
showArgs
a
<*>
showArgs
b
infixr
6
<+>
arg
a
=
args
[
showArg
a
]
-- Filter out given arg(s) from a collection
filterOut
::
ShowArgs
a
=>
Args
->
a
->
Args
...
...
@@ -85,7 +76,7 @@ filterOut as exclude = do
filter
(`
notElem
`
exclude'
)
<$>
as
-- Generate a cross product collection of two argument collections
-- Example: productArgs ["-a", "-b"] "c" = arg ["-a", "c", "-b", "c"]
-- Example: productArgs ["-a", "-b"] "c" = arg
s
["-a", "c", "-b", "c"]
productArgs
::
(
ShowArgs
a
,
ShowArgs
b
)
=>
a
->
b
->
Args
productArgs
as
bs
=
do
as'
<-
showArgs
as
...
...
@@ -93,7 +84,7 @@ productArgs as bs = do
return
$
concat
$
sequence
[
as'
,
bs'
]
-- Similar to productArgs but concat resulting arguments pairwise
-- Example: concatArgs ["-a", "-b"] "c" = arg ["-ac", "-bc"]
-- Example: concatArgs ["-a", "-b"] "c" = arg
s
["-ac", "-bc"]
concatArgs
::
(
ShowArgs
a
,
ShowArgs
b
)
=>
a
->
b
->
Args
concatArgs
as
bs
=
do
as'
<-
showArgs
as
...
...
src/Package/Base.hs
View file @
9c218adf
...
...
@@ -122,10 +122,11 @@ packageArgs stage pathDist = do
,
when
(
stage
==
Stage0
)
$
arg
"-package-db libraries/bootstrapping.conf"
,
if
usePackageKey
then
productArgs
"-this-package-key"
(
arg
$
PackageKey
pathDist
)
<>
productArgs
"-package-key"
(
args
$
DepKeys
pathDist
)
else
productArgs
"-package-name"
(
arg
$
PackageKey
pathDist
)
<>
productArgs
"-package"
(
args
$
Deps
pathDist
)
]
then
productArgs
[
"-this-package-key"
]
[
arg
$
PackageKey
pathDist
]
<>
productArgs
[
"-package-key"
]
[
args
$
DepKeys
pathDist
]
else
productArgs
[
"-package-name"
]
[
arg
$
PackageKey
pathDist
]
<>
productArgs
[
"-package"
]
[
args
$
Deps
pathDist
]
]
includeGccArgs
::
FilePath
->
FilePath
->
Args
includeGccArgs
path
dist
=
...
...
@@ -145,8 +146,9 @@ includeGhcArgs path dist =
[
buildDir
,
unifyPath
$
buildDir
</>
"autogen"
]
,
pathArgs
"-I"
path
$
IncludeDirs
pathDist
,
arg
"-optP-include"
-- TODO: Shall we also add -cpp?
,
concatArgs
"-optP"
$
unifyPath
$
buildDir
</>
"autogen/cabal_macros.h"
]
,
concatArgs
[
"-optP"
]
[
unifyPath
$
buildDir
</>
"autogen/cabal_macros.h"
]
]
pkgHsSources
::
FilePath
->
FilePath
->
Action
[
FilePath
]
pkgHsSources
path
dist
=
do
...
...
src/Package/Compile.hs
View file @
9c218adf
...
...
@@ -23,7 +23,7 @@ ghcArgs (Package _ path _ _) (stage, dist, _) way srcs result =
,
args
$
HsArgs
pathDist
-- TODO: now we have both -O and -O2
-- <> arg ["-O2"]
,
productArgs
[
"-odir"
,
"-hidir"
,
"-stubdir"
]
buildDir
,
productArgs
[
"-odir"
,
"-hidir"
,
"-stubdir"
]
[
buildDir
]
,
when
(
splitObjects
stage
)
$
arg
"-split-objs"
,
args
(
"-c"
:
srcs
)
,
args
[
"-o"
,
result
]
]
...
...
src/Package/Data.hs
View file @
9c218adf
...
...
@@ -24,7 +24,7 @@ configureArgs stage settings =
let
conf
key
as
=
do
s
<-
unwords
<$>
args
as
unless
(
null
s
)
$
arg
$
"--configure-option="
++
key
++
"="
++
s
cflags
=
[
commonCcArgs
`
filterOut
`
"-Werror"
cflags
=
[
commonCcArgs
`
filterOut
`
[
"-Werror"
]
,
args
$
ConfCcArgs
stage
-- , customCcArgs settings -- TODO: bring this back
,
commonCcWarninigArgs
]
-- TODO: check why cflags are glued
...
...
@@ -37,7 +37,8 @@ configureArgs stage settings =
in
args
[
conf
"CFLAGS"
cflags
,
conf
"LDFLAGS"
ldflags
,
conf
"CPPFLAGS"
cppflags
,
arg
$
concat
<$>
"--gcc-options="
<+>
cflags
<+>
" "
<+>
ldflags
,
arg
$
concat
<$>
arg
"--gcc-options="
<>
args
cflags
<>
arg
" "
<>
args
ldflags
,
conf
"--with-iconv-includes"
IconvIncludeDirs
,
conf
"--with-iconv-libraries"
IconvLibDirs
,
conf
"--with-gmp-includes"
GmpIncludeDirs
...
...
@@ -73,8 +74,8 @@ bootPkgConstraints = args $ do
content
<-
lines
<$>
liftIO
(
readFile
cabal
)
let
versionLines
=
filter
((
"ersion:"
`
isPrefixOf
`)
.
drop
1
)
content
case
versionLines
of
[
versionLine
]
->
args
[
"--constraint
"
,
depName
++
" == "
++
dropWhile
(
not
.
isDigit
)
versionLine
]
[
versionLine
]
->
return
$
"--constraint
"
++
depName
++
" == "
++
dropWhile
(
not
.
isDigit
)
versionLine
_
->
redError
$
"Cannot determine package version in '"
++
unifyPath
cabal
++
"'."
...
...
src/Package/Dependencies.hs
View file @
9c218adf
...
...
@@ -16,9 +16,9 @@ ghcArgs (Package name path _ _) (stage, dist, settings) =
,
packageArgs
stage
pathDist
,
includeGhcArgs
path
dist
,
concatArgs
[
"-optP"
]
$
CppArgs
pathDist
,
productArgs
[
"-odir"
,
"-stubdir"
,
"-hidir"
]
buildDir
,
args
[
"-dep-makefile"
,
depFile
]
,
productArgs
"-dep-suffix"
$
map
wayPrefix
<$>
ways
settings
,
productArgs
[
"-odir"
,
"-stubdir"
,
"-hidir"
]
[
buildDir
]
,
args
[
"-dep-makefile"
,
depFile
]
,
productArgs
[
"-dep-suffix"
]
$
map
wayPrefix
<$>
ways
settings
,
args
$
HsArgs
pathDist
,
args
$
pkgHsSources
path
dist
]
...
...
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