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
ff86f40e
Commit
ff86f40e
authored
Jul 24, 2015
by
Andrey Mokhov
Browse files
Refactoring for consistent interface (getters) for expressions.
parent
d9d1dd9e
Changes
11
Hide whitespace changes
Inline
Side-by-side
src/Expression.hs
View file @
ff86f40e
...
...
@@ -9,6 +9,7 @@ module Expression (
apply
,
append
,
appendM
,
remove
,
appendSub
,
appendSubD
,
filterSub
,
removeSub
,
interpret
,
interpretExpr
,
getStage
,
getPackage
,
getBuilder
,
getFiles
,
getWay
,
stage
,
package
,
builder
,
file
,
way
)
where
...
...
@@ -16,7 +17,9 @@ import Way
import
Stage
import
Builder
import
Package
import
Target
import
Target
(
Target
)
import
Target
hiding
(
Target
(
..
))
import
qualified
Target
import
Oracles.Base
import
Data.List
import
Data.Monoid
...
...
@@ -148,18 +151,34 @@ fromDiffExpr = fmap (($ mempty) . fromDiff)
interpret
::
Monoid
a
=>
Target
->
DiffExpr
a
->
Action
a
interpret
target
=
interpretExpr
target
.
fromDiffExpr
-- Convenient getters for target parameters
getStage
::
Expr
Stage
getStage
=
asks
Target
.
stage
getPackage
::
Expr
Package
getPackage
=
asks
Target
.
package
getBuilder
::
Expr
Builder
getBuilder
=
asks
Target
.
builder
getFiles
::
Expr
[
FilePath
]
getFiles
=
asks
Target
.
files
getWay
::
Expr
Way
getWay
=
asks
Target
.
way
-- Basic predicates (see Switches.hs for derived predicates)
stage
::
Stage
->
Predicate
stage
s
=
liftM
(
s
==
)
(
asks
getStage
)
stage
s
=
liftM
(
s
==
)
getStage
package
::
Package
->
Predicate
package
p
=
liftM
(
p
==
)
(
asks
getPackage
)
package
p
=
liftM
(
p
==
)
getPackage
builder
::
Builder
->
Predicate
builder
b
=
liftM
(
b
==
)
(
asks
getBuilder
)
builder
b
=
liftM
(
b
==
)
getBuilder
file
::
FilePattern
->
Predicate
file
f
=
liftM
(
any
(
f
?==
))
(
asks
getFiles
)
file
f
=
liftM
(
any
(
f
?==
))
getFiles
way
::
Way
->
Predicate
way
w
=
liftM
(
w
==
)
(
asks
getWay
)
way
w
=
liftM
(
w
==
)
getWay
src/Rules/Actions.hs
View file @
ff86f40e
...
...
@@ -5,6 +5,7 @@ module Rules.Actions (
import
Util
import
Builder
import
Expression
import
qualified
Target
import
Settings.Args
import
Settings.Util
import
Oracles.ArgsHash
...
...
@@ -18,7 +19,7 @@ build target = do
argList
<-
interpret
target
args
-- The line below forces the rule to be rerun if the args hash has changed
argsHash
<-
askArgsHash
target
run
(
get
B
uilder
target
)
argList
run
(
Tar
get
.
b
uilder
target
)
argList
buildWhen
::
Predicate
->
FullTarget
->
Action
()
buildWhen
predicate
target
=
do
...
...
src/Rules/Data.hs
View file @
ff86f40e
...
...
@@ -9,6 +9,7 @@ import Package
import
Builder
import
Switches
import
Expression
import
qualified
Target
import
Settings.GhcPkg
import
Settings.GhcCabal
import
Settings.TargetDirectory
...
...
@@ -20,8 +21,8 @@ import Development.Shake
-- Build package-data.mk by using GhcCabal to process pkgCabal file
buildPackageData
::
StagePackageTarget
->
Rules
()
buildPackageData
target
=
let
stage
=
get
S
tage
target
pkg
=
get
P
ackage
target
let
stage
=
Tar
get
.
s
tage
target
pkg
=
Tar
get
.
p
ackage
target
path
=
targetPath
stage
pkg
in
(
path
-/-
)
<$>
...
...
src/Settings/GhcCabal.hs
View file @
ff86f40e
...
...
@@ -21,8 +21,8 @@ import Control.Applicative
cabalArgs
::
Args
cabalArgs
=
builder
GhcCabal
?
do
stage
<-
asks
getStage
pkg
<-
asks
getPackage
stage
<-
getStage
pkg
<-
getPackage
mconcat
[
arg
"configure"
,
arg
$
pkgPath
pkg
,
arg
$
targetDirectory
stage
pkg
...
...
@@ -43,7 +43,7 @@ cabalArgs = builder GhcCabal ? do
-- TODO: Isn't vanilla always built? If yes, some conditions are redundant.
libraryArgs
::
Args
libraryArgs
=
do
ways
<-
fromDiffExpr
Settings
.
Ways
.
w
ays
ways
<-
getW
ays
ghcInterpreter
<-
lift
$
ghcWithInterpreter
append
[
if
vanilla
`
elem
`
ways
then
"--enable-library-vanilla"
...
...
@@ -60,7 +60,7 @@ libraryArgs = do
configureArgs
::
Args
configureArgs
=
do
stage
<-
asks
getStage
stage
<-
getStage
let
conf
key
=
appendSubD
$
"--configure-option="
++
key
cFlags
=
mconcat
[
ccArgs
,
remove
[
"-Werror"
]
...
...
@@ -82,7 +82,7 @@ configureArgs = do
bootPackageDbArgs
::
Args
bootPackageDbArgs
=
do
sourcePath
<-
lift
.
s
etting
$
GhcSourcePath
sourcePath
<-
getS
etting
GhcSourcePath
arg
$
"--package-db="
++
sourcePath
-/-
"libraries/bootstrapping.conf"
-- This is a positional argument, hence:
...
...
@@ -93,7 +93,7 @@ dllArgs = arg ""
packageConstraints
::
Args
packageConstraints
=
do
pkgs
<-
fromDiffExpr
p
ackages
pkgs
<-
getP
ackages
constraints
<-
lift
$
forM
pkgs
$
\
pkg
->
do
let
cabal
=
pkgPath
pkg
-/-
pkgCabal
pkg
prefix
=
dropExtension
(
pkgCabal
pkg
)
++
" == "
...
...
src/Settings/GhcM.hs
View file @
ff86f40e
...
...
@@ -16,13 +16,13 @@ import Development.Shake
ghcMArgs
::
Args
ghcMArgs
=
do
stage
<-
asks
getStage
stage
<-
getStage
builder
(
GhcM
stage
)
?
do
pkg
<-
asks
getPackage
pkg
<-
getPackage
cppArgs
<-
getPkgDataList
CppArgs
hsArgs
<-
getPkgDataList
HsArgs
hsSrcs
<-
getHsSources
ways
<-
fromDiffExpr
Settings
.
Ways
.
w
ays
ways
<-
getW
ays
let
buildPath
=
targetPath
stage
pkg
-/-
"build"
mconcat
[
arg
"-M"
...
...
@@ -39,9 +39,9 @@ ghcMArgs = do
packageGhcArgs
::
Args
packageGhcArgs
=
do
stage
<-
asks
getStage
supportsPackageKey
<-
lift
.
f
lag
$
SupportsPackageKey
pkgKey
<-
getPkgData
PackageKey
stage
<-
getStage
supportsPackageKey
<-
getF
lag
SupportsPackageKey
pkgKey
<-
getPkgData
PackageKey
pkgDepKeys
<-
getPkgDataList
DepKeys
pkgDeps
<-
getPkgDataList
Deps
mconcat
...
...
@@ -57,8 +57,8 @@ packageGhcArgs = do
includeGhcArgs
::
Args
includeGhcArgs
=
do
stage
<-
asks
getStage
pkg
<-
asks
getPackage
stage
<-
getStage
pkg
<-
getPackage
srcDirs
<-
getPkgDataList
SrcDirs
includeDirs
<-
getPkgDataList
IncludeDirs
let
buildPath
=
targetPath
stage
pkg
-/-
"build"
...
...
@@ -76,8 +76,8 @@ includeGhcArgs = do
getHsSources
::
Expr
[
FilePath
]
getHsSources
=
do
stage
<-
asks
getStage
pkg
<-
asks
getPackage
stage
<-
getStage
pkg
<-
getPackage
srcDirs
<-
getPkgDataList
SrcDirs
let
autogenPath
=
targetPath
stage
pkg
-/-
"build/autogen"
dirs
=
autogenPath
:
map
(
pkgPath
pkg
-/-
)
srcDirs
...
...
src/Settings/GhcPkg.hs
View file @
ff86f40e
...
...
@@ -12,8 +12,8 @@ import Settings.TargetDirectory
ghcPkgArgs
::
Args
ghcPkgArgs
=
do
stage
<-
asks
getStage
pkg
<-
asks
getPackage
stage
<-
getStage
pkg
<-
getPackage
builder
(
GhcPkg
stage
)
?
mconcat
[
arg
"update"
,
arg
"--force"
...
...
src/Settings/Packages.hs
View file @
ff86f40e
module
Settings.Packages
(
module
Settings
.
Default
,
packages
,
knownPackages
packages
,
getPackages
,
knownPackages
)
where
import
Package
...
...
@@ -14,6 +14,9 @@ import Settings.Default
packages
::
Packages
packages
=
defaultPackages
<>
userPackages
getPackages
::
Expr
[
Package
]
getPackages
=
fromDiffExpr
packages
-- These are the packages we build by default
defaultPackages
::
Packages
defaultPackages
=
mconcat
...
...
src/Settings/Util.hs
View file @
ff86f40e
...
...
@@ -2,6 +2,7 @@ module Settings.Util (
-- Primitive settings elements
arg
,
argM
,
argSetting
,
argSettingList
,
getFlag
,
getSetting
,
getSettingList
,
getPkgData
,
getPkgDataList
,
appendCcArgs
,
needBuilder
...
...
@@ -16,6 +17,7 @@ module Settings.Util (
import
Builder
import
Expression
import
Oracles.Base
import
Oracles.Flag
import
Oracles.Setting
import
Oracles.PackageData
import
Settings.User
...
...
@@ -34,24 +36,31 @@ argSetting = argM . setting
argSettingList
::
SettingList
->
Args
argSettingList
=
appendM
.
settingList
getFlag
::
Flag
->
Expr
Bool
getFlag
=
lift
.
flag
getSetting
::
Setting
->
Expr
String
getSetting
=
lift
.
setting
getSettingList
::
SettingList
->
Expr
[
String
]
getSettingList
=
lift
.
settingList
getPkgData
::
(
FilePath
->
PackageData
)
->
Expr
String
getPkgData
key
=
do
stage
<-
asks
getStage
pkg
<-
asks
getPackage
let
path
=
targetPath
stage
pkg
lift
.
pkgData
.
key
$
path
stage
<-
getStage
pkg
<-
getPackage
lift
.
pkgData
.
key
$
targetPath
stage
pkg
getPkgDataList
::
(
FilePath
->
PackageDataList
)
->
Expr
[
String
]
getPkgDataList
key
=
do
stage
<-
asks
getStage
pkg
<-
asks
getPackage
let
path
=
targetPath
stage
pkg
lift
.
pkgDataList
.
key
$
path
stage
<-
getStage
pkg
<-
getPackage
lift
.
pkgDataList
.
key
$
targetPath
stage
pkg
-- Pass arguments to Gcc and corresponding lists of sub-arguments of GhcCabal
appendCcArgs
::
[
String
]
->
Args
appendCcArgs
xs
=
do
stage
<-
asks
getStage
stage
<-
getStage
mconcat
[
builder
(
Gcc
stage
)
?
append
xs
,
builder
GhcCabal
?
appendSub
"--configure-option=CFLAGS"
xs
,
builder
GhcCabal
?
appendSub
"--gcc-options"
xs
]
...
...
src/Settings/Ways.hs
View file @
ff86f40e
module
Settings.Ways
(
ways
ways
,
getWays
)
where
import
Way
...
...
@@ -13,6 +13,9 @@ import Settings.User
ways
::
Ways
ways
=
defaultWays
<>
userWays
getWays
::
Expr
[
Way
]
getWays
=
fromDiffExpr
ways
-- These are default ways
defaultWays
::
Ways
defaultWays
=
mconcat
...
...
src/Switches.hs
View file @
ff86f40e
...
...
@@ -4,9 +4,10 @@ module Switches (
)
where
import
Stage
import
Expression
import
Settings.Util
import
Oracles.Flag
import
Oracles.Setting
import
Expression
-- Derived predicates
stage0
::
Predicate
...
...
@@ -30,11 +31,11 @@ registerPackage = return True
splitObjects
::
Predicate
splitObjects
=
do
stage
<-
asks
getSt
age
notB
roken
<-
notP
.
f
lag
$
SplitObjectsBroken
notG
hcUnreg
<-
notP
.
f
lag
$
GhcUnregisterised
goodArch
<-
lift
$
targetArchs
[
"i386"
,
"x86_64"
,
"powerpc"
,
"sparc"
]
goodOs
<-
lift
$
targetOss
[
"mingw32"
,
"cygwin32"
,
"linux"
,
"darwin"
,
"solaris2"
,
"freebsd"
,
"dragonfly"
,
"netbsd"
,
"openbsd"
]
return
$
not
B
roken
&&
not
G
hcUnreg
&&
stage
==
Stage1
&&
goodArch
&&
goodOs
stage
<-
getStage
-- We don't split bootstrap (stage 0) pack
age
s
b
roken
<-
getF
lag
SplitObjectsBroken
g
hcUnreg
<-
getF
lag
GhcUnregisterised
goodArch
<-
lift
$
targetArchs
[
"i386"
,
"x86_64"
,
"powerpc"
,
"sparc"
]
goodOs
<-
lift
$
targetOss
[
"mingw32"
,
"cygwin32"
,
"linux"
,
"darwin"
,
"solaris2"
,
"freebsd"
,
"dragonfly"
,
"netbsd"
,
"openbsd"
]
return
$
not
b
roken
&&
not
g
hcUnreg
&&
stage
==
Stage1
&&
goodArch
&&
goodOs
src/Target.hs
View file @
ff86f40e
{-# LANGUAGE DeriveGeneric, TypeSynonymInstances #-}
module
Target
(
Target
(
..
),
StageTarget
(
..
),
StagePackageTarget
(
..
),
FullTarget
(
..
),
stageTarget
,
stagePackageTarget
,
fullTarget
,
fullTar
getW
ithWay
stageTarget
,
stagePackageTarget
,
fullTarget
,
fullTar
w
ithWay
)
where
import
Way
...
...
@@ -16,39 +16,40 @@ import Development.Shake.Classes
-- be built and the Way they are to be built.
data
Target
=
Target
{
getS
tage
::
Stage
,
getP
ackage
::
Package
,
getF
iles
::
[
FilePath
],
getB
uilder
::
Builder
,
getW
ay
::
Way
s
tage
::
Stage
,
p
ackage
::
Package
,
f
iles
::
[
FilePath
],
b
uilder
::
Builder
,
w
ay
::
Way
}
deriving
(
Eq
,
Generic
)
-- StageTarget is a Target whose field getStage is already assigned
-- StageTarget is a partially constructed Target. Only stage is guaranteed to
-- be assigned.
type
StageTarget
=
Target
stageTarget
::
Stage
->
StageTarget
stageTarget
s
tage
=
Target
stageTarget
s
=
Target
{
getS
tage
=
s
tage
,
getP
ackage
=
error
"stageTarget: Package not set"
,
getF
iles
=
error
"stageTarget: Files not set"
,
getB
uilder
=
error
"stageTarget: Builder not set"
,
getW
ay
=
vanilla
-- most targets are built only one way (vanilla)
s
tage
=
s
,
p
ackage
=
error
"stageTarget: Package not set"
,
f
iles
=
error
"stageTarget: Files not set"
,
b
uilder
=
error
"stageTarget: Builder not set"
,
w
ay
=
vanilla
}
-- StagePackageTarget is a
T
ar
get whose fields getS
tage and
getP
ackage
are
-- a
l
re
ady
assigned
-- StagePackageTarget is a
p
ar
tially constructed Target. Only s
tage and
p
ackage
-- are
guaranteed to be
assigned
.
type
StagePackageTarget
=
Target
stagePackageTarget
::
Stage
->
Package
->
StagePackageTarget
stagePackageTarget
s
tage
package
=
Target
stagePackageTarget
s
p
=
Target
{
getS
tage
=
s
tage
,
getP
ackage
=
p
ackage
,
getF
iles
=
error
"stagePackageTarget: Files not set"
,
getB
uilder
=
error
"stagePackageTarget: Builder not set"
,
getW
ay
=
vanilla
s
tage
=
s
,
p
ackage
=
p
,
f
iles
=
error
"stagePackageTarget: Files not set"
,
b
uilder
=
error
"stagePackageTarget: Builder not set"
,
w
ay
=
vanilla
}
-- FullTarget is a Target whose fields are all assigned
...
...
@@ -56,29 +57,29 @@ type FullTarget = Target
-- Most targets are built only one way, vanilla, hence we set it by default.
fullTarget
::
StagePackageTarget
->
[
FilePath
]
->
Builder
->
FullTarget
fullTarget
target
f
iles
builder
=
target
fullTarget
target
f
s
b
=
target
{
getF
iles
=
f
ile
s
,
getB
uilder
=
b
uilder
,
getW
ay
=
vanilla
f
iles
=
fs
,
b
uilder
=
b
,
w
ay
=
vanilla
}
-- Use this function to be explicit about build
the
way.
fullTar
getW
ithWay
::
StagePackageTarget
->
[
FilePath
]
->
Builder
->
Way
->
FullTarget
fullTar
getW
ithWay
target
f
iles
builder
way
=
target
-- Use this function to be explicit about
the
build way.
fullTar
w
ithWay
::
StagePackageTarget
->
[
FilePath
]
->
Builder
->
Way
->
FullTarget
fullTar
w
ithWay
target
f
s
b
w
=
target
{
getF
iles
=
f
ile
s
,
getB
uilder
=
b
uilder
,
getW
ay
=
w
ay
f
iles
=
fs
,
b
uilder
=
b
,
w
ay
=
w
}
-- Shows a (full) target as "package:file@stage (builder, way)"
instance
Show
FullTarget
where
show
target
=
show
(
getP
ackage
target
)
++
":"
++
show
(
getF
iles
target
)
++
"@"
++
show
(
getS
tage
target
)
++
" ("
++
show
(
getB
uilder
target
)
++
", "
++
show
(
getW
ay
target
)
++
")"
show
target
=
show
(
p
ackage
target
)
++
":"
++
show
(
f
iles
target
)
++
"@"
++
show
(
s
tage
target
)
++
" ("
++
show
(
b
uilder
target
)
++
", "
++
show
(
w
ay
target
)
++
")"
-- Instances for storing in the Shake database
instance
Binary
FullTarget
...
...
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