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
7412fe39
Commit
7412fe39
authored
Jan 16, 2015
by
Andrey Mokhov
Browse files
Add ShowArg for single string options, clean up code.
parent
3cbacccf
Changes
8
Hide whitespace changes
Inline
Side-by-side
src/Base.hs
View file @
7412fe39
...
...
@@ -8,7 +8,7 @@ module Base (
module
Data
.
Monoid
,
module
Data
.
List
,
Stage
(
..
),
Args
,
arg
,
ShowArgs
(
..
),
Args
,
arg
,
ShowArg
(
..
),
ShowArgs
(
..
),
Condition
(
..
),
(
<+>
),
filterOut
,
...
...
@@ -37,6 +37,9 @@ instance Monoid a => Monoid (Action a) where
mempty
=
return
mempty
mappend
p
q
=
mappend
<$>
p
<*>
q
class
ShowArg
a
where
showArg
::
a
->
Action
String
-- Using the Creators' trick for overlapping String instances
class
ShowArgs
a
where
showArgs
::
a
->
Args
...
...
src/Config.hs
View file @
7412fe39
...
...
@@ -3,6 +3,7 @@ module Config (
)
where
import
Base
import
Util
cfgPath
::
FilePath
cfgPath
=
"shake"
</>
"cfg"
...
...
@@ -10,11 +11,15 @@ cfgPath = "shake" </> "cfg"
autoconfRules
::
Rules
()
autoconfRules
=
do
"configure"
%>
\
out
->
do
need
[
"shake/src/Config.hs"
]
copyFile'
(
cfgPath
</>
"configure.ac"
)
"configure.ac"
putColoured
Vivid
White
$
"Running autoconf..."
cmd
"bash autoconf"
-- TODO: get rid of 'bash'
configureRules
::
Rules
()
configureRules
=
do
cfgPath
</>
"default.config"
%>
\
out
->
do
need
[
"shake/src/Config.hs"
]
need
[
cfgPath
</>
"default.config.in"
,
"configure"
]
putColoured
Vivid
White
"Running configure..."
cmd
"bash configure"
-- TODO: get rid of 'bash'
src/Oracles.hs
View file @
7412fe39
...
...
@@ -10,6 +10,7 @@ module Oracles (
import
Development.Shake.Config
import
qualified
Data.HashMap.Strict
as
M
import
Base
import
Util
import
Config
import
Oracles.Base
import
Oracles.Flag
...
...
@@ -31,15 +32,21 @@ configOracle = do
++
"' is missing; unwilling to proceed."
return
()
need
[
defaultConfig
]
putNormal
$
"Parsing "
++
toStandard
defaultConfig
++
"..."
cfgDefault
<-
liftIO
$
readConfigFile
defaultConfig
existsUser
<-
doesFileExist
userConfig
cfgUser
<-
if
existsUser
then
liftIO
$
readConfigFile
userConfig
then
do
putNormal
$
"Parsing "
++
toStandard
userConfig
++
"..."
liftIO
$
readConfigFile
userConfig
else
do
putLoud
$
"
\n
User defined configuration file '"
putColoured
Dull
Red
$
"
\n
User defined configuration file '"
++
userConfig
++
"' is missing; "
++
"proceeding with default configuration.
\n
"
return
M
.
empty
putColoured
Vivid
Green
$
"Finished processing configuration files."
return
$
cfgUser
`
M
.
union
`
cfgDefault
addOracle
$
\
(
ConfigKey
key
)
->
M
.
lookup
key
<$>
cfg
()
return
()
...
...
src/Oracles/Builder.hs
View file @
7412fe39
...
...
@@ -30,8 +30,8 @@ data Builder = Ar
|
GhcPkg
Stage
deriving
Show
instance
ShowArg
s
Builder
where
showArg
s
builder
=
showArgs
$
fmap
(
map
toStandard
.
words
)
$
do
instance
ShowArg
Builder
where
showArg
builder
=
toStandard
<$>
do
let
key
=
case
builder
of
Ar
->
"ar"
Ld
->
"ld"
...
...
@@ -49,7 +49,7 @@ instance ShowArgs Builder where
cfgPath
<-
askConfigWithDefault
key
$
error
$
"
\n
Cannot find path to '"
++
key
++
"' in configuration files."
let
cfgPathExe
=
if
cfgPath
/=
""
then
cfgPath
-<.>
exe
else
""
let
cfgPathExe
=
if
null
cfgPath
then
""
else
cfgPath
-<.>
exe
windows
<-
windowsHost
-- Note, below is different from FilePath.isAbsolute:
if
(
windows
&&
"/"
`
isPrefixOf
`
cfgPathExe
)
...
...
@@ -66,19 +66,17 @@ instance ShowArgs Builder where
-- should reset the flag (at least temporarily).
-- Make sure the builder exists on the given path and rebuild it if out of date
-- Raise an error if the builder is not uniquely specified in config files
needBuilder
::
Builder
->
Action
()
needBuilder
ghc
@
(
Ghc
stage
)
=
do
[
exe
]
<-
showArg
s
ghc
exe
<-
showArg
ghc
laxDeps
<-
test
LaxDeps
if
laxDeps
then
orderOnly
[
exe
]
else
need
[
exe
]
needBuilder
builder
=
do
[
exe
]
<-
showArg
s
builder
exe
<-
showArg
builder
need
[
exe
]
-- Action 'with Gcc' returns '--with-gcc=/path/to/gcc' and needs Gcc
-- Raises an error if the builder is not uniquely specified in config files
with
::
Builder
->
Args
with
builder
=
do
let
key
=
case
builder
of
...
...
@@ -90,17 +88,17 @@ with builder = do
Happy
->
"--with-happy="
GhcPkg
_
->
"--with-ghc-pkg="
HsColour
->
"--with-hscolour="
[
exe
]
<-
showArg
s
builder
exe
<-
showArg
builder
needBuilder
builder
arg
$
key
++
normaliseEx
exe
return
[
key
++
exe
]
-- Run the builder with a given collection of arguments
-- Raises an error if the builder is not uniquely specified in config files
run
::
ShowArgs
a
=>
Builder
->
a
->
Action
()
run
builder
as
=
do
needBuilder
builder
[
exe
]
<-
showArg
s
builder
args
<-
showArgs
as
exe
<-
showArg
builder
args
<-
showArgs
as
cmd
[
exe
]
args
-- Run the builder with a given collection of arguments printing out a
...
...
@@ -123,7 +121,7 @@ interestingInfo builder ss = case builder of
Ghc
_
->
if
head
ss
==
"-M"
then
prefixAndSuffix
1
1
ss
else
prefixAndSuffix
0
4
ss
GhcPkg
_
->
prefixAndSuffix
2
0
ss
GhcPkg
_
->
prefixAndSuffix
3
0
ss
GhcCabal
->
prefixAndSuffix
3
0
ss
_
->
ss
where
...
...
@@ -136,11 +134,6 @@ interestingInfo builder ss = case builder of
++
" arguments ..."
]
++
drop
(
length
ss
-
m
)
ss
-- Check if the builder is
uniquely
specified in config files
-- Check if the builder is specified in config files
specified
::
Builder
->
Condition
specified
builder
=
do
exes
<-
showArgs
builder
return
$
case
exes
of
[
_
]
->
True
_
->
False
specified
=
fmap
(
not
.
null
)
.
showArg
src/Oracles/Flag.hs
View file @
7412fe39
...
...
@@ -3,14 +3,15 @@
module
Oracles.Flag
(
module
Control
.
Monad
,
module
Prelude
,
Flag
(
..
),
test
,
when
,
unless
,
not
,
(
&&
),
(
||
)
,
(
<?>
)
Flag
(
..
),
test
,
when
,
unless
,
not
,
(
&&
),
(
||
)
)
where
import
Control.Monad
hiding
(
when
,
unless
)
import
qualified
Prelude
import
Prelude
hiding
(
not
,
(
&&
),
(
||
))
import
Base
import
Util
import
Oracles.Base
data
Flag
=
LaxDeps
...
...
@@ -39,8 +40,8 @@ test flag = do
SplitObjectsBroken
->
(
"split-objects-broken"
,
False
)
GhcUnregisterised
->
(
"ghc-unregisterised"
,
False
)
let
defaultString
=
if
defaultValue
then
"YES"
else
"NO"
value
<-
askConfigWithDefault
key
$
do
put
Lou
d
$
"
\n
Flag '"
value
<-
askConfigWithDefault
key
$
-- TODO: warn just once
do
put
Coloured
Dull
Re
d
$
"
\n
Flag '"
++
key
++
"' not set in configuration files. "
++
"Proceeding with default value '"
...
...
@@ -71,10 +72,6 @@ unless x act = do
bool
<-
toCondition
x
if
bool
then
mempty
else
act
-- Infix version of when
(
<?>
)
::
(
ToCondition
a
,
Monoid
m
)
=>
a
->
Action
m
->
Action
m
(
<?>
)
=
when
class
Not
a
where
type
NotResult
a
not
::
a
->
NotResult
a
...
...
src/Oracles/Option.hs
View file @
7412fe39
{-# LANGUAGE NoImplicitPrelude #-}
module
Oracles.Option
(
Option
(
..
),
Option
(
..
),
MultiOption
(
..
),
ghcWithInterpreter
,
platformSupportsSharedLibs
,
windowsHost
,
splitObjects
)
where
...
...
@@ -10,47 +10,56 @@ import Oracles.Base
-- For each Option the files {default.config, user.config} contain
-- a line of the form 'target-os = mingw32'.
-- (showArgs TargetOS) is an action that consults the config files
-- and returns ["mingw32"].
-- TODO: separate single string options from multiple string ones.
data
Option
=
TargetOS
-- (showArg TargetOs) is an action that consults the config files
-- and returns "mingw32".
--
-- MultiOption is used for multiple string options separated by spaces,
-- such as 'src-hc-args' = -H32m -O'.
-- (showArgs SrcHcArgs) therefore returns a list of strings ["-H32", "-O"].
data
Option
=
TargetOs
|
TargetArch
|
TargetPlatformFull
|
ConfCcArgs
Stage
|
ConfGccLinkerArgs
Stage
|
ConfLdLinkerArgs
Stage
|
ConfCppArgs
Stage
|
IconvIncludeDirs
|
IconvLibDirs
|
GmpIncludeDirs
|
GmpLibDirs
|
SrcHcOpts
|
HostOsCpp
|
DynamicExtension
|
ProjectVersion
instance
ShowArgs
Option
where
showArgs
opt
=
showArgs
$
fmap
words
$
askConfig
$
case
opt
of
TargetOS
->
"target-os"
data
MultiOption
=
SrcHcArgs
|
ConfCcArgs
Stage
|
ConfGccLinkerArgs
Stage
|
ConfLdLinkerArgs
Stage
|
ConfCppArgs
Stage
|
IconvIncludeDirs
|
IconvLibDirs
|
GmpIncludeDirs
|
GmpLibDirs
instance
ShowArg
Option
where
showArg
opt
=
askConfig
$
case
opt
of
TargetOs
->
"target-os"
TargetArch
->
"target-arch"
TargetPlatformFull
->
"target-platform-full"
ConfCcArgs
stage
->
"conf-cc-args-stage-"
++
show
stage
ConfCppArgs
stage
->
"conf-cpp-args-stage-"
++
show
stage
ConfGccLinkerArgs
stage
->
"conf-gcc-linker-args-stage-"
++
show
stage
ConfLdLinkerArgs
stage
->
"conf-ld-linker-args-stage-"
++
show
stage
HostOsCpp
->
"host-os-cpp"
DynamicExtension
->
"dynamic-extension"
ProjectVersion
->
"project-version"
instance
ShowArgs
MultiOption
where
showArgs
opt
=
showArgs
$
fmap
words
$
askConfig
$
case
opt
of
SrcHcArgs
->
"src-hc-args"
ConfCcArgs
stage
->
"conf-cc-args"
++
showStage
stage
ConfCppArgs
stage
->
"conf-cpp-args"
++
showStage
stage
ConfGccLinkerArgs
stage
->
"conf-gcc-linker-args"
++
showStage
stage
ConfLdLinkerArgs
stage
->
"conf-ld-linker-args"
++
showStage
stage
IconvIncludeDirs
->
"iconv-include-dirs"
IconvLibDirs
->
"iconv-lib-dirs"
GmpIncludeDirs
->
"gmp-include-dirs"
GmpLibDirs
->
"gmp-lib-dirs"
SrcHcOpts
->
"src-hc-opts"
HostOsCpp
->
"host-os-cpp"
DynamicExtension
->
"dynamic-extension"
ProjectVersion
->
"project-version"
where
showStage
=
(
"-stage-"
++
)
.
show
ghcWithInterpreter
::
Condition
ghcWithInterpreter
=
do
[
os
]
<-
showArg
s
TargetO
S
[
arch
]
<-
showArg
s
TargetArch
os
<-
showArg
TargetO
s
arch
<-
showArg
TargetArch
return
$
os
`
elem
`
[
"mingw32"
,
"cygwin32"
,
"linux"
,
"solaris2"
,
"freebsd"
,
"dragonfly"
,
"netbsd"
,
"openbsd"
,
...
...
@@ -60,7 +69,7 @@ ghcWithInterpreter = do
platformSupportsSharedLibs
::
Condition
platformSupportsSharedLibs
=
do
[
platform
]
<-
showArg
s
TargetPlatformFull
platform
<-
showArg
TargetPlatformFull
solarisBrokenShld
<-
test
SolarisBrokenShld
return
$
notElem
platform
$
[
"powerpc-unknown-linux"
,
...
...
@@ -70,19 +79,17 @@ platformSupportsSharedLibs = do
windowsHost
::
Condition
windowsHost
=
do
[
hostOsCpp
]
<-
showArg
s
HostOsCpp
hostOsCpp
<-
showArg
HostOsCpp
return
$
hostOsCpp
`
elem
`
[
"mingw32"
,
"cygwin32"
]
-- TODO: refactor helper Condition functions into a separate file
splitObjects
::
Stage
->
Condition
splitObjects
stage
=
do
[
os
]
<-
showArgs
TargetOS
[
arch
]
<-
showArgs
TargetArch
splitObjectsBroken
<-
test
SplitObjectsBroken
ghcUnregisterised
<-
test
GhcUnregisterised
return
$
not
splitObjectsBroken
&&
not
ghcUnregisterised
&&
stage
==
Stage1
&&
arch
`
elem
`
[
"i386"
,
"x86_64"
,
"powerpc"
,
"sparc"
]
&&
os
`
elem
`
[
"mingw32"
,
"cygwin32"
,
"linux"
,
"darwin"
,
"solaris2"
,
"freebsd"
,
"dragonfly"
,
"netbsd"
,
"openbsd"
]
arch
<-
showArg
TargetArch
os
<-
showArg
TargetOs
not
SplitObjectsBroken
&&
not
GhcUnregisterised
&&
stage
==
Stage1
&&
arch
`
elem
`
[
"i386"
,
"x86_64"
,
"powerpc"
,
"sparc"
]
&&
os
`
elem
`
[
"mingw32"
,
"cygwin32"
,
"linux"
,
"darwin"
,
"solaris2"
,
"freebsd"
,
"dragonfly"
,
"netbsd"
,
"openbsd"
]
src/Util.hs
View file @
7412fe39
...
...
@@ -35,6 +35,7 @@ chunksOfSize size ss = reverse chunk : chunksOfSize size rest
then
(
chunk
,
s
:
ss
)
else
(
newChunk
,
rest
)
-- A more colourful version of Shake's putNormal
putColoured
::
ColorIntensity
->
Color
->
String
->
Action
()
putColoured
intensity
colour
msg
=
do
liftIO
$
setSGR
[
SetColor
Foreground
intensity
colour
]
...
...
src/Ways.hs
View file @
7412fe39
{-# LANGUAGE NoImplicitPrelude #-}
module
Ways
(
WayUnit
(
..
),
Way
,
tag
,
allWays
,
defaultWays
,
Way
,
tag
,
vanilla
,
profiling
,
logging
,
parallel
,
granSim
,
threaded
,
threadedProfiling
,
threadedLogging
,
allWays
,
defaultWays
,
vanilla
,
profiling
,
logging
,
parallel
,
granSim
,
threaded
,
threadedProfiling
,
threadedLogging
,
debug
,
debugProfiling
,
threadedDebug
,
threadedDebugProfiling
,
dynamic
,
profilingDynamic
,
threadedProfilingDynamic
,
threadedDynamic
,
threadedDebugDynamic
,
debugDynamic
,
loggingDynamic
,
threadedLoggingDynamic
,
wayHcArgs
,
wayHcArgs
,
wayPrefix
,
hisuf
,
osuf
,
hcsuf
,
obootsuf
,
ssuf
,
libsuf
,
detectWay
...
...
@@ -61,8 +61,8 @@ debugDynamic = Way "debug_dyn" [Debug, Dynamic]
loggingDynamic
=
Way
"l_dyn"
[
Logging
,
Dynamic
]
threadedLoggingDynamic
=
Way
"thr_l_dyn"
[
Threaded
,
Logging
,
Dynamic
]
allWays
=
[
vanilla
,
profiling
,
logging
,
parallel
,
granSim
,
threaded
,
threadedProfiling
,
threadedLogging
,
allWays
=
[
vanilla
,
profiling
,
logging
,
parallel
,
granSim
,
threaded
,
threadedProfiling
,
threadedLogging
,
debug
,
debugProfiling
,
threadedDebug
,
threadedDebugProfiling
,
dynamic
,
profilingDynamic
,
threadedProfilingDynamic
,
threadedDynamic
,
threadedDebugDynamic
,
debugDynamic
,
...
...
@@ -72,22 +72,23 @@ defaultWays :: Stage -> Action [Way]
defaultWays
stage
=
do
sharedLibs
<-
platformSupportsSharedLibs
return
$
[
vanilla
]
++
[
profiling
|
stage
/=
Stage0
]
++
[
profiling
|
stage
/=
Stage0
]
++
[
dynamic
|
sharedLibs
]
-- TODO: do '-ticky' in all debug ways?
wayHcArgs
::
Way
->
Args
wayHcArgs
(
Way
_
units
)
=
(
Dynamic
`
notElem
`
units
)
<?>
arg
"-static"
<>
(
Dynamic
`
elem
`
units
)
<?>
arg
[
"-fPIC"
,
"-dynamic"
]
<>
(
Threaded
`
elem
`
units
)
<?>
arg
"-optc-DTHREADED_RTS"
<>
(
Debug
`
elem
`
units
)
<?>
arg
"-optc-DDEBUG"
<>
(
Profiling
`
elem
`
units
)
<?>
arg
"-prof"
<>
(
Logging
`
elem
`
units
)
<?>
arg
"-eventlog"
<>
(
Parallel
`
elem
`
units
)
<?>
arg
"-parallel"
<>
(
GranSim
`
elem
`
units
)
<?>
arg
"-gransim"
<>
(
units
==
[
Debug
]
||
units
==
[
Debug
,
Dynamic
])
<?>
arg
[
"-ticky"
,
"-DTICKY_TICKY"
]
wayHcArgs
(
Way
_
units
)
=
arg
[
if
(
Dynamic
`
elem
`
units
)
then
arg
[
"-fPIC"
,
"-dynamic"
]
else
arg
"-static"
,
when
(
Threaded
`
elem
`
units
)
$
arg
"-optc-DTHREADED_RTS"
,
when
(
Debug
`
elem
`
units
)
$
arg
"-optc-DDEBUG"
,
when
(
Profiling
`
elem
`
units
)
$
arg
"-prof"
,
when
(
Logging
`
elem
`
units
)
$
arg
"-eventlog"
,
when
(
Parallel
`
elem
`
units
)
$
arg
"-parallel"
,
when
(
GranSim
`
elem
`
units
)
$
arg
"-gransim"
,
when
(
units
==
[
Debug
]
||
units
==
[
Debug
,
Dynamic
])
$
arg
[
"-ticky"
,
"-DTICKY_TICKY"
]
]
wayPrefix
::
Way
->
String
wayPrefix
way
|
way
==
vanilla
=
""
...
...
@@ -110,8 +111,8 @@ libsuf way = do
if
Dynamic
`
notElem
`
units
way
then
return
$
staticSuffix
++
"a"
else
do
[
extension
]
<-
showArg
s
DynamicExtension
[
version
]
<-
showArg
s
ProjectVersion
extension
<-
showArg
DynamicExtension
version
<-
showArg
ProjectVersion
return
$
staticSuffix
++
"-ghc"
++
version
++
extension
-- TODO: This may be slow -- optimise if overhead is significant.
...
...
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