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
48e8b6f2
Commit
48e8b6f2
authored
Aug 05, 2017
by
Andrey Mokhov
Browse files
Factor out generic build infrastructure
See
#347
parent
81fecb8b
Changes
20
Hide whitespace changes
Inline
Side-by-side
hadrian.cabal
View file @
48e8b6f2
...
...
@@ -26,6 +26,8 @@ executable hadrian
, Expression
, Flavour
, GHC
, Hadrian.Expression
, Hadrian.Target
, Oracles.ArgsHash
, Oracles.Config
, Oracles.Config.Flag
...
...
src/Expression.hs
View file @
48e8b6f2
{-# LANGUAGE DeriveFunctor, FlexibleInstances, LambdaCase #-}
module
Expression
(
-- * Expressions
Expr
,
expr
,
exprIO
,
-- ** Operators
append
,
arg
,
remove
,
Expr
,
Predicate
,
Args
,
Ways
,
Packages
,
-- ** Construction and modification
expr
,
exprIO
,
append
,
arg
,
remove
,
(
?
),
-- ** Evaluation
interpret
,
interpretInContext
,
-- ** Predicates
Predicate
,
(
?
),
applyPredicate
,
-- ** Common expressions
Args
,
Ways
,
Packages
,
-- ** Context and Target
Context
,
vanillaContext
,
stageContext
,
Target
,
dummyTarget
,
Context
,
vanillaContext
,
stageContext
,
Target
,
-- * Convenient accessors
getContext
,
getStage
,
getPackage
,
getBuilder
,
getOutputs
,
getInputs
,
getWay
,
...
...
@@ -26,11 +24,11 @@ module Expression (
module
Way
)
where
import
Control.Monad.Trans.Reader
import
Control.Monad.Trans
import
Data.Semigroup
import
Base
import
qualified
Hadrian.Expression
as
H
import
Hadrian.Expression
hiding
(
Expr
,
Predicate
,
Args
)
import
Builder
import
Context
import
Package
...
...
@@ -44,38 +42,13 @@ 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'.
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
instance
Semigroup
a
=>
Semigroup
(
Expr
a
)
where
Expr
x
<>
Expr
y
=
Expr
$
(
<>
)
<$>
x
<*>
y
-- TODO: The 'Semigroup a' constraint will at some point become redundant.
instance
(
Semigroup
a
,
Monoid
a
)
=>
Monoid
(
Expr
a
)
where
mempty
=
pure
mempty
mappend
=
(
<>
)
instance
Applicative
Expr
where
pure
=
Expr
.
pure
(
<*>
)
=
ap
instance
Monad
Expr
where
return
=
pure
Expr
e
>>=
f
=
Expr
$
do
re
<-
e
let
Expr
rf
=
f
re
rf
type
Expr
a
=
H
.
Expr
Context
Builder
a
-- | 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
=
Expr
[
String
]
type
Predicate
=
H
.
Predicate
Context
Builder
type
Args
=
H
.
Args
Context
Builder
type
Packages
=
Expr
[
Package
]
type
Ways
=
Expr
[
Way
]
...
...
@@ -85,88 +58,17 @@ type Ways = Expr [Way]
append
::
a
->
Expr
a
append
=
pure
-- | Remove given elements from a list expression.
remove
::
Eq
a
=>
[
a
]
->
Expr
[
a
]
->
Expr
[
a
]
remove
xs
e
=
filter
(`
notElem
`
xs
)
<$>
e
-- | Apply a predicate to an expression.
applyPredicate
::
(
Monoid
a
,
Semigroup
a
)
=>
Predicate
->
Expr
a
->
Expr
a
applyPredicate
predicate
expr
=
do
bool
<-
predicate
if
bool
then
expr
else
mempty
-- | Add a single argument to 'Args'.
arg
::
String
->
Args
arg
=
append
.
return
-- | A convenient operator for predicate application.
class
PredicateLike
a
where
(
?
)
::
(
Monoid
m
,
Semigroup
m
)
=>
a
->
Expr
m
->
Expr
m
infixr
3
?
instance
PredicateLike
Predicate
where
(
?
)
=
applyPredicate
instance
PredicateLike
Bool
where
(
?
)
=
applyPredicate
.
Expr
.
return
instance
PredicateLike
(
Action
Bool
)
where
(
?
)
=
applyPredicate
.
expr
-- | Interpret a given expression according to the given 'Target'.
interpret
::
Target
->
Expr
a
->
Action
a
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
-- | Get the current build 'Context'.
getContext
::
Expr
Context
getContext
=
Expr
$
asks
context
-- | Get the 'Stage' of the current 'Context'.
getStage
::
Expr
Stage
getStage
=
Expr
$
stage
<$>
asks
c
ontext
getStage
=
stage
<$>
getC
ontext
-- | Get the 'Package' of the current 'Context'.
getPackage
::
Expr
Package
getPackage
=
Expr
$
package
<$>
asks
c
ontext
getPackage
=
package
<$>
getC
ontext
-- | Get the 'Way' of the current 'Context'.
getWay
::
Expr
Way
getWay
=
Expr
$
way
<$>
asks
context
-- | Get the 'Builder' for the current 'Target'.
getBuilder
::
Expr
Builder
getBuilder
=
Expr
$
asks
builder
-- | Get the input files of the current 'Target'.
getInputs
::
Expr
[
FilePath
]
getInputs
=
Expr
$
asks
inputs
-- | Run 'getInputs' and check that the result contains one input file only.
getInput
::
Expr
FilePath
getInput
=
Expr
$
do
target
<-
ask
getSingleton
(
"Exactly one input file expected in "
++
show
target
)
<$>
asks
inputs
-- | Get the files produced by the current 'Target'.
getOutputs
::
Expr
[
FilePath
]
getOutputs
=
Expr
$
asks
outputs
-- | Run 'getOutputs' and check that the result contains one output file only.
getOutput
::
Expr
FilePath
getOutput
=
Expr
$
do
target
<-
ask
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
getWay
=
way
<$>
getContext
getSetting
::
Setting
->
Expr
String
getSetting
=
expr
.
setting
...
...
src/Hadrian/Expression.hs
0 → 100644
View file @
48e8b6f2
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module
Hadrian.Expression
(
-- * Expressions
Expr
,
Predicate
,
Args
,
-- ** Construction and modification
expr
,
exprIO
,
arg
,
remove
,
(
?
),
-- ** Evaluation
interpret
,
interpretInContext
,
-- * Convenient accessors
getContext
,
getBuilder
,
getOutputs
,
getInputs
,
getInput
,
getOutput
,
getSingleton
)
where
import
Control.Monad.Trans
import
Control.Monad.Trans.Reader
import
Data.Semigroup
import
Development.Shake
import
Hadrian.Target
-- | 'Expr' @c b a@ is a computation that produces a value of type 'Action' @a@
-- and can read parameters of the current build 'Target' @c b@.
newtype
Expr
c
b
a
=
Expr
(
ReaderT
(
Target
c
b
)
Action
a
)
deriving
(
Applicative
,
Functor
,
Monad
)
instance
Semigroup
a
=>
Semigroup
(
Expr
c
b
a
)
where
Expr
x
<>
Expr
y
=
Expr
$
(
<>
)
<$>
x
<*>
y
-- TODO: The 'Semigroup a' constraint will at some point become redundant.
instance
(
Semigroup
a
,
Monoid
a
)
=>
Monoid
(
Expr
c
b
a
)
where
mempty
=
pure
mempty
mappend
=
(
<>
)
-- | Expressions that compute a Boolean value.
type
Predicate
c
b
=
Expr
c
b
Bool
-- | Expressions that compute lists of arguments to be passed to builders.
type
Args
c
b
=
Expr
c
b
[
String
]
-- | Lift actions independent from the current build 'Target' into the 'Expr'
-- monad.
expr
::
Action
a
->
Expr
c
b
a
expr
=
Expr
.
lift
-- | Lift IO computations independent from the current build 'Target' into the
-- 'Expr' monad.
exprIO
::
IO
a
->
Expr
c
b
a
exprIO
=
Expr
.
liftIO
-- | Remove given elements from a list expression.
remove
::
Eq
a
=>
[
a
]
->
Expr
c
b
[
a
]
->
Expr
c
b
[
a
]
remove
xs
e
=
filter
(`
notElem
`
xs
)
<$>
e
-- | Add a single argument to 'Args'.
arg
::
String
->
Args
c
b
arg
=
pure
.
pure
-- | Values that can be converted to a 'Predicate'.
class
ToPredicate
p
c
b
where
toPredicate
::
p
->
Predicate
c
b
infixr
3
?
-- | Apply a predicate to an expression.
(
?
)
::
(
Monoid
a
,
Semigroup
a
,
ToPredicate
p
c
b
)
=>
p
->
Expr
c
b
a
->
Expr
c
b
a
p
?
e
=
do
bool
<-
toPredicate
p
if
bool
then
e
else
mempty
instance
ToPredicate
(
Predicate
c
b
)
c
b
where
toPredicate
=
id
instance
ToPredicate
Bool
c
b
where
toPredicate
=
pure
instance
ToPredicate
(
Action
Bool
)
c
b
where
toPredicate
=
expr
-- | Interpret a given expression according to the given 'Target'.
interpret
::
Target
c
b
->
Expr
c
b
a
->
Action
a
interpret
target
(
Expr
e
)
=
runReaderT
e
target
-- | Interpret a given expression by looking only at the given 'Context'.
interpretInContext
::
c
->
Expr
c
b
a
->
Action
a
interpretInContext
c
=
interpret
$
target
c
(
error
"contextOnlyTarget: builder not set"
)
(
error
"contextOnlyTarget: inputs not set"
)
(
error
"contextOnlyTarget: outputs not set"
)
-- | Get the current build 'Context'.
getContext
::
Expr
c
b
c
getContext
=
Expr
$
asks
context
-- | Get the 'Builder' for the current 'Target'.
getBuilder
::
Expr
c
b
b
getBuilder
=
Expr
$
asks
builder
-- | Get the input files of the current 'Target'.
getInputs
::
Expr
c
b
[
FilePath
]
getInputs
=
Expr
$
asks
inputs
-- | Run 'getInputs' and check that the result contains one input file only.
getInput
::
(
Show
b
,
Show
c
)
=>
Expr
c
b
FilePath
getInput
=
Expr
$
do
target
<-
ask
getSingleton
(
"Exactly one input file expected in "
++
show
target
)
<$>
asks
inputs
-- | Get the files produced by the current 'Target'.
getOutputs
::
Expr
c
b
[
FilePath
]
getOutputs
=
Expr
$
asks
outputs
-- | Run 'getOutputs' and check that the result contains one output file only.
getOutput
::
(
Show
b
,
Show
c
)
=>
Expr
c
b
FilePath
getOutput
=
Expr
$
do
target
<-
ask
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
src/Hadrian/Target.hs
0 → 100644
View file @
48e8b6f2
{-# LANGUAGE DeriveGeneric #-}
module
Hadrian.Target
(
Target
,
target
,
context
,
builder
,
inputs
,
outputs
)
where
import
GHC.Generics
import
Base
-- | Each invocation of a builder is fully described by a 'Target', which
-- comprises a build context (type variable @c@), a builder (type variable @b@),
-- a list of input files and a list of output files. For example:
--
-- @
-- preludeTarget = Target (GHC.Context) (GHC.Builder)
-- { context = Context Stage1 base profiling
-- , builder = Ghc Stage1
-- , inputs = ["libraries/base/Prelude.hs"]
-- , outputs = ["build/stage1/libraries/base/Prelude.p_o"] }
-- @
data
Target
c
b
=
Target
{
context
::
c
-- ^ Current build context
,
builder
::
b
-- ^ Builder to be invoked
,
inputs
::
[
FilePath
]
-- ^ Input files for the builder
,
outputs
::
[
FilePath
]
-- ^ Files to be produced
}
deriving
(
Eq
,
Generic
,
Show
)
target
::
c
->
b
->
[
FilePath
]
->
[
FilePath
]
->
Target
c
b
target
=
Target
instance
(
Binary
c
,
Binary
b
)
=>
Binary
(
Target
c
b
)
instance
(
Hashable
c
,
Hashable
b
)
=>
Hashable
(
Target
c
b
)
instance
(
NFData
c
,
NFData
b
)
=>
NFData
(
Target
c
b
)
src/Oracles/ArgsHash.hs
View file @
48e8b6f2
...
...
@@ -21,10 +21,10 @@ newtype ArgsHashKey = ArgsHashKey Target
-- argument list constructors are assumed not to examine target sources, but
-- only append them to argument lists where appropriate.
checkArgsHash
::
Target
->
Action
()
checkArgsHash
t
arget
=
do
let
hashed
=
[
show
.
hash
$
inputs
t
arget
]
_
<-
askOracle
.
ArgsHashKey
$
target
{
inputs
=
hashed
}
::
Action
Int
return
(
)
checkArgsHash
t
=
do
let
hashed
Inputs
=
[
show
$
hash
(
inputs
t
)
]
hashedTarget
=
target
(
context
t
)
(
builder
t
)
hashedInputs
(
outputs
t
)
void
(
askOracle
$
ArgsHashKey
hashedTarget
::
Action
Int
)
-- | Oracle for storing per-target argument list hashes.
argsHashOracle
::
Rules
()
...
...
src/Rules/Compile.hs
View file @
48e8b6f2
...
...
@@ -19,13 +19,13 @@ compilePackage rs context@Context {..} = do
let
src
=
obj2src
context
obj
need
[
src
]
needDependencies
context
src
$
obj
<.>
"d"
build
$
T
arget
context
(
compiler
stage
)
[
src
]
[
obj
]
build
$
t
arget
context
(
compiler
stage
)
[
src
]
[
obj
]
compileHs
=
\
[
obj
,
_hi
]
->
do
(
src
,
deps
)
<-
fileDependencies
context
obj
need
$
src
:
deps
when
(
isLibrary
package
)
$
need
=<<
return
<$>
pkgConfFile
context
needLibrary
=<<
contextDependencies
context
buildWithResources
rs
$
T
arget
context
(
Ghc
CompileHs
stage
)
[
src
]
[
obj
]
buildWithResources
rs
$
t
arget
context
(
Ghc
CompileHs
stage
)
[
src
]
[
obj
]
priority
2.0
$
do
nonHs
"c"
%>
compile
(
Ghc
CompileCWithGhc
)
(
obj2src
"c"
isGeneratedCFile
)
...
...
@@ -43,7 +43,7 @@ needDependencies :: Context -> FilePath -> FilePath -> Action ()
needDependencies
context
@
Context
{
..
}
src
depFile
=
discover
where
discover
=
do
build
$
T
arget
context
(
Cc
FindCDependencies
stage
)
[
src
]
[
depFile
]
build
$
t
arget
context
(
Cc
FindCDependencies
stage
)
[
src
]
[
depFile
]
deps
<-
parseFile
depFile
-- Generated dependencies, if not yet built, will not be found and hence
-- will be referred to simply by their file names.
...
...
src/Rules/Configure.hs
View file @
48e8b6f2
...
...
@@ -29,7 +29,7 @@ configureRules = do
let
srcs
=
map
(
<.>
"in"
)
outs
context
=
vanillaContext
Stage0
compiler
need
srcs
build
$
T
arget
context
(
Configure
"."
)
srcs
outs
build
$
t
arget
context
(
Configure
"."
)
srcs
outs
[
"configure"
,
configH
<.>
"in"
]
&%>
\
_
->
do
if
cmdSkipConfigure
...
...
src/Rules/Data.hs
View file @
48e8b6f2
...
...
@@ -33,7 +33,7 @@ buildPackageData context@Context {..} = do
need
=<<
mapM
pkgConfFile
=<<
contextDependencies
context
need
[
cabalFile
]
build
$
T
arget
context
GhcCabal
[
cabalFile
]
[
mk
,
setupConfig
]
build
$
t
arget
context
GhcCabal
[
cabalFile
]
[
mk
,
setupConfig
]
postProcessPackageData
context
mk
pkgInplaceConfig
context
%>
\
conf
->
do
...
...
@@ -41,7 +41,7 @@ buildPackageData context@Context {..} = do
if
package
==
rts
then
do
need
[
rtsConfIn
]
build
$
T
arget
context
HsCpp
[
rtsConfIn
]
[
conf
]
build
$
t
arget
context
HsCpp
[
rtsConfIn
]
[
conf
]
fixFile
conf
$
unlines
.
map
(
replace
"
\"\"
"
""
...
...
src/Rules/Dependencies.hs
View file @
48e8b6f2
...
...
@@ -21,7 +21,7 @@ buildPackageDependencies rs context@Context {..} =
if
srcs
==
[]
then
writeFileChanged
mk
""
else
buildWithResources
rs
$
T
arget
context
(
Ghc
FindHsDependencies
stage
)
srcs
[
mk
]
t
arget
context
(
Ghc
FindHsDependencies
stage
)
srcs
[
mk
]
removeFile
$
mk
<.>
"bak"
mkDeps
<-
readFile'
mk
writeFileChanged
deps
.
unlines
...
...
src/Rules/Documentation.hs
View file @
48e8b6f2
...
...
@@ -33,7 +33,7 @@ buildPackageDocumentation context@Context {..} =
-- Build Haddock documentation
-- TODO: pass the correct way from Rules via Context
let
haddockWay
=
if
dynamicGhcPrograms
flavour
then
dynamic
else
vanilla
build
$
T
arget
(
context
{
way
=
haddockWay
})
Haddock
srcs
[
file
]
build
$
t
arget
(
context
{
way
=
haddockWay
})
Haddock
srcs
[
file
]
when
(
package
==
haddock
)
$
haddockHtmlLib
%>
\
_
->
do
let
dir
=
takeDirectory
haddockHtmlLib
...
...
src/Rules/Generate.hs
View file @
48e8b6f2
...
...
@@ -109,7 +109,7 @@ generatePackageCode context@(Context stage pkg _) =
let
unpack
=
fromMaybe
.
error
$
"No generator for "
++
file
++
"."
(
src
,
builder
)
<-
unpack
<$>
findGenerator
context
file
need
[
src
]
build
$
T
arget
context
builder
[
src
]
[
file
]
build
$
t
arget
context
builder
[
src
]
[
file
]
let
boot
=
src
-<.>
"hs-boot"
whenM
(
doesFileExist
boot
)
.
copyFile
boot
$
file
-<.>
"hs-boot"
...
...
@@ -121,7 +121,7 @@ generatePackageCode context@(Context stage pkg _) =
when
(
pkg
==
compiler
)
$
do
primopsTxt
stage
%>
\
file
->
do
need
$
[
platformH
stage
,
primopsSource
]
++
includesDependencies
build
$
T
arget
context
HsCpp
[
primopsSource
]
[
file
]
build
$
t
arget
context
HsCpp
[
primopsSource
]
[
file
]
platformH
stage
%>
go
generateGhcBootPlatformH
...
...
@@ -131,10 +131,10 @@ generatePackageCode context@(Context stage pkg _) =
,
"GHC/PrimopWrappers.hs"
,
"*.hs-incl"
]
|%>
\
file
->
do
need
[
primopsTxt
stage
]
build
$
T
arget
context
GenPrimopCode
[
primopsTxt
stage
]
[
file
]
build
$
t
arget
context
GenPrimopCode
[
primopsTxt
stage
]
[
file
]
when
(
pkg
==
rts
)
$
path
-/-
"cmm/AutoApply.cmm"
%>
\
file
->
build
$
T
arget
context
GenApply
[]
[
file
]
build
$
t
arget
context
GenApply
[]
[
file
]
copyRules
::
Rules
()
copyRules
=
do
...
...
@@ -161,7 +161,7 @@ generateRules = do
-- TODO: simplify, get rid of fake rts context
generatedPath
++
"//*"
%>
\
file
->
do
withTempDir
$
\
dir
->
build
$
T
arget
rtsContext
DeriveConstants
[]
[
file
,
dir
]
t
arget
rtsContext
DeriveConstants
[]
[
file
,
dir
]
where
file
<~
gen
=
file
%>
\
out
->
generate
out
emptyTarget
gen
...
...
src/Rules/Gmp.hs
View file @
48e8b6f2
...
...
@@ -43,13 +43,13 @@ gmpRules = do
putBuild
"| No GMP library/framework detected; in tree GMP will be built"
need
[
gmpLibrary
]
createDirectory
gmpObjects
build
$
T
arget
gmpContext
(
Ar
Stage1
)
[
gmpLibrary
]
[
gmpObjects
]
build
$
t
arget
gmpContext
(
Ar
Stage1
)
[
gmpLibrary
]
[
gmpObjects
]
copyFile
(
gmpBuildPath
-/-
"gmp.h"
)
header
copyFile
(
gmpBuildPath
-/-
"gmp.h"
)
gmpLibraryInTreeH
-- Build in-tree GMP library
gmpLibrary
%>
\
lib
->
do
build
$
T
arget
gmpContext
(
Make
gmpBuildPath
)
[
gmpMakefile
]
[
lib
]
build
$
t
arget
gmpContext
(
Make
gmpBuildPath
)
[
gmpMakefile
]
[
lib
]
putSuccess
"| Successfully built custom library 'gmp'"
-- In-tree GMP header is built in the gmpLibraryH rule
...
...
@@ -64,7 +64,7 @@ gmpRules = do
env
<-
configureEnvironment
need
[
mk
<.>
"in"
]
buildWithCmdOptions
env
$
T
arget
gmpContext
(
Configure
gmpBuildPath
)
[
mk
<.>
"in"
]
[
mk
]
t
arget
gmpContext
(
Configure
gmpBuildPath
)
[
mk
<.>
"in"
]
[
mk
]
-- Extract in-tree GMP sources and apply patches
gmpMakefile
<.>
"in"
%>
\
_
->
do
...
...
@@ -79,7 +79,7 @@ gmpRules = do
withTempDir
$
\
dir
->
do
let
tmp
=
unifyPath
dir
need
[
tarball
]
build
$
T
arget
gmpContext
Tar
[
tarball
]
[
tmp
]
build
$
t
arget
gmpContext
Tar
[
tarball
]
[
tmp
]
let
patch
=
gmpBase
-/-
"gmpsrc.patch"
patchName
=
takeFileName
patch
...
...
src/Rules/Install.hs
View file @
48e8b6f2
...
...
@@ -135,7 +135,7 @@ installPackageConf :: Action ()
installPackageConf
=
do
let
context
=
vanillaContext
Stage0
rts
liftIO
$
IO
.
createDirectoryIfMissing
True
(
takeDirectory
pkgConfInstallPath
)
build
$
T
arget
context
HsCpp
[
pkgPath
rts
-/-
"package.conf.in"
]
build
$
t
arget
context
HsCpp
[
pkgPath
rts
-/-
"package.conf.in"
]
[
pkgConfInstallPath
<.>
"raw"
]
Stdout
content
<-
cmd
"grep"
[
"-v"
,
"^#pragma GCC"
,
pkgConfInstallPath
<.>
"raw"
]
...
...
@@ -206,7 +206,7 @@ installPackages = do
installDistDir
(
installDistDir
-/-
"build"
)
whenM
(
isSpecified
HsColour
)
$
build
$
T
arget
context
GhcCabalHsColour
[
cabalFile
]
[]
build
$
t
arget
context
GhcCabalHsColour
[
cabalFile
]
[]
pref
<-
setting
InstallPrefix
unit
$
cmd
ghcCabalInplace
[
"copy"
...
...
@@ -282,7 +282,7 @@ installLibsTo libs dir = do
installData
[
out
]
dir
let
context
=
vanillaContext
Stage0
$
topLevel
(
PackageName
""
)
-- TODO: Get rid of meaningless context for certain builder like ranlib
build
$
T
arget
context
Ranlib
[
out
]
[
out
]
build
$
t
arget
context
Ranlib
[
out
]
[
out
]
_
->
installData
[
lib
]
dir
-- ref: includes/ghc.mk
...
...
src/Rules/Libffi.hs
View file @
48e8b6f2
...
...
@@ -49,7 +49,7 @@ libffiRules = do
copyFile
(
ffiIncludeDir
-/-
file
)
(
rtsBuildPath
-/-
file
)
putSuccess
$
"| Successfully copied system FFI library header files"
else
do
build
$
T
arget
libffiContext
(
Make
libffiBuildPath
)
[]
[]
build
$
t
arget
libffiContext
(
Make
libffiBuildPath
)
[]
[]
hs
<-
getDirectoryFiles
""
[
libffiBuildPath
-/-
"inst/lib/*/include/*"
]
forM_
hs
$
\
header
->
...
...
@@ -72,7 +72,7 @@ libffiRules = do
removeDirectory
(
buildRootPath
-/-
libname
)
-- TODO: Simplify.
actionFinally
(
do
build
$
T
arget
libffiContext
Tar
[
tarball
]
[
buildRootPath
]
build
$
t
arget
libffiContext
Tar
[
tarball
]
[
buildRootPath
]
moveDirectory
(
buildRootPath
-/-
libname
)
libffiBuildPath
)
$
removeFiles
buildRootPath
[
libname
<//>
"*"
]
...
...
@@ -86,4 +86,4 @@ libffiRules = do
env
<-
configureEnvironment
buildWithCmdOptions
env
$
T
arget
libffiContext
(
Configure
libffiBuildPath
)
[
mk
<.>
"in"
]
[
mk
]
t
arget
libffiContext
(
Configure
libffiBuildPath
)
[
mk
<.>
"in"
]
[
mk
]
src/Rules/Library.hs
View file @
48e8b6f2
...
...
@@ -50,7 +50,7 @@ buildDynamicLib context@Context{..} = do
deps
<-
contextDependencies
context
need
=<<
mapM
pkgLibraryFile
deps
objs
<-
libraryObjects
context
build
$
T
arget
context
(
Ghc
LinkHs
stage
)
objs
[
so
]
build
$
t
arget
context
(
Ghc
LinkHs
stage
)
objs
[
so
]
buildPackageLibrary
::
Context
->
Rules
()
buildPackageLibrary
context
@
Context
{
..
}
=
do
...
...
@@ -61,8 +61,8 @@ buildPackageLibrary context@Context {..} = do
asuf
<-
libsuf
way
let
isLib0
=
(
"//*-0"
++
asuf
)
?==
a
removeFile
a
if
isLib0
then
build
$
T
arget
context
(
Ar
stage
)
[]
[
a
]
-- TODO: Scan for dlls
else
build
$
T
arget
context
(
Ar
stage
)
objs
[
a
]
if
isLib0
then
build
$
t
arget
context
(
Ar
stage
)
[]
[
a
]
-- TODO: Scan for dlls
else
build
$
t
arget
context
(
Ar
stage
)
objs
[
a
]
synopsis
<-
interpretInContext
context
$
getPkgData
Synopsis
unless
isLib0
.
putSuccess
$
renderLibrary
...
...
@@ -75,7 +75,7 @@ buildPackageGhciLibrary context@Context {..} = priority 2 $ do
matchVersionedFilePath
libPrefix
(
waySuffix
way
<.>
"o"
)
?>
\
obj
->
do
objs
<-
allObjects
context
need
objs
build
$
T
arget
context
Ld
objs
[
obj
]
build
$
t
arget
context
Ld
objs
[
obj
]
allObjects
::
Context
->
Action
[
FilePath
]
allObjects
context
=
(
++
)
<$>
nonHsObjects
context
<*>
hsObjects
context
...
...
src/Rules/Program.hs
View file @
48e8b6f2
...
...
@@ -104,7 +104,7 @@ buildBinary rs context@Context {..} bin = do
++
[
path
-/-
"Paths_hsc2hs.o"
|
package
==
hsc2hs
]
++
[
path
-/-
"Paths_haddock.o"
|
package
==
haddock
]
need
binDeps
buildWithResources
rs
$
T
arget
context
(
Ghc
LinkHs
stage
)
binDeps
[
bin
]
buildWithResources
rs
$
t
arget
context
(
Ghc
LinkHs
stage
)
binDeps
[
bin
]
synopsis
<-
interpretInContext
context
$
getPkgData
Synopsis
putSuccess
$
renderProgram
(
quote
(
pkgNameString
package
)
++
" ("
++
show
stage
++
")."
)
...
...
src/Rules/Register.hs
View file @
48e8b6f2
...
...
@@ -19,11 +19,11 @@ registerPackage rs context@Context {..} = when (stage <= Stage1) $ do
matchVersionedFilePath
(
dir
-/-
pkgNameString
package
)
"conf"
?>
\
conf
->
do
need
[
confIn
]
buildWithResources
rs
$
T
arget
context
(
GhcPkg
Update
stage
)
[
confIn
]
[
conf
]
t
arget
context
(
GhcPkg
Update
stage
)
[
confIn
]
[
conf
]
when
(
package
==
ghc
)
$
packageDbStamp
stage
%>
\
stamp
->
do
removeDirectory
dir
buildWithResources
rs
$
T
arget
(
vanillaContext
stage
ghc
)
(
GhcPkg
Init
stage
)
[]
[
dir
]
t
arget
(
vanillaContext
stage
ghc
)
(
GhcPkg
Init
stage
)
[]
[
dir
]
writeFileLines
stamp
[]
putSuccess
$
"| Successfully initialised "
++
dir
src/Rules/Test.hs
View file @
48e8b6f2
...
...
@@ -24,7 +24,7 @@ testRules = do
need
[
"inplace/bin/hp2ps"
,
"inplace/bin/hsc2hs"
]