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
a4f318fd
Commit
a4f318fd
authored
Jan 04, 2015
by
Andrey Mokhov
Browse files
Refactor using variadic args.
parent
c6870b2f
Changes
5
Hide whitespace changes
Inline
Side-by-side
src/Base.hs
View file @
a4f318fd
...
...
@@ -7,9 +7,9 @@ module Base (
module
Data
.
Monoid
,
module
Data
.
List
,
Stage
(
..
),
Args
,
arg
,
args
,
ShowAction
(
..
),
Args
,
arg
,
args
,
ShowAction
(
..
),
Collect
(
..
),
Condition
(
..
),
joinArgs
,
joinArgs
With
Space
s
,
splitArgs
,
joinArgs
,
joinArgsSpace
d
,
splitArgs
,
filterOut
)
where
...
...
@@ -23,7 +23,6 @@ data Stage = Stage0 | Stage1 | Stage2 | Stage3 deriving (Eq, Enum)
type
Args
=
Action
[
String
]
type
Condition
=
Action
Bool
instance
Monoid
a
=>
Monoid
(
Action
a
)
where
...
...
@@ -31,16 +30,22 @@ instance Monoid a => Monoid (Action a) where
mappend
p
q
=
mappend
<$>
p
<*>
q
class
ShowAction
a
where
showAction
::
a
->
Action
String
showAction
::
a
->
Args
showListAction
::
[
a
]
->
Args
-- the Creators' trick for overlapping String instances
showListAction
=
mconcat
.
map
showAction
instance
ShowAction
Char
where
showAction
c
=
return
[[
c
]]
showListAction
s
=
return
[
s
]
instance
ShowAction
String
where
showAction
=
retur
n
instance
ShowAction
a
=>
ShowAction
[
a
]
where
showAction
=
showListActio
n
instance
ShowAction
(
Action
String
)
where
showAction
=
id
instance
ShowAction
a
=>
ShowAction
(
Action
a
)
where
showAction
=
(
showAction
=<<
)
arg
::
ShowAction
a
=>
[
a
]
->
Args
arg
=
mapM
showAction
arg
::
ShowAction
a
=>
a
->
Args
arg
=
showAction
type
ArgsCombine
=
Args
->
Args
->
Args
...
...
@@ -51,19 +56,16 @@ instance Collect Args where
collect
=
const
id
instance
(
ShowAction
a
,
Collect
r
)
=>
Collect
(
a
->
r
)
where
collect
combine
x
=
\
y
->
collect
combine
$
x
`
combine
`
arg
[
y
]
instance
Collect
r
=>
Collect
(
Args
->
r
)
where
collect
combine
x
=
\
y
->
collect
combine
$
x
`
combine
`
y
collect
combine
x
=
\
y
->
collect
combine
$
x
`
combine
`
arg
y
args
::
Collect
a
=>
a
args
=
collect
(
<>
)
mempty
joinArgs
::
Collect
a
=>
a
joinArgs
=
collect
(
\
x
y
->
intercalateArgs
""
x
<>
y
)
mempty
joinArgs
=
collect
(
\
x
y
->
intercalateArgs
""
$
x
<>
y
)
mempty
joinArgs
With
Space
s
::
Collect
a
=>
a
joinArgs
With
Space
s
=
collect
(
\
x
y
->
intercalateArgs
" "
x
<>
y
)
mempty
joinArgsSpace
d
::
Collect
a
=>
a
joinArgsSpace
d
=
collect
(
\
x
y
->
intercalateArgs
" "
$
x
<>
y
)
mempty
intercalateArgs
::
String
->
Args
->
Args
intercalateArgs
s
as
=
do
...
...
src/Oracles/Builder.hs
View file @
a4f318fd
...
...
@@ -15,7 +15,7 @@ import Oracles.Option
data
Builder
=
Ar
|
Ld
|
Gcc
|
Alex
|
Happy
|
HsColour
|
GhcCabal
|
GhcPkg
Stage
|
Ghc
Stage
instance
ShowAction
Builder
where
showAction
builder
=
do
showAction
builder
=
showAction
$
do
let
key
=
case
builder
of
Ar
->
"ar"
Ld
->
"ld"
...
...
@@ -50,12 +50,12 @@ instance ShowAction Builder where
-- the flag (at least temporarily).
needBuilder
::
Builder
->
Action
()
needBuilder
ghc
@
(
Ghc
stage
)
=
do
target
<-
showAction
ghc
laxDeps
<-
test
LaxDeps
[
target
]
<-
showAction
ghc
laxDeps
<-
test
LaxDeps
if
laxDeps
then
orderOnly
[
target
]
else
need
[
target
]
needBuilder
builder
=
do
target
<-
showAction
builder
[
target
]
<-
showAction
builder
need
[
target
]
-- Action 'with Gcc' returns an argument '--with-gcc=/path/to/gcc' and needs the builder
...
...
@@ -70,18 +70,18 @@ with builder = do
Happy
->
"--with-happy="
GhcPkg
_
->
"--with-ghc-pkg="
HsColour
->
"--with-hscolour="
suffix
<-
showAction
builder
[
suffix
]
<-
showAction
builder
needBuilder
builder
return
[
prefix
++
suffix
]
run
::
Builder
->
Args
->
Action
()
run
builder
args
=
do
needBuilder
builder
exe
<-
showAction
builder
[
exe
]
<-
showAction
builder
args'
<-
args
cmd
[
exe
::
FilePath
]
args'
cmd
[
exe
]
args'
hsColourSrcs
::
Condition
hsColourSrcs
=
do
hscolour
<-
showAction
HsColour
[
hscolour
]
<-
showAction
HsColour
return
$
hscolour
/=
""
src/Oracles/Flag.hs
View file @
a4f318fd
...
...
@@ -51,14 +51,14 @@ instance ToCondition Flag where
toCondition
=
test
when
::
(
ToCondition
a
,
Monoid
m
)
=>
a
->
Action
m
->
Action
m
when
x
a
rgs
=
do
when
x
a
ct
=
do
bool
<-
toCondition
x
if
bool
then
a
rgs
else
mempty
if
bool
then
a
ct
else
mempty
unless
::
(
ToCondition
a
,
Monoid
m
)
=>
a
->
Action
m
->
Action
m
unless
x
a
rgs
=
do
unless
x
a
ct
=
do
bool
<-
toCondition
x
if
bool
then
mempty
else
a
rgs
if
bool
then
mempty
else
a
ct
class
Not
a
where
type
NotResult
a
...
...
src/Oracles/Option.hs
View file @
a4f318fd
...
...
@@ -13,7 +13,7 @@ data Option = TargetOS | TargetArch | TargetPlatformFull
|
HostOsCpp
instance
ShowAction
Option
where
showAction
opt
=
askConfig
$
case
opt
of
showAction
opt
=
showAction
$
askConfig
$
case
opt
of
TargetOS
->
"target-os"
TargetArch
->
"target-arch"
TargetPlatformFull
->
"target-platform-full"
...
...
@@ -30,8 +30,8 @@ instance ShowAction Option where
ghcWithInterpreter
::
Condition
ghcWithInterpreter
=
do
os
<-
showAction
TargetOS
arch
<-
showAction
TargetArch
[
os
]
<-
showAction
TargetOS
[
arch
]
<-
showAction
TargetArch
return
$
os
`
elem
`
[
"mingw32"
,
"cygwin32"
,
"linux"
,
"solaris2"
,
"freebsd"
,
"dragonfly"
,
"netbsd"
,
"openbsd"
,
"darwin"
,
"kfreebsdgnu"
]
&&
...
...
@@ -39,10 +39,10 @@ ghcWithInterpreter = do
platformSupportsSharedLibs
::
Condition
platformSupportsSharedLibs
=
do
platform
<-
showAction
TargetPlatformFull
[
platform
]
<-
showAction
TargetPlatformFull
return
$
platform
`
notElem
`
[
"powerpc-unknown-linux"
,
"x86_64-unknown-mingw32"
,
"i386-unknown-mingw32"
]
-- TODO: i386-unknown-solaris2?
windowsHost
::
Condition
windowsHost
=
do
hostOsCpp
<-
showAction
HostOsCpp
[
hostOsCpp
]
<-
showAction
HostOsCpp
return
$
hostOsCpp
`
elem
`
[
"mingw32"
,
"cygwin32"
]
src/Package.hs
View file @
a4f318fd
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoImplicitPrelude
, ScopedTypeVariables
#-}
module
Package
(
packageRules
)
where
...
...
@@ -50,7 +50,7 @@ libraryPackage name stage settings =
)]
commonCcArgs
::
Args
commonCcArgs
=
when
Validating
$
arg
[
"-Werror"
,
"-Wall"
]
commonCcArgs
=
when
Validating
$
arg
s
"-Werror"
"-Wall"
commonLdArgs
::
Args
commonLdArgs
=
mempty
-- TODO: Why empty? Perhaps drop it altogether?
...
...
@@ -60,21 +60,17 @@ commonCppArgs = mempty -- TODO: Why empty? Perhaps drop it altogether?
commonCcWarninigArgs
::
Args
commonCcWarninigArgs
=
when
Validating
$
mconcat
[
when
GccIsClang
$
arg
[
"-Wno-unknown-pragmas"
]
,
when
(
not
GccIsClang
&&
not
GccLt46
)
$
arg
[
"-Wno-error=inline"
]
,
when
(
GccIsClang
&&
not
GccLt46
)
$
hostOsCppWarning
[
when
GccIsClang
$
arg
"-Wno-unknown-pragmas"
,
when
(
not
GccIsClang
&&
not
GccLt46
)
$
arg
"-Wno-error=inline"
,
when
(
GccIsClang
&&
not
GccLt46
&&
windowsHost
)
$
arg
"-Werror=unused-but-set-variable"
]
where
hostOsCppWarning
=
do
hostOsCpp
<-
option
HostOsCpp
when
(
hostOsCpp
/=
"mingw32"
)
$
arg
[
"-Werror=unused-but-set-variable"
]
bootPkgConstraints
::
Args
bootPkgConstraints
=
mempty
libraryArgs
::
[
Way
]
->
Args
libraryArgs
ways
=
let
argEnable
x
suffix
=
arg
[
(
if
x
then
"--enable-"
else
"--disable-"
)
++
suffix
]
let
argEnable
x
suffix
=
arg
$
(
if
x
then
"--enable-"
else
"--disable-"
)
++
suffix
in
mconcat
[
argEnable
False
"library-for-ghci"
-- TODO: why always disable?
,
argEnable
(
vanilla
`
elem
`
ways
)
"library-vanilla"
...
...
@@ -86,32 +82,31 @@ libraryArgs ways =
configureArgs
::
Stage
->
Settings
->
Args
configureArgs
stage
settings
=
let
argConf
key
args
=
joinArgs
$
arg
[
"--configure-option="
,
key
,
"="
]
<>
joinArgsWithSpaces
args
let
argConf
::
String
->
Args
->
Args
argConf
key
as
=
joinArgs
"--configure-option="
key
"="
as
argConfWith
key
opt
=
do
value
<-
option
opt
when
(
value
/=
""
)
$
argConf
(
"--with-"
++
key
)
$
arg
[
value
]
cflags
=
mconcat
[
commonCcArgs
`
filterOut
`
[
"-Werror"
]
,
argOption
$
ConfCcArgs
stage
,
customCcArgs
settings
,
commonCcWarninigArgs
]
ldflags
=
mconcat
[
commonLdArgs
,
argOption
$
ConfGccLinkerArgs
stage
,
customLdArgs
settings
]
cppflags
=
mconcat
[
commonCppArgs
,
argOption
$
ConfCppArgs
stage
,
customCppArgs
settings
]
[
value
]
<-
showAction
opt
when
(
value
/=
""
)
$
argConf
(
"--with-"
++
key
)
$
arg
value
cflags
=
joinArgsSpaced
(
commonCcArgs
`
filterOut
`
[
"-Werror"
])
(
ConfCcArgs
stage
)
(
customCcArgs
settings
)
(
commonCcWarninigArgs
)
ldflags
=
joinArgsSpaced
commonLdArgs
(
ConfGccLinkerArgs
stage
)
(
customLdArgs
settings
)
cppflags
=
joinArgsSpaced
commonCppArgs
(
ConfCppArgs
stage
)
(
customCppArgs
settings
)
in
mconcat
[
argConf
"CFLAGS"
cflags
,
argConf
"LDFLAGS"
ldflags
,
argConf
"CPPFLAGS"
cppflags
,
joinArgs
$
mconcat
[
arg
[
"--gcc-options="
],
cflags
,
arg
[
" "
],
ldflags
]
,
joinArgs
"--gcc-options="
cflags
" "
ldflags
,
argConfWith
"iconv-includes"
IconvIncludeDirs
,
argConfWith
"iconv-libraries"
IconvLibDirs
,
argConfWith
"gmp-includes"
GmpIncludeDirs
,
argConfWith
"gmp-libraries"
GmpLibDirs
,
when
CrossCompiling
$
argConf
"--host"
$
arg
Option
$
TargetPlatformFull
-- TODO: why not host?
,
argConf
"--with-cc"
$
arg
Path
Gcc
,
when
CrossCompiling
$
argConf
"--host"
$
arg
TargetPlatformFull
-- TODO: why not host?
,
argConf
"--with-cc"
$
arg
Gcc
]
buildPackageData
::
Package
->
TodoItem
->
Rules
()
...
...
@@ -132,11 +127,11 @@ buildPackageData pkg @ (Package name path _) (stage, dist, settings) =
where
cabalArgs
,
ghcPkgArgs
::
Args
cabalArgs
=
mconcat
[
arg
[
"configure"
,
path
,
dist
]
[
arg
s
"configure"
path
dist
-- this is a positional argument, hence:
-- * if it is empty, we need to emit one empty string argument
-- * if there are many, we must collapse them into one string argument
,
joinArgs
With
Space
s
$
customDllArgs
settings
,
joinArgsSpace
d
$
customDllArgs
settings
,
with
$
Ghc
stage
-- TODO: used to be stage01 (using max Stage1 GHC)
,
with
$
GhcPkg
stage
...
...
@@ -155,11 +150,9 @@ buildPackageData pkg @ (Package name path _) (stage, dist, settings) =
,
with
Happy
]
-- TODO: reorder with's
ghcPkgArgs
=
mconcat
[
arg
[
"update"
,
"--force"
]
,
when
(
stage
==
Stage0
)
$
arg
[
"--package-db=libraries/bootstrapping.conf"
]
,
arg
[
path
</>
dist
</>
"inplace-pkg-config"
]
]
ghcPkgArgs
=
args
"update"
"--force"
(
when
(
stage
==
Stage0
)
$
arg
"--package-db=libraries/bootstrapping.conf"
)
(
path
</>
dist
</>
"inplace-pkg-config"
)
-- $1_$2_$3_MOST_DIR_HC_OPTS = \
...
...
@@ -239,7 +232,7 @@ buildPackageDeps pkg @ (Package name path _) (stage, dist, settings) =
run
(
Ghc
stage
)
$
mconcat
[
arg
[
"-M"
]
,
wayHcOpts
vanilla
-- TODO: i) is this needed? ii) shall we run GHC -M multiple times?
,
splitArgs
$
arg
Option
SrcHcOpts
,
splitArgs
$
arg
[
SrcHcOpts
]
,
when
(
stage
==
Stage0
)
$
arg
[
"-package-db libraries/bootstrapping.conf"
]
,
arg
[
if
usePackageKey
then
"-this-package-key"
else
"-package-name"
]
,
arg
[
packageKey
]
-- TODO: check reasoning ($$($4_THIS_PACKAGE_KEY) $$($1_$2_PACKAGE_KEY))
...
...
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