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
GHC
Commits
28a80787
Commit
28a80787
authored
Jul 25, 2015
by
Andrey Mokhov
Browse files
Clean up.
parent
4bd88123
Changes
7
Hide whitespace changes
Inline
Side-by-side
src/Expression.hs
View file @
28a80787
...
...
@@ -9,8 +9,8 @@ module Expression (
apply
,
append
,
appendM
,
remove
,
appendSub
,
appendSubD
,
filterSub
,
removeSub
,
interpret
,
interpretExpr
,
getStage
,
getPackage
,
getBuilder
,
getFiles
,
getWay
,
stage
,
package
,
builder
,
file
,
way
getStage
,
getPackage
,
getBuilder
,
getFiles
,
getFile
,
getWay
,
stage
,
package
,
builder
,
stagedBuilder
,
file
,
way
)
where
import
Way
...
...
@@ -164,6 +164,15 @@ getBuilder = asks Target.builder
getFiles
::
Expr
[
FilePath
]
getFiles
=
asks
Target
.
files
-- Run getFiles and check that it contains a single file only
getFile
::
Expr
FilePath
getFile
=
do
target
<-
ask
files
<-
getFiles
case
files
of
[
file
]
->
return
file
_
->
error
$
"Exactly one file expected in target "
++
show
target
getWay
::
Expr
Way
getWay
=
asks
Target
.
way
...
...
@@ -174,9 +183,17 @@ stage s = liftM (s ==) getStage
package
::
Package
->
Predicate
package
p
=
liftM
(
p
==
)
getPackage
-- For unstaged builders, e.g. GhcCabal
builder
::
Builder
->
Predicate
builder
b
=
liftM
(
b
==
)
getBuilder
-- For staged builders, e.g. Ghc Stage
stagedBuilder
::
(
Stage
->
Builder
)
->
Predicate
stagedBuilder
sb
=
do
stage
<-
getStage
builder
<-
getBuilder
return
$
builder
==
sb
stage
file
::
FilePattern
->
Predicate
file
f
=
liftM
(
any
(
f
?==
))
getFiles
...
...
src/Package/Base.hs
View file @
28a80787
...
...
@@ -26,8 +26,8 @@ import qualified System.Directory as S
--pathArgs :: ShowArgs a => String -> FilePath -> a -> Args
--pathArgs key path as = map (\a -> key ++ unifyPath (path </> a)) <$> args as
prefixedPath
::
String
->
[
Settings
]
->
Settings
prefixedPath
prefix
=
argPrefix
prefix
.
argConcatPath
.
sconcat
--
prefixedPath :: String -> [Settings] -> Settings
--
prefixedPath prefix = argPrefix prefix . argConcatPath . sconcat
--includeGccArgs :: FilePath -> FilePath -> Args
--includeGccArgs path dist =
...
...
@@ -38,34 +38,34 @@ prefixedPath prefix = argPrefix prefix . argConcatPath . sconcat
-- , pathArgs "-I" path $ DepIncludeDirs pathDist ]
includeGccSettings
::
Settings
includeGccSettings
=
mconcat
[
prefixedPath
"-I"
[
argBuildPath
,
argBuildDir
,
arg
"build"
,
arg
"autogen"
]
,
argPrefix
"-I"
$
argPaths
...
,
prefixedPath
"-I"
[
argBuildPath
,
argIncludeDirs
]
-- wrong
,
prefixedPath
"-I"
[
argBuildPath
,
argDepIncludeDirs
]]
includeGhcSettings
::
Settings
includeGhcSettings
=
let
buildDir
=
argBuildPath
`
fence
`
argSrcDirs
in
arg
"-i"
`
fence
`
mconcat
[
argPathList
"-i"
[
argBuildPath
,
argSrcDirs
]
,
argPath
"-i"
buildDir
,
argPath
"-I"
buildDir
,
argPathList
"-i"
[
buildDir
,
arg
"autogen"
]
,
argPathList
"-I"
[
buildDir
,
arg
"autogen"
]
,
argPathList
"-I"
[
argBuildPath
,
argIncludeDirs
]
,
arg
"-optP-include"
-- TODO: Shall we also add -cpp?
,
argPathList
"-optP"
[
buildDir
,
arg
"autogen/cabal_macros.h"
]
]
pkgHsSources
::
FilePath
->
FilePath
->
Action
[
FilePath
]
pkgHsSources
path
dist
=
do
let
pathDist
=
path
</>
dist
autogen
=
pathDist
</>
"build/autogen"
dirs
<-
map
(
path
</>
)
<$>
args
(
SrcDirs
pathDist
)
findModuleFiles
pathDist
(
autogen
:
dirs
)
[
".hs"
,
".lhs"
]
--
includeGccSettings :: Settings
--
includeGccSettings = mconcat
--
[ prefixedPath "-I" [argBuildPath, argBuildDir, arg "build", arg "autogen"]
--
, argPrefix "-I" $ argPaths ...
--
, prefixedPath "-I" [argBuildPath, argIncludeDirs ] -- wrong
--
, prefixedPath "-I" [argBuildPath, argDepIncludeDirs ]]
--
includeGhcSettings :: Settings
--
includeGhcSettings =
--
let buildDir = argBuildPath `fence` argSrcDirs
--
in arg "-i" `fence`
--
mconcat
--
[ argPathList "-i" [argBuildPath, argSrcDirs]
--
, argPath "-i" buildDir
--
, argPath "-I" buildDir
--
, argPathList "-i" [buildDir, arg "autogen"]
--
, argPathList "-I" [buildDir, arg "autogen"]
--
, argPathList "-I" [argBuildPath, argIncludeDirs]
--
, arg "-optP-include" -- TODO: Shall we also add -cpp?
--
, argPathList "-optP" [buildDir, arg "autogen/cabal_macros.h"] ]
--
pkgHsSources :: FilePath -> FilePath -> Action [FilePath]
--
pkgHsSources path dist = do
--
let pathDist = path </> dist
--
autogen = pathDist </> "build/autogen"
--
dirs <- map (path </>) <$> args (SrcDirs pathDist)
--
findModuleFiles pathDist (autogen:dirs) [".hs", ".lhs"]
-- TODO: look for non-{hs,c} objects too
...
...
@@ -101,19 +101,19 @@ pkgLibHsObjects path dist stage way = do
findModuleFiles
pathDist
[
buildDir
]
[
suffix
]
else
do
return
depObjs
findModuleFiles
::
FilePath
->
[
FilePath
]
->
[
String
]
->
Action
[
FilePath
]
findModuleFiles
pathDist
directories
suffixes
=
do
modPaths
<-
map
(
replaceEq
'.'
pathSeparator
)
<$>
args
(
Modules
pathDist
)
fileList
<-
forM
[
dir
</>
modPath
++
suffix
|
dir
<-
directories
,
modPath
<-
modPaths
,
suffix
<-
suffixes
]
$
\
file
->
do
let
dir
=
takeDirectory
file
dirExists
<-
liftIO
$
S
.
doesDirectoryExist
dir
when
dirExists
$
return
$
unifyPath
file
files
<-
getDirectoryFiles
""
fileList
return
$
map
unifyPath
files
--
findModuleFiles :: FilePath -> [FilePath] -> [String] -> Action [FilePath]
--
findModuleFiles pathDist directories suffixes = do
--
modPaths <- map (replaceEq '.' pathSeparator) <$> args (Modules pathDist)
--
fileList <- forM [ dir </> modPath ++ suffix
--
| dir <- directories
--
, modPath <- modPaths
--
, suffix <- suffixes
--
] $ \file -> do
--
let dir = takeDirectory file
--
dirExists <- liftIO $ S.doesDirectoryExist dir
--
when dirExists $ return $ unifyPath file
--
files <- getDirectoryFiles "" fileList
--
return $ map unifyPath files
-- The argument list has a limited size on Windows. Since Windows 7 the limit
-- is 32768 (theoretically). In practice we use 31000 to leave some breathing
...
...
@@ -128,29 +128,29 @@ argSizeLimit = do
-- List of source files, which need to be tracked by the build system
-- to make sure the argument lists have not changed.
sourceDependecies
::
[
FilePath
]
sourceDependecies
=
[
"shake/src/Package/Base.hs"
,
"shake/src/Oracles/Base.hs"
,
"shake/src/Oracles/Flag.hs"
,
"shake/src/Oracles/Option.hs"
,
"shake/src/Oracles/Builder.hs"
,
"shake/src/Oracles/PackageData.hs"
,
"shake/src/Ways.hs"
,
"shake/src/Util.hs"
,
"shake/src/Oracles.hs"
]
-- Convert Builder's argument list to a printable String
argListWithComment
::
String
->
Builder
->
Args
->
Action
String
argListWithComment
comment
builder
args
=
do
args'
<-
args
return
$
show
builder
++
" arguments"
++
(
if
null
comment
then
""
else
" ("
++
comment
++
")"
)
++
":
\n
"
++
concatMap
(
\
s
->
" "
++
s
++
"
\n
"
)
args'
argList
::
Builder
->
Args
->
Action
String
argList
=
argListWithComment
""
-- Path to argument list for a given Package/Stage combination
argListPath
::
FilePath
->
Package
->
Stage
->
FilePath
argListPath
dir
(
Package
name
_
_
_
)
stage
=
dir
</>
takeBaseName
name
++
" (stage "
++
show
stage
++
")"
<.>
"txt"
--
sourceDependecies :: [FilePath]
--
sourceDependecies = [ "shake/src/Package/Base.hs"
--
, "shake/src/Oracles/Base.hs"
--
, "shake/src/Oracles/Flag.hs"
--
, "shake/src/Oracles/Option.hs"
--
, "shake/src/Oracles/Builder.hs"
--
, "shake/src/Oracles/PackageData.hs"
--
, "shake/src/Ways.hs"
--
, "shake/src/Util.hs"
--
, "shake/src/Oracles.hs" ]
--
-- Convert Builder's argument list to a printable String
--
argListWithComment :: String -> Builder -> Args -> Action String
--
argListWithComment comment builder args = do
--
args' <- args
--
return $ show builder ++ " arguments"
--
++ (if null comment then "" else " (" ++ comment ++ ")")
--
++ ":\n" ++ concatMap (\s -> " " ++ s ++ "\n") args'
--
argList :: Builder -> Args -> Action String
--
argList = argListWithComment ""
--
-- Path to argument list for a given Package/Stage combination
--
argListPath :: FilePath -> Package -> Stage -> FilePath
--
argListPath dir (Package name _ _ _) stage =
--
dir </> takeBaseName name ++ " (stage " ++ show stage ++ ")" <.> "txt"
src/Settings/GccM.hs
View file @
28a80787
...
...
@@ -2,40 +2,34 @@ module Settings.GccM (gccMArgs) where
import
Util
import
Builder
import
Package
import
Expression
import
Oracles.PackageData
import
Settings.Util
import
Settings.TargetDirectory
-- TODO: handle custom $1_$2_MKDEPENDC_OPTS and
gccMArgs
::
Args
gccMArgs
=
do
stage
<-
getStage
builder
(
GccM
stage
)
?
do
pkg
<-
getPackage
files
<-
getFiles
ccArgs
<-
getPkgDataList
CcArgs
let
file
=
head
files
path
=
targetPath
stage
pkg
-/-
"build"
mconcat
[
arg
"-E"
,
arg
"-MM"
,
append
ccArgs
-- TODO: remove? any other flags?
,
includeGccArgs
,
arg
"-MF"
,
arg
$
path
-/-
takeFileName
file
<.>
"deps"
,
arg
"-x"
,
arg
"c"
,
arg
file
]
gccMArgs
=
stagedBuilder
GccM
?
do
path
<-
getTargetPath
file
<-
getFile
ccArgs
<-
getPkgDataList
CcArgs
mconcat
[
arg
"-E"
,
arg
"-MM"
,
append
ccArgs
-- TODO: remove? any other flags?
,
includeGccArgs
,
arg
"-MF"
,
arg
$
path
-/-
"build"
-/-
takeFileName
file
<.>
"deps"
,
arg
"-x"
,
arg
"c"
,
arg
file
]
includeGccArgs
::
Args
includeGccArgs
=
do
stage
<-
get
Stage
pkg
<-
getPackage
incDirs
<-
getP
kgDataList
IncludeDirs
depInc
Dirs
<-
getPkgDataList
Dep
IncludeDirs
let
path
=
p
kg
P
at
h
pkg
path
<-
get
TargetPath
pkg
Path
<-
getPackage
Path
pkg
<-
getP
ackage
i
Dirs
<-
getPkgDataList
IncludeDirs
dDirs
<-
getP
kg
D
at
aList
DepIncludeDirs
mconcat
[
arg
$
"-I"
++
targetPath
stage
pkg
-/-
"build/autogen"
,
append
.
map
(
\
dir
->
"-I"
++
path
-/-
dir
)
$
i
nc
Dirs
++
d
epInc
Dirs
]
[
arg
$
"-I"
++
path
-/-
"build/autogen"
,
append
.
map
(
\
dir
->
"-I"
++
p
kgP
ath
-/-
dir
)
$
iDirs
++
dDirs
]
src/Settings/GhcCabal.hs
View file @
28a80787
...
...
@@ -3,9 +3,10 @@ module Settings.GhcCabal (
)
where
import
Way
import
Util
import
Stage
import
Builder
import
Package
import
Util
import
Switches
import
Expression
import
Oracles.Base
...
...
@@ -15,26 +16,25 @@ import Settings.User
import
Settings.Ways
import
Settings.Util
import
Settings.Packages
import
Settings.TargetDirectory
import
Data.List
import
Control.Applicative
cabalArgs
::
Args
cabalArgs
=
builder
GhcCabal
?
do
stage
<-
get
Stage
pkg
<-
get
Package
path
<-
get
PackagePath
dir
<-
get
TargetDirectory
mconcat
[
arg
"configure"
,
arg
$
pkgPath
pkg
,
arg
$
targetDirectory
stage
pkg
,
arg
path
,
arg
dir
,
dllArgs
,
with
$
Ghc
stage
,
with
$
GhcPkg
stage
,
with
Staged
Ghc
,
with
Staged
GhcPkg
,
stage0
?
bootPackageDbArgs
,
libraryArgs
,
with
HsColour
,
configureArgs
,
stage0
?
packageConstraints
,
with
$
Gcc
stage
,
with
Staged
Gcc
,
notStage0
?
with
Ld
,
with
Ar
,
with
Alex
...
...
@@ -43,12 +43,12 @@ cabalArgs = builder GhcCabal ? do
-- TODO: Isn't vanilla always built? If yes, some conditions are redundant.
libraryArgs
::
Args
libraryArgs
=
do
ways
<-
getWays
ghcInt
erpreter
<-
lift
$
ghcWithInterpreter
ways
<-
getWays
ghcInt
<-
lift
$
ghcWithInterpreter
append
[
if
vanilla
`
elem
`
ways
then
"--enable-library-vanilla"
else
"--disable-library-vanilla"
,
if
vanilla
`
elem
`
ways
&&
ghcInt
erpreter
&&
not
dynamicGhcPrograms
,
if
vanilla
`
elem
`
ways
&&
ghcInt
&&
not
dynamicGhcPrograms
then
"--enable-library-for-ghci"
else
"--disable-library-for-ghci"
,
if
profiling
`
elem
`
ways
...
...
@@ -82,8 +82,8 @@ configureArgs = do
bootPackageDbArgs
::
Args
bootPackageDbArgs
=
do
sourceP
ath
<-
getSetting
GhcSourcePath
arg
$
"--package-db="
++
sourceP
ath
-/-
"libraries/bootstrapping.conf"
p
ath
<-
getSetting
GhcSourcePath
arg
$
"--package-db="
++
p
ath
-/-
"libraries/bootstrapping.conf"
-- This is a positional argument, hence:
-- * if it is empty, we need to emit one empty string argument;
...
...
@@ -110,7 +110,7 @@ packageConstraints = do
-- TODO: put all validating options together in one file
ccArgs
::
Args
ccArgs
=
validating
?
do
let
gccGe46
=
liftM
not
gccLt46
let
gccGe46
=
not
P
gccLt46
mconcat
[
arg
"-Werror"
,
arg
"-Wall"
,
gccIsClang
??
...
...
@@ -155,3 +155,8 @@ with builder = specified builder ? do
path
<-
lift
$
builderPath
builder
lift
$
needBuilder
builder
append
[
withBuilderKey
builder
++
path
]
withStaged
::
(
Stage
->
Builder
)
->
Args
withStaged
sb
=
do
stage
<-
getStage
with
$
sb
stage
src/Settings/GhcM.hs
View file @
28a80787
...
...
@@ -4,38 +4,34 @@ import Way
import
Util
import
Stage
import
Builder
import
Package
import
Switches
import
Expression
import
Oracles.Flag
import
Oracles.PackageData
import
Settings.Util
import
Settings.Ways
import
Settings.TargetDirectory
import
Development.Shake
ghcMArgs
::
Args
ghcMArgs
=
do
stage
<-
getStage
builder
(
GhcM
stage
)
?
do
pkg
<-
getPackage
cppArgs
<-
getPkgDataList
CppArgs
hsArgs
<-
getPkgDataList
HsArgs
hsSrcs
<-
getHsSources
ways
<-
getWays
let
buildPath
=
targetPath
stage
pkg
-/-
"build"
mconcat
[
arg
"-M"
,
packageGhcArgs
,
includeGhcArgs
,
append
.
map
(
"-optP"
++
)
$
cppArgs
,
arg
"-odir"
,
arg
buildPath
,
arg
"-stubdir"
,
arg
buildPath
,
arg
"-hidir"
,
arg
buildPath
,
arg
"-dep-makefile"
,
arg
$
buildPath
-/-
"haskell.deps"
,
append
.
concatMap
(
\
way
->
[
"-dep-suffix"
,
wayPrefix
way
])
$
ways
,
append
hsArgs
,
append
hsSrcs
]
ghcMArgs
=
stagedBuilder
GhcM
?
do
ways
<-
getWays
hsSrcs
<-
getHsSources
hsArgs
<-
getPkgDataList
HsArgs
cppArgs
<-
getPkgDataList
CppArgs
path
<-
getTargetPath
let
buildPath
=
path
-/-
"build"
mconcat
[
arg
"-M"
,
packageGhcArgs
,
includeGhcArgs
,
append
.
map
(
"-optP"
++
)
$
cppArgs
,
arg
"-odir"
,
arg
buildPath
,
arg
"-stubdir"
,
arg
buildPath
,
arg
"-hidir"
,
arg
buildPath
,
arg
"-dep-makefile"
,
arg
$
buildPath
-/-
"haskell.deps"
,
append
.
concatMap
(
\
way
->
[
"-dep-suffix"
,
wayPrefix
way
])
$
ways
,
append
hsArgs
,
append
hsSrcs
]
packageGhcArgs
::
Args
packageGhcArgs
=
do
...
...
@@ -57,30 +53,29 @@ packageGhcArgs = do
includeGhcArgs
::
Args
includeGhcArgs
=
do
stage
<-
get
Stage
pkg
<-
getPackage
path
<-
get
TargetPath
pkg
Path
<-
getPackage
Path
srcDirs
<-
getPkgDataList
SrcDirs
incDirs
<-
getPkgDataList
IncludeDirs
let
buildPath
=
targetPath
stage
pkg
-/-
"build"
let
buildPath
=
path
-/-
"build"
autogenPath
=
buildPath
-/-
"autogen"
mconcat
[
arg
"-i"
,
append
.
map
(
\
dir
->
"-i"
++
pkgPath
pkg
-/-
dir
)
$
srcDirs
,
append
.
map
(
\
dir
->
"-i"
++
pkgPath
-/-
dir
)
$
srcDirs
,
arg
$
"-i"
++
buildPath
,
arg
$
"-i"
++
autogenPath
,
arg
$
"-I"
++
buildPath
,
arg
$
"-I"
++
autogenPath
,
append
.
map
(
\
dir
->
"-I"
++
pkgPath
pkg
-/-
dir
)
$
incDirs
,
append
.
map
(
\
dir
->
"-I"
++
pkgPath
-/-
dir
)
$
incDirs
,
arg
"-optP-include"
-- TODO: Shall we also add -cpp?
,
arg
$
"-optP"
++
autogenPath
-/-
"cabal_macros.h"
]
getHsSources
::
Expr
[
FilePath
]
getHsSources
=
do
stage
<-
get
Stage
pkg
<-
getPackage
path
<-
get
TargetPath
pkg
Path
<-
getPackage
Path
srcDirs
<-
getPkgDataList
SrcDirs
let
autogen
=
targetPath
stage
pkg
-/-
"build/autogen"
paths
=
autogen
:
map
(
pkgPath
pkg
-/-
)
srcDirs
let
paths
=
(
path
-/-
"build/autogen"
)
:
map
(
pkgPath
-/-
)
srcDirs
getSourceFiles
paths
[
".hs"
,
".lhs"
]
-- Find all source files in specified paths and with given extensions
...
...
src/Settings/GhcPkg.hs
View file @
28a80787
...
...
@@ -6,14 +6,11 @@ import Switches
import
Expression
import
Settings.Util
import
Settings.GhcCabal
import
Settings.TargetDirectory
ghcPkgArgs
::
Args
ghcPkgArgs
=
do
stage
<-
getStage
pkg
<-
getPackage
builder
(
GhcPkg
stage
)
?
mconcat
[
arg
"update"
,
arg
"--force"
,
stage0
?
bootPackageDbArgs
,
arg
$
targetPath
stage
pkg
-/-
"inplace-pkg-config"
]
ghcPkgArgs
=
stagedBuilder
GhcPkg
?
do
path
<-
getTargetPath
mconcat
[
arg
"update"
,
arg
"--force"
,
stage0
?
bootPackageDbArgs
,
arg
$
path
-/-
"inplace-pkg-config"
]
src/Settings/Util.hs
View file @
28a80787
...
...
@@ -4,6 +4,7 @@ module Settings.Util (
argSetting
,
argSettingList
,
getFlag
,
getSetting
,
getSettingList
,
getPkgData
,
getPkgDataList
,
getPackagePath
,
getTargetPath
,
getTargetDirectory
,
appendCcArgs
,
needBuilder
-- argBuilderPath, argStagedBuilderPath,
...
...
@@ -15,6 +16,7 @@ module Settings.Util (
)
where
import
Builder
import
Package
import
Expression
import
Oracles.Base
import
Oracles.Flag
...
...
@@ -57,6 +59,15 @@ getPkgDataList key = do
pkg
<-
getPackage
lift
.
pkgDataList
.
key
$
targetPath
stage
pkg
getPackagePath
::
Expr
FilePath
getPackagePath
=
liftM
pkgPath
getPackage
getTargetPath
::
Expr
FilePath
getTargetPath
=
liftM2
targetPath
getStage
getPackage
getTargetDirectory
::
Expr
FilePath
getTargetDirectory
=
liftM2
targetDirectory
getStage
getPackage
-- Pass arguments to Gcc and corresponding lists of sub-arguments of GhcCabal
appendCcArgs
::
[
String
]
->
Args
appendCcArgs
xs
=
do
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a 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