Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
9c756201
Commit
9c756201
authored
Jul 27, 2017
by
Andrey Mokhov
Browse files
Part 1 of the Great Refactoring of the Expression
See
#347
parent
345deee0
Changes
27
Hide whitespace changes
Inline
Side-by-side
hadrian.cabal
View file @
9c756201
...
...
@@ -111,7 +111,8 @@ executable hadrian
default-language: Haskell2010
default-extensions: RecordWildCards
other-extensions: DeriveGeneric
other-extensions: DeriveFunctor
, DeriveGeneric
, FlexibleInstances
, GeneralizedNewtypeDeriving
, LambdaCase
...
...
src/Base.hs
View file @
9c756201
...
...
@@ -7,7 +7,6 @@ module Base (
module
Data
.
List
.
Extra
,
module
Data
.
Maybe
,
module
Data
.
Monoid
,
MonadTrans
(
lift
),
-- * Shake
module
Development
.
Shake
,
...
...
src/Expression.hs
View file @
9c756201
{-# LANGUAGE FlexibleInstances, LambdaCase #-}
{-# LANGUAGE
DeriveFunctor,
FlexibleInstances, LambdaCase #-}
module
Expression
(
-- * Expressions
Expr
,
DiffExpr
,
fromDiffE
xpr
,
Expr
,
expr
,
e
xpr
IO
,
-- ** Operators
apply
,
append
,
arg
,
remove
,
appendSub
,
appendSubD
,
filterSub
,
removeSub
,
append
,
arg
,
remove
,
-- ** Evaluation
interpret
,
interpretInContext
,
interpretDiff
,
interpret
,
interpretInContext
,
-- ** Predicates
Predicate
,
(
?
),
applyPredicate
,
-- ** Common expressions
...
...
@@ -16,10 +15,10 @@ module Expression (
-- * Convenient accessors
getContext
,
getStage
,
getPackage
,
getBuilder
,
getOutputs
,
getInputs
,
getWay
,
getInput
,
getOutput
,
getSingleton
,
getInput
,
getOutput
,
getSingleton
,
getSetting
,
getSettingList
,
getFlag
,
getTopDirectory
,
-- * Re-exports
module
Control
.
Monad
.
Trans
.
Reader
,
module
Data
.
Monoid
,
module
Builder
,
module
Package
,
...
...
@@ -28,6 +27,7 @@ module Expression (
)
where
import
Control.Monad.Trans.Reader
import
Control.Monad.Trans
import
Data.Monoid
import
Base
...
...
@@ -38,53 +38,58 @@ import Stage
import
Target
import
Way
import
Oracles.Config.Flag
import
Oracles.Config.Setting
import
Oracles.Path
-- | @Expr a@ is a computation that produces a value of type @Action a@ and can
-- read parameters of the current build 'Target'.
type
Expr
a
=
ReaderT
Target
Action
a
newtype
Expr
a
=
Expr
(
ReaderT
Target
Action
a
)
deriving
Functor
expr
::
Action
a
->
Expr
a
expr
=
Expr
.
lift
exprIO
::
IO
a
->
Expr
a
exprIO
=
Expr
.
liftIO
-- | @Diff a@ is a /difference list/ containing values of type @a@. A difference
-- list is a list with efficient concatenation, encoded as a value @a -> a@. We
-- could use @Dual (Endo a)@ instead of @Diff a@, but the former may look scary.
newtype
Diff
a
=
Diff
{
fromDiff
::
a
->
a
}
instance
Monoid
a
=>
Monoid
(
Expr
a
)
where
mempty
=
Expr
$
return
mempty
mappend
(
Expr
x
)
(
Expr
y
)
=
Expr
$
(
<>
)
<$>
x
<*>
y
-- | @DiffExpr a@ is a computation that builds a difference list (i.e., a
-- function of type @'Action' (a -> a)@) and can read parameters of the current
-- build 'Target'.
type
DiffExpr
a
=
Expr
(
Diff
a
)
instance
Applicative
Expr
where
pure
=
Expr
.
pure
(
<*>
)
=
ap
-- Note the reverse order of function composition (y . x), which ensures that
-- when two DiffExpr computations c1 and c2 are combined (c1 <> c2), then c1 is
-- applied first, and c2 is applied second.
instance
Monoid
(
Diff
a
)
wher
e
mempty
=
Diff
id
Diff
x
`
mappend
`
Diff
y
=
Diff
$
y
.
x
instance
Monad
Expr
where
return
=
pure
Expr
e
>>=
f
=
Expr
$
do
re
<-
e
let
Expr
rf
=
f
re
rf
-- | The following expressions are used throughout the build system for
-- specifying conditions ('Predicate'), lists of arguments ('Args'), 'Ways'
-- and 'Packages'.
type
Predicate
=
Expr
Bool
type
Args
=
Diff
Expr
[
String
]
type
Packages
=
Diff
Expr
[
Package
]
type
Ways
=
Diff
Expr
[
Way
]
type
Args
=
Expr
[
String
]
type
Packages
=
Expr
[
Package
]
type
Ways
=
Expr
[
Way
]
-- Basic operations on expressions:
-- | Transform an expression by applying a given function.
apply
::
(
a
->
a
)
->
DiffExpr
a
apply
=
return
.
Diff
-- | Append something to an expression.
append
::
Monoid
a
=>
a
->
Diff
Expr
a
append
x
=
apply
(
<>
x
)
append
::
Monoid
a
=>
a
->
Expr
a
append
=
Expr
.
return
-- | Remove given elements from a list expression.
remove
::
Eq
a
=>
[
a
]
->
Diff
Expr
[
a
]
remove
xs
=
apply
$
filter
(`
notElem
`
xs
)
remove
::
Eq
a
=>
[
a
]
->
Expr
[
a
]
->
Expr
[
a
]
remove
xs
e
=
filter
(`
notElem
`
xs
)
<$>
e
-- | Apply a predicate to an expression.
applyPredicate
::
Monoid
a
=>
Predicate
->
Expr
a
->
Expr
a
applyPredicate
predicate
expr
=
do
bool
<-
predicate
if
bool
then
expr
else
return
mempty
if
bool
then
expr
else
mempty
-- | Add a single argument to 'Args'.
arg
::
String
->
Args
...
...
@@ -100,104 +105,73 @@ instance PredicateLike Predicate where
(
?
)
=
applyPredicate
instance
PredicateLike
Bool
where
(
?
)
=
applyPredicate
.
return
(
?
)
=
applyPredicate
.
Expr
.
return
instance
PredicateLike
(
Action
Bool
)
where
(
?
)
=
applyPredicate
.
lift
-- | @appendSub@ appends a list of sub-arguments to all arguments starting with a
-- given prefix. If there is no argument with such prefix then a new argument
-- of the form @prefix=listOfSubarguments@ is appended to the expression.
-- Note: nothing is done if the list of sub-arguments is empty.
appendSub
::
String
->
[
String
]
->
Args
appendSub
prefix
xs
|
xs'
==
[]
=
mempty
|
otherwise
=
apply
.
go
$
False
where
xs'
=
filter
(
/=
""
)
xs
go
True
[]
=
[]
go
False
[]
=
[
prefix
++
"="
++
unwords
xs'
]
go
found
(
y
:
ys
)
=
if
prefix
`
isPrefixOf
`
y
then
unwords
(
y
:
xs'
)
:
go
True
ys
else
y
:
go
found
ys
-- | @appendSubD@ is similar to 'appendSub' but it extracts the list of sub-arguments
-- from the given 'DiffExpr'.
appendSubD
::
String
->
Args
->
Args
appendSubD
prefix
diffExpr
=
fromDiffExpr
diffExpr
>>=
appendSub
prefix
filterSub
::
String
->
(
String
->
Bool
)
->
Args
filterSub
prefix
p
=
apply
$
map
filterSubstr
where
filterSubstr
s
|
prefix
`
isPrefixOf
`
s
=
unwords
.
filter
p
.
words
$
s
|
otherwise
=
s
-- | Remove given elements from a list of sub-arguments with a given prefix
-- Example: removeSub "--configure-option=CFLAGS" ["-Werror"].
removeSub
::
String
->
[
String
]
->
Args
removeSub
prefix
xs
=
filterSub
prefix
(`
notElem
`
xs
)
(
?
)
=
applyPredicate
.
expr
-- | Interpret a given expression according to the given 'Target'.
interpret
::
Target
->
Expr
a
->
Action
a
interpret
=
flip
runReaderT
interpret
target
(
Expr
e
)
=
runReaderT
e
target
-- | Interpret a given expression by looking only at the given 'Context'.
interpretInContext
::
Context
->
Expr
a
->
Action
a
interpretInContext
=
interpret
.
dummyTarget
-- | Extract an expression from a difference expression.
fromDiffExpr
::
Monoid
a
=>
DiffExpr
a
->
Expr
a
fromDiffExpr
=
fmap
((
$
mempty
)
.
fromDiff
)
-- | Interpret a given difference expression in a given environment.
interpretDiff
::
Monoid
a
=>
Target
->
DiffExpr
a
->
Action
a
interpretDiff
target
=
interpret
target
.
fromDiffExpr
-- | Get the current build 'Context'.
getContext
::
Expr
Context
getContext
=
asks
context
getContext
=
Expr
$
asks
context
-- | Get the 'Stage' of the current 'Context'.
getStage
::
Expr
Stage
getStage
=
stage
<$>
asks
context
getStage
=
Expr
$
stage
<$>
asks
context
-- | Get the 'Package' of the current 'Context'.
getPackage
::
Expr
Package
getPackage
=
package
<$>
asks
context
getPackage
=
Expr
$
package
<$>
asks
context
-- | Get the 'Way' of the current 'Context'.
getWay
::
Expr
Way
getWay
=
way
<$>
asks
context
getWay
=
Expr
$
way
<$>
asks
context
-- | Get the 'Builder' for the current 'Target'.
getBuilder
::
Expr
Builder
getBuilder
=
asks
builder
getBuilder
=
Expr
$
asks
builder
-- | Get the input files of the current 'Target'.
getInputs
::
Expr
[
FilePath
]
getInputs
=
asks
inputs
getInputs
=
Expr
$
asks
inputs
-- | Run 'getInputs' and check that the result contains one input file only.
getInput
::
Expr
FilePath
getInput
=
do
getInput
=
Expr
$
do
target
<-
ask
getSingleton
(
"Exactly one input file expected in "
++
show
target
)
<$>
getInputs
getSingleton
(
"Exactly one input file expected in "
++
show
target
)
<$>
asks
inputs
-- | Get the files produced by the current 'Target'.
getOutputs
::
Expr
[
FilePath
]
getOutputs
=
asks
outputs
getOutputs
=
Expr
$
asks
outputs
-- | Run 'getOutputs' and check that the result contains one output file only.
getOutput
::
Expr
FilePath
getOutput
=
do
getOutput
=
Expr
$
do
target
<-
ask
getSingleton
(
"Exactly one output file expected in "
++
show
target
)
<$>
getOutputs
getSingleton
(
"Exactly one output file expected in "
++
show
target
)
<$>
asks
outputs
-- | Extract a value from a singleton list, or raise an error if the list does
-- not contain exactly one value.
getSingleton
::
String
->
[
a
]
->
a
getSingleton
_
[
res
]
=
res
getSingleton
msg
_
=
error
msg
getSetting
::
Setting
->
Expr
String
getSetting
=
expr
.
setting
getSettingList
::
SettingList
->
Expr
[
String
]
getSettingList
=
expr
.
settingList
getFlag
::
Flag
->
Predicate
getFlag
=
expr
.
flag
getTopDirectory
::
Expr
FilePath
getTopDirectory
=
expr
topDirectory
src/Oracles/Config/Flag.hs
View file @
9c756201
module
Oracles.Config.Flag
(
Flag
(
..
),
flag
,
getFlag
,
crossCompiling
,
platformSupportsSharedLibs
,
Flag
(
..
),
flag
,
crossCompiling
,
platformSupportsSharedLibs
,
ghcWithSMP
,
ghcWithNativeCodeGen
,
supportsSplitObjects
)
where
import
Control.Monad.Trans.Reader
import
Base
import
Oracles.Config
import
Oracles.Config.Setting
...
...
@@ -44,9 +42,6 @@ flag f = do
++
quote
(
key
++
" = "
++
value
)
++
"cannot be parsed."
return
$
value
==
"YES"
getFlag
::
Flag
->
ReaderT
a
Action
Bool
getFlag
=
lift
.
flag
crossCompiling
::
Action
Bool
crossCompiling
=
flag
CrossCompiling
...
...
src/Oracles/Config/Setting.hs
View file @
9c756201
module
Oracles.Config.Setting
(
Setting
(
..
),
SettingList
(
..
),
setting
,
settingList
,
getSetting
,
getSettingList
,
anyTargetPlatform
,
anyTargetOs
,
anyTargetArch
,
anyHostOs
,
Setting
(
..
),
SettingList
(
..
),
setting
,
settingList
,
anyTargetPlatform
,
anyTargetOs
,
anyTargetArch
,
anyHostOs
,
ghcWithInterpreter
,
ghcEnableTablesNextToCode
,
useLibFFIForAdjustors
,
ghcCanonVersion
,
cmdLineLengthLimit
,
iosHost
,
osxHost
,
windowsHost
,
relocatableBuild
,
installDocDir
,
installGhcLibDir
)
where
import
Control.Monad.Trans.Reader
import
Base
import
Oracles.Config
import
Stage
...
...
@@ -130,12 +128,6 @@ settingList key = fmap words $ unsafeAskConfig $ case key of
ConfLdLinkerArgs
stage
->
"conf-ld-linker-args-"
++
stageString
stage
HsCppArgs
->
"hs-cpp-args"
getSetting
::
Setting
->
ReaderT
a
Action
String
getSetting
=
lift
.
setting
getSettingList
::
SettingList
->
ReaderT
a
Action
[
String
]
getSettingList
=
lift
.
settingList
matchSetting
::
Setting
->
[
String
]
->
Action
Bool
matchSetting
key
values
=
fmap
(`
elem
`
values
)
$
setting
key
...
...
src/Oracles/Path.hs
View file @
9c756201
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module
Oracles.Path
(
topDirectory
,
getTopDirectory
,
systemBuilderPath
,
pathOracle
,
bashPath
,
topDirectory
,
systemBuilderPath
,
pathOracle
,
bashPath
,
fixAbsolutePathOnWindows
)
where
import
Control.Monad.Trans.Reader
import
Data.Char
import
System.Directory
...
...
@@ -18,9 +17,6 @@ import Stage
topDirectory
::
Action
FilePath
topDirectory
=
fixAbsolutePathOnWindows
=<<
setting
GhcSourcePath
getTopDirectory
::
ReaderT
a
Action
FilePath
getTopDirectory
=
lift
topDirectory
-- | Determine the location of a system 'Builder'.
systemBuilderPath
::
Builder
->
Action
FilePath
systemBuilderPath
builder
=
case
builder
of
...
...
src/Rules/Generators/Common.hs
View file @
9c756201
...
...
@@ -5,12 +5,12 @@ import Expression
-- | Track a given source file when constructing an expression.
trackSource
::
FilePath
->
Expr
()
trackSource
file
=
lift
$
need
[
sourcePath
-/-
file
]
trackSource
file
=
expr
$
need
[
sourcePath
-/-
file
]
-- | Turn a 'Bool' computed by an 'Action' into a 'String' expression returning
-- "YES" (when the Boolean is 'True') or "NO" (when the Boolean is 'False').
yesNo
::
Action
Bool
->
Expr
String
yesNo
=
lift
.
fmap
(
\
x
->
if
x
then
"YES"
else
"NO"
)
yesNo
=
expr
.
fmap
(
\
x
->
if
x
then
"YES"
else
"NO"
)
-- | Given a 'String' replace charaters '.' and '-' by underscores ('_') so that
-- the resulting 'String' becomes a valid C identifier.
...
...
src/Rules/Generators/ConfigHs.hs
View file @
9c756201
...
...
@@ -31,7 +31,7 @@ generateConfigHs = do
cGhcEnableTablesNextToCode
<-
yesNo
ghcEnableTablesNextToCode
cLeadingUnderscore
<-
yesNo
$
flag
LeadingUnderscore
cGHC_UNLIT_PGM
<-
fmap
takeFileName
$
getBuilderPath
Unlit
cLibFFI
<-
lift
useLibFFIForAdjustors
cLibFFI
<-
expr
useLibFFIForAdjustors
rtsWays
<-
getRtsWays
cGhcRtsWithLibdw
<-
getFlag
WithLibdw
let
cGhcRTSWays
=
unwords
$
map
show
rtsWays
...
...
src/Rules/Generators/GhcAutoconfH.hs
View file @
9c756201
...
...
@@ -19,8 +19,8 @@ undefinePackage s
generateGhcAutoconfH
::
Expr
String
generateGhcAutoconfH
=
do
trackSource
"Rules/Generators/GhcAutoconfH.hs"
configHContents
<-
lift
$
map
undefinePackage
<$>
readFileLines
configH
tablesNextToCode
<-
lift
$
ghcEnableTablesNextToCode
configHContents
<-
expr
$
map
undefinePackage
<$>
readFileLines
configH
tablesNextToCode
<-
expr
ghcEnableTablesNextToCode
ghcUnreg
<-
getFlag
GhcUnregisterised
ccLlvmBackend
<-
getSetting
CcLlvmBackend
ccClangBackend
<-
getSetting
CcClangBackend
...
...
src/Rules/Generators/GhcSplit.hs
View file @
9c756201
...
...
@@ -17,7 +17,7 @@ generateGhcSplit = do
targetPlatform
<-
getSetting
TargetPlatform
ghcEnableTNC
<-
yesNo
ghcEnableTablesNextToCode
perlPath
<-
getBuilderPath
Perl
contents
<-
lift
$
readFileLines
ghcSplitSource
contents
<-
expr
$
readFileLines
ghcSplitSource
return
.
unlines
$
[
"#!"
++
perlPath
,
"my $TARGETPLATFORM = "
++
show
targetPlatform
++
";"
...
...
src/Rules/Libffi.hs
View file @
9c756201
...
...
@@ -24,10 +24,10 @@ fixLibffiMakefile top =
-- TODO: check code duplication w.r.t. ConfCcArgs
configureEnvironment
::
Action
[
CmdOption
]
configureEnvironment
=
do
cFlags
<-
interpretInContext
libffiContext
.
fromDiffExpr
$
mconcat
cFlags
<-
interpretInContext
libffiContext
$
mconcat
[
cArgs
,
argStagedSettingList
ConfCcArgs
]
ldFlags
<-
interpretInContext
libffiContext
$
fromDiffExpr
ldArgs
ldFlags
<-
interpretInContext
libffiContext
ldArgs
sequence
[
builderEnvironment
"CC"
$
Cc
CompileC
Stage1
,
builderEnvironment
"CXX"
$
Cc
CompileC
Stage1
,
builderEnvironment
"LD"
Ld
...
...
src/Rules/Wrappers.hs
View file @
9c756201
...
...
@@ -8,7 +8,7 @@ import GHC
import
Settings
(
getPackages
,
latestBuildStage
)
import
Settings.Install
(
installPackageDbDirectory
)
import
Settings.Path
(
buildPath
,
inplacePackageDbDirectory
)
import
Oracles.Path
(
getTopDirectory
,
bashPath
)
import
Oracles.Path
(
bashPath
)
import
Oracles.Config.Setting
(
SettingList
(
..
),
settingList
)
-- | Wrapper is an expression depending on the 'FilePath' to the
...
...
@@ -22,8 +22,8 @@ type Wrapper = WrappedBinary -> Expr String
ghcWrapper
::
WrappedBinary
->
Expr
String
ghcWrapper
WrappedBinary
{
..
}
=
do
lift
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
bash
<-
lift
bashPath
expr
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
bash
<-
expr
bashPath
return
$
unlines
[
"#!"
++
bash
,
"exec "
++
(
binaryLibPath
-/-
"bin"
-/-
binaryName
)
...
...
@@ -31,8 +31,8 @@ ghcWrapper WrappedBinary{..} = do
inplaceRunGhcWrapper
::
WrappedBinary
->
Expr
String
inplaceRunGhcWrapper
WrappedBinary
{
..
}
=
do
lift
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
bash
<-
lift
bashPath
expr
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
bash
<-
expr
bashPath
return
$
unlines
[
"#!"
++
bash
,
"exec "
++
(
binaryLibPath
-/-
"bin"
-/-
binaryName
)
...
...
@@ -41,8 +41,8 @@ inplaceRunGhcWrapper WrappedBinary{..} = do
installRunGhcWrapper
::
WrappedBinary
->
Expr
String
installRunGhcWrapper
WrappedBinary
{
..
}
=
do
lift
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
bash
<-
lift
bashPath
expr
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
bash
<-
expr
bashPath
return
$
unlines
[
"#!"
++
bash
,
"exec "
++
(
binaryLibPath
-/-
"bin"
-/-
binaryName
)
...
...
@@ -51,13 +51,13 @@ installRunGhcWrapper WrappedBinary{..} = do
inplaceGhcPkgWrapper
::
WrappedBinary
->
Expr
String
inplaceGhcPkgWrapper
WrappedBinary
{
..
}
=
do
lift
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
expr
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
stage
<-
getStage
top
<-
getTopDirectory
-- Use the package configuration for the next stage in the wrapper.
-- The wrapper is generated in StageN, but used in StageN+1.
let
packageDb
=
top
-/-
inplacePackageDbDirectory
(
succ
stage
)
bash
<-
lift
bashPath
bash
<-
expr
bashPath
return
$
unlines
[
"#!"
++
bash
,
"exec "
++
(
binaryLibPath
-/-
"bin"
-/-
binaryName
)
...
...
@@ -65,13 +65,13 @@ inplaceGhcPkgWrapper WrappedBinary{..} = do
installGhcPkgWrapper
::
WrappedBinary
->
Expr
String
installGhcPkgWrapper
WrappedBinary
{
..
}
=
do
lift
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
expr
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
stage
<-
getStage
top
<-
getTopDirectory
-- Use the package configuration for the next stage in the wrapper.
-- The wrapper is generated in StageN, but used in StageN+1.
let
packageDb
=
installPackageDbDirectory
binaryLibPath
top
(
succ
stage
)
bash
<-
lift
bashPath
bash
<-
expr
bashPath
return
$
unlines
[
"#!"
++
bash
,
"exec "
++
(
binaryLibPath
-/-
"bin"
-/-
binaryName
)
...
...
@@ -79,16 +79,16 @@ installGhcPkgWrapper WrappedBinary{..} = do
hp2psWrapper
::
WrappedBinary
->
Expr
String
hp2psWrapper
WrappedBinary
{
..
}
=
do
lift
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
bash
<-
lift
bashPath
expr
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
bash
<-
expr
bashPath
return
$
unlines
[
"#!"
++
bash
,
"exec "
++
(
binaryLibPath
-/-
"bin"
-/-
binaryName
)
++
" ${1+
\"
$@
\"
}"
]
hpcWrapper
::
WrappedBinary
->
Expr
String
hpcWrapper
WrappedBinary
{
..
}
=
do
lift
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
bash
<-
lift
bashPath
expr
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
bash
<-
expr
bashPath
return
$
unlines
[
"#!"
++
bash
,
"exec "
++
(
binaryLibPath
-/-
"bin"
-/-
binaryName
)
++
" ${1+
\"
$@
\"
}"
]
...
...
@@ -96,14 +96,14 @@ hpcWrapper WrappedBinary{..} = do
hsc2hsWrapper
::
WrappedBinary
->
Expr
String
hsc2hsWrapper
WrappedBinary
{
..
}
=
do
top
<-
getTopDirectory
lift
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
contents
<-
lift
$
readFile'
$
top
-/-
"utils/hsc2hs/hsc2hs.wrapper"
expr
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
contents
<-
expr
$
readFile'
$
top
-/-
"utils/hsc2hs/hsc2hs.wrapper"
let
executableName
=
binaryLibPath
-/-
"bin"
-/-
binaryName
confCcArgs
<-
lift
$
settingList
(
ConfCcArgs
Stage1
)
confGccLinkerArgs
<-
lift
$
settingList
(
ConfGccLinkerArgs
Stage1
)
confCcArgs
<-
expr
$
settingList
(
ConfCcArgs
Stage1
)
confGccLinkerArgs
<-
expr
$
settingList
(
ConfGccLinkerArgs
Stage1
)
let
hsc2hsExtra
=
unwords
(
map
(
"-cflags="
++
)
confCcArgs
)
++
" "
++
unwords
(
map
(
"-lflags="
++
)
confGccLinkerArgs
)
bash
<-
lift
bashPath
bash
<-
expr
bashPath
return
$
unlines
[
"#!"
++
bash
,
"executablename=
\"
"
++
executableName
++
"
\"
"
...
...
@@ -112,7 +112,7 @@ hsc2hsWrapper WrappedBinary{..} = do
haddockWrapper
::
WrappedBinary
->
Expr
String
haddockWrapper
WrappedBinary
{
..
}
=
do
lift
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
expr
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
return
$
unlines
[
"#!/bin/bash"
,
"exec "
++
(
binaryLibPath
-/-
"bin"
-/-
binaryName
)
...
...
@@ -120,13 +120,13 @@ haddockWrapper WrappedBinary{..} = do
iservBinWrapper
::
WrappedBinary
->
Expr
String
iservBinWrapper
WrappedBinary
{
..
}
=
do
lift
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
expr
$
need
[
sourcePath
-/-
"Rules/Wrappers.hs"
]
activePackages
<-
filter
isLibrary
<$>
getPackages
-- TODO: Figure our the reason of this hardcoded exclusion
let
pkgs
=
activePackages
\\
[
cabal
,
process
,
haskeline
,
terminfo
,
ghcCompact
,
hpc
,
compiler
]
contexts
<-
catMaybes
<$>
mapM
(
\
p
->
do
m
<-
lift
$
latestBuildStage
p
m
<-
expr
$
latestBuildStage
p
return
$
fmap
(
\
s
->
vanillaContext
s
p
)
m
)
pkgs
let
buildPaths
=
map
buildPath
contexts
...
...
src/Settings.hs
View file @
9c756201
...
...
@@ -24,16 +24,16 @@ import Settings.Path
import
UserSettings
getArgs
::
Expr
[
String
]
getArgs
=
fromDiffExpr
$
args
flavour
getArgs
=
args
flavour
getLibraryWays
::
Expr
[
Way
]
getLibraryWays
=
fromDiffExpr
$
libraryWays
flavour
getLibraryWays
=
libraryWays
flavour
getRtsWays
::
Expr
[
Way
]
getRtsWays
=
fromDiffExpr
$
rtsWays
flavour
getRtsWays
=
rtsWays
flavour
getPackages
::
Expr
[
Package
]
getPackages
=
fromDiffExpr
$
packages
flavour
getPackages
=
packages
flavour
stagePackages
::
Stage
->
Action
[
Package
]
stagePackages
stage
=
interpretInContext
(
stageContext
stage
)
getPackages
...
...
@@ -48,10 +48,10 @@ getBuildPath :: Expr FilePath
getBuildPath
=
buildPath
<$>
getContext
getPkgData
::
(
FilePath
->
PackageData
)
->
Expr
String
getPkgData
key
=
lift
.
pkgData
.
key
=<<
getBuildPath
getPkgData
key
=
expr
.
pkgData
.
key
=<<
getBuildPath
getPkgDataList
::
(
FilePath
->
PackageDataList
)
->
Expr
[
String
]
getPkgDataList
key
=
lift
.
pkgDataList
.
key
=<<
getBuildPath
getPkgDataList
key
=
expr
.
pkgDataList
.
key
=<<
getBuildPath
hadrianFlavours
::
[
Flavour
]
hadrianFlavours
=
...
...
@@ -92,8 +92,8 @@ builderPath builder = case builderProvenance builder of
let
msg
=
error
$
show
builder
++
" is never built by Hadrian."
return
$
fromMaybe
msg
maybePath
getBuilderPath
::
Builder
->
ReaderT
a
Action
FilePath
getBuilderPath
=
lift
.
builderPath
getBuilderPath
::
Builder
->
Expr
FilePath
getBuilderPath
=
expr
.
builderPath
-- | Was the path to a given 'Builder' specified in configuration files?
isSpecified
::
Builder
->
Action
Bool
...
...
src/Settings/Builders/Cc.hs
View file @
9c756201
...
...
@@ -7,7 +7,7 @@ ccBuilderArgs = do
way
<-
getWay
builder
Cc
?
mconcat
[
append
=<<
getPkgDataList
CcArgs
,
arg
SettingList
.
ConfCcArgs
=<<
getStage
,
get
SettingList
.
ConfCcArgs
=<<
getStage
,
cIncludeArgs
,
builder
(
Cc
CompileC
)
?
mconcat
...
...
src/Settings/Builders/Common.hs
View file @
9c756201
...
...
@@ -10,8 +10,8 @@ module Settings.Builders.Common (
module
Settings
,
module
Settings
.
Path
,
module
UserSettings
,
cIncludeArgs
,
ldArgs
,
cArgs
,
cWarnings
,
argS
etting
,
argSettingList
,
argStagedBuilderPath
,
argStagedSettingList
,
bootPackageDatabaseArgs
cIncludeArgs
,
ldArgs
,
cArgs
,
cWarnings
,
argS
tagedBuilderPath
,
argStagedSettingList
,
bootPackageDatabaseArgs
)
where
import
Base
...
...
@@ -53,12 +53,6 @@ cWarnings = do
,
gccGe46
?
notM
windowsHost
?
arg
"-Werror=unused-but-set-variable"
,
gccGe46
?
arg
"-Wno-error=inline"
]
argM
::
Action
String
->
Args
argM
=
(
arg
=<<
)
.
lift