Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
15acc2cd
Commit
15acc2cd
authored
May 22, 2016
by
Andrey Mokhov
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Minor revision
parent
8933a3a8
Changes
14
Hide whitespace changes
Inline
Side-by-side
Showing
14 changed files
with
67 additions
and
91 deletions
+67
-91
src/Builder.hs
src/Builder.hs
+11
-10
src/Expression.hs
src/Expression.hs
+4
-6
src/Oracles/Config.hs
src/Oracles/Config.hs
+9
-13
src/Oracles/Config/Flag.hs
src/Oracles/Config/Flag.hs
+15
-17
src/Oracles/Config/Setting.hs
src/Oracles/Config/Setting.hs
+2
-2
src/Oracles/Dependencies.hs
src/Oracles/Dependencies.hs
+11
-19
src/Oracles/LookupInPath.hs
src/Oracles/LookupInPath.hs
+2
-4
src/Oracles/ModuleFiles.hs
src/Oracles/ModuleFiles.hs
+1
-1
src/Oracles/PackageData.hs
src/Oracles/PackageData.hs
+1
-4
src/Predicate.hs
src/Predicate.hs
+3
-4
src/Rules/Generate.hs
src/Rules/Generate.hs
+2
-4
src/Rules/Gmp.hs
src/Rules/Gmp.hs
+4
-5
src/Rules/Libffi.hs
src/Rules/Libffi.hs
+1
-1
src/Settings/Builders/GhcCabal.hs
src/Settings/Builders/GhcCabal.hs
+1
-1
No files found.
src/Builder.hs
View file @
15acc2cd
...
...
@@ -22,7 +22,7 @@ import Stage
data
CompilerMode
=
Compile
|
FindDependencies
|
Link
deriving
(
Show
,
Eq
,
Generic
)
deriving
(
Eq
,
Generic
,
Show
)
-- TODO: Do we really need HsCpp builder? Can't we use Cc instead?
-- | A 'Builder' is an external command invoked in separate process using 'Shake.cmd'
...
...
@@ -57,7 +57,7 @@ data Builder = Alex
|
Ranlib
|
Tar
|
Unlit
deriving
(
Show
,
Eq
,
Generic
)
deriving
(
Eq
,
Generic
,
Show
)
-- | Some builders are built by this very build system, in which case
-- 'builderProvenance' returns the corresponding build 'Context' (which includes
...
...
@@ -93,7 +93,7 @@ isOptional = \case
Objdump
->
True
_
->
False
-- TODO:
g
et rid of fromJust
-- TODO:
G
et rid of fromJust
.
-- | Determine the location of a 'Builder'.
builderPath
::
Builder
->
Action
FilePath
builderPath
builder
=
case
builderProvenance
builder
of
...
...
@@ -121,14 +121,14 @@ builderPath builder = case builderProvenance builder of
_
->
error
$
"Cannot determine builderPath for "
++
show
builder
where
fromKey
key
=
do
path
<-
askConfigWithDefault
key
.
error
$
"
\n
Cannot find path to "
++
quote
key
++
" in system.config file. Did you skip configure?"
let
unpack
=
fromMaybe
.
error
$
"Cannot find path to builder "
++
quote
key
++
" in system.config file. Did you skip configure?"
path
<-
unpack
<$>
askConfig
key
if
null
path
then
do
if
isOptional
builder
then
return
""
else
error
$
"Builder "
++
quote
key
++
" is not specified in"
++
" system.config file. Cannot proceed without it."
unless
(
isOptional
builder
)
.
error
$
"Non optional builder "
++
quote
key
++
" is not specified in system.config file."
return
""
-- TODO: Use a safe interface.
else
fixAbsolutePathOnWindows
=<<
lookupInPath
path
getBuilderPath
::
Builder
->
ReaderT
a
Action
FilePath
...
...
@@ -141,6 +141,7 @@ builderEnvironment variable builder = do
path
<-
builderPath
builder
return
$
AddEnv
variable
path
-- | Was the path to a given 'Builder' specified in configuration files?
specified
::
Builder
->
Action
Bool
specified
=
fmap
(
not
.
null
)
.
builderPath
...
...
@@ -152,7 +153,7 @@ needBuilder = \case
path
<-
builderPath
builder
need
[
path
]
-- Instances for storing in the Shake database
--
|
Instances for storing in the Shake database
.
instance
Binary
CompilerMode
instance
Hashable
CompilerMode
instance
NFData
CompilerMode
...
...
src/Expression.hs
View file @
15acc2cd
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleInstances
, LambdaCase
#-}
module
Expression
(
-- * Expressions
Expr
,
DiffExpr
,
fromDiffExpr
,
...
...
@@ -207,8 +207,6 @@ getOutput = do
"getOutput: exactly one output file expected in target "
++
show
target
getSingleton
::
Expr
[
a
]
->
String
->
Expr
a
getSingleton
expr
msg
=
do
xs
<-
expr
case
xs
of
[
res
]
->
return
res
_
->
error
msg
getSingleton
expr
msg
=
expr
>>=
\
case
[
res
]
->
return
res
_
->
error
msg
src/Oracles/Config.hs
View file @
15acc2cd
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module
Oracles.Config
(
askConfig
,
a
skConfig
WithDefault
,
configOracle
)
where
module
Oracles.Config
(
askConfig
,
unsafeA
skConfig
,
configOracle
)
where
import
qualified
Data.HashMap.Strict
as
Map
import
Development.Shake.Config
...
...
@@ -9,23 +9,19 @@ import Base
newtype
ConfigKey
=
ConfigKey
String
deriving
(
Binary
,
Eq
,
Hashable
,
NFData
,
Show
,
Typeable
)
askConfig
::
String
->
Action
String
askConfig
key
=
askConfigWithDefault
key
.
error
$
"Cannot find key "
++
quote
key
++
" in configuration files."
unsafeAskConfig
::
String
->
Action
String
unsafeAskConfig
key
=
(
fromMaybe
$
error
msg
)
<$>
askConfig
key
where
msg
=
"Key "
++
quote
key
++
" not found in configuration files."
askConfigWithDefault
::
String
->
Action
String
->
Action
String
askConfigWithDefault
key
defaultAction
=
do
maybeValue
<-
askOracle
$
ConfigKey
key
case
maybeValue
of
Just
value
->
return
value
Nothing
->
defaultAction
askConfig
::
String
->
Action
(
Maybe
String
)
askConfig
=
askOracle
.
ConfigKey
-- Oracle for configuration files
configOracle
::
Rules
()
configOracle
=
do
configOracle
=
void
$
do
cfg
<-
newCache
$
\
()
->
do
need
[
configFile
]
putLoud
$
"Reading "
++
configFile
++
"..."
liftIO
$
readConfigFile
configFile
_
<-
addOracle
$
\
(
ConfigKey
key
)
->
Map
.
lookup
key
<$>
cfg
()
return
()
addOracle
$
\
(
ConfigKey
key
)
->
Map
.
lookup
key
<$>
cfg
()
src/Oracles/Config/Flag.hs
View file @
15acc2cd
...
...
@@ -25,23 +25,21 @@ data Flag = ArSupportsAtFile
-- fragile, but some flags do behave like this, e.g. GccIsClang.
flag
::
Flag
->
Action
Bool
flag
f
=
do
key
<-
return
$
case
f
of
ArSupportsAtFile
->
"ar-supports-at-file"
CrossCompiling
->
"cross-compiling"
GccIsClang
->
"gcc-is-clang"
GccLt46
->
"gcc-lt-46"
GhcUnregisterised
->
"ghc-unregisterised"
LeadingUnderscore
->
"leading-underscore"
SolarisBrokenShld
->
"solaris-broken-shld"
SplitObjectsBroken
->
"split-objects-broken"
SupportsThisUnitId
->
"supports-this-unit-id"
WithLibdw
->
"with-libdw"
UseSystemFfi
->
"use-system-ffi"
value
<-
askConfigWithDefault
key
.
error
$
"
\n
Flag "
++
quote
key
++
" not set in configuration files."
unless
(
value
==
"YES"
||
value
==
"NO"
||
value
==
""
)
.
error
$
"
\n
Flag "
++
quote
key
++
" is set to "
++
quote
value
++
" instead of 'YES' or 'NO'."
let
key
=
case
f
of
ArSupportsAtFile
->
"ar-supports-at-file"
CrossCompiling
->
"cross-compiling"
GccIsClang
->
"gcc-is-clang"
GccLt46
->
"gcc-lt-46"
GhcUnregisterised
->
"ghc-unregisterised"
LeadingUnderscore
->
"leading-underscore"
SolarisBrokenShld
->
"solaris-broken-shld"
SplitObjectsBroken
->
"split-objects-broken"
SupportsThisUnitId
->
"supports-this-unit-id"
WithLibdw
->
"with-libdw"
UseSystemFfi
->
"use-system-ffi"
value
<-
unsafeAskConfig
key
when
(
value
`
notElem
`
[
"YES"
,
"NO"
,
""
])
.
error
$
"Configuration flag "
++
quote
(
key
++
" = "
++
value
)
++
"cannot be parsed."
return
$
value
==
"YES"
getFlag
::
Flag
->
ReaderT
a
Action
Bool
...
...
src/Oracles/Config/Setting.hs
View file @
15acc2cd
...
...
@@ -59,7 +59,7 @@ data SettingList = ConfCcArgs Stage
|
HsCppArgs
setting
::
Setting
->
Action
String
setting
key
=
a
skConfig
$
case
key
of
setting
key
=
unsafeA
skConfig
$
case
key
of
BuildArch
->
"build-arch"
BuildOs
->
"build-os"
BuildPlatform
->
"build-platform"
...
...
@@ -96,7 +96,7 @@ setting key = askConfig $ case key of
IconvLibDir
->
"iconv-lib-dir"
settingList
::
SettingList
->
Action
[
String
]
settingList
key
=
fmap
words
$
a
skConfig
$
case
key
of
settingList
key
=
fmap
words
$
unsafeA
skConfig
$
case
key
of
ConfCcArgs
stage
->
"conf-cc-args-"
++
stageString
stage
ConfCppArgs
stage
->
"conf-cpp-args-"
++
stageString
stage
ConfGccLinkerArgs
stage
->
"conf-gcc-linker-args-"
++
stageString
stage
...
...
src/Oracles/Dependencies.hs
View file @
15acc2cd
...
...
@@ -41,18 +41,11 @@ newtype PkgDepsKey = PkgDepsKey String
-- compute package dependencies we scan package cabal files, see "Rules.Cabal".
contextDependencies
::
Context
->
Action
[
Context
]
contextDependencies
context
@
Context
{
..
}
=
do
maybeDeps
<-
askOracle
.
PkgDepsKey
$
pkgNameString
package
deps
<-
case
maybeDeps
of
Nothing
->
error
$
"Context dependencies not found for "
++
show
context
Just
ds
->
return
$
map
PackageName
ds
let
pkgContext
=
\
pkg
->
Context
(
min
stage
Stage1
)
pkg
way
pkgs
<-
interpretInContext
(
pkgContext
package
)
getPackages
return
.
map
pkgContext
$
matchPackageNames
(
sort
pkgs
)
deps
-- | Given a sorted list of packages and a sorted list of package names, returns
-- packages whose names appear in the list of names.
matchPackageNames
::
[
Package
]
->
[
PackageName
]
->
[
Package
]
matchPackageNames
=
intersectOrd
(
\
pkg
name
->
compare
(
pkgName
pkg
)
name
)
unpack
=
fromMaybe
.
error
$
"No dependencies for "
++
show
context
deps
<-
unpack
<$>
askOracle
(
PkgDepsKey
$
pkgNameString
package
)
pkgs
<-
sort
<$>
interpretInContext
(
pkgContext
package
)
getPackages
return
.
map
pkgContext
$
intersectOrd
(
compare
.
pkgNameString
)
pkgs
deps
-- | Coarse-grain 'need': make sure given contexts are fully built.
needContext
::
[
Context
]
->
Action
()
...
...
@@ -71,14 +64,13 @@ needContext cs = do
-- | Oracles for the package dependencies and 'path/dist/.dependencies' files.
dependenciesOracles
::
Rules
()
dependenciesOracles
=
do
deps
<-
newCache
$
\
file
->
do
putLoud
$
"Reading dependencies from "
++
file
++
"..."
contents
<-
map
words
<$>
readFileLines
file
return
.
Map
.
fromList
$
map
(
\
(
x
:
xs
)
->
(
x
,
xs
))
contents
deps
<-
newCache
readDependencies
void
$
addOracle
$
\
(
ObjDepsKey
(
file
,
obj
))
->
Map
.
lookup
obj
<$>
deps
file
pkgDeps
<-
newCache
$
\
_
->
do
putLoud
$
"Reading package dependencies..."
contents
<-
readFileLines
packageDependencies
return
$
Map
.
fromList
[
(
p
,
ps
)
|
s
<-
contents
,
let
p
:
ps
=
words
s
]
pkgDeps
<-
newCache
$
\
_
->
readDependencies
packageDependencies
void
$
addOracle
$
\
(
PkgDepsKey
pkg
)
->
Map
.
lookup
pkg
<$>
pkgDeps
()
where
readDependencies
file
=
do
putLoud
$
"Reading dependencies from "
++
file
++
"..."
contents
<-
map
words
<$>
readFileLines
file
return
$
Map
.
fromList
[
(
key
,
values
)
|
(
key
:
values
)
<-
contents
]
src/Oracles/LookupInPath.hs
View file @
15acc2cd
...
...
@@ -17,9 +17,7 @@ lookupInPath name
lookupInPathOracle
::
Rules
()
lookupInPathOracle
=
void
$
addOracle
$
\
(
LookupInPath
name
)
->
do
maybePath
<-
liftIO
$
findExecutable
name
path
<-
case
maybePath
of
Just
value
->
return
$
unifyPath
value
Nothing
->
error
$
"Cannot find executable '"
++
name
++
"'."
let
unpack
=
fromMaybe
.
error
$
"Cannot find executable "
++
quote
name
path
<-
unifyPath
<$>
unpack
<$>
liftIO
(
findExecutable
name
)
putLoud
$
"Executable found: "
++
name
++
" => "
++
path
return
path
src/Oracles/ModuleFiles.hs
View file @
15acc2cd
...
...
@@ -78,7 +78,7 @@ haskellSources context = do
let
autogen
=
buildPath
context
-/-
"autogen"
-- Generated source files live in buildPath and have extension "hs", except
-- for GHC/Prim.hs that lives in autogen. TODO: fix the inconsistency?
let
modFile
(
"GHC.Prim"
,
_
)
=
autogen
-/-
"GHC/Prim.hs"
modFile
(
"GHC.Prim"
,
_
)
=
autogen
-/-
"GHC/Prim.hs"
modFile
(
m
,
Nothing
)
=
generatedFile
context
m
modFile
(
m
,
Just
file
)
|
takeExtension
file
`
elem
`
haskellExtensions
=
file
...
...
src/Oracles/PackageData.hs
View file @
15acc2cd
...
...
@@ -38,10 +38,7 @@ askPackageData :: FilePath -> String -> Action String
askPackageData
path
key
=
do
let
fullKey
=
replaceSeparators
'_'
$
path
++
"_"
++
key
file
=
path
-/-
"package-data.mk"
maybeValue
<-
askOracle
$
PackageDataKey
(
file
,
fullKey
)
case
maybeValue
of
Nothing
->
return
""
Just
value
->
return
value
fromMaybe
""
<$>
askOracle
(
PackageDataKey
(
file
,
fullKey
))
-- | For each @PackageData path@ the file 'path/package-data.mk' contains a line
-- of the form 'path_VERSION = 1.2.3.4'. @pkgData (PackageData path)@ is an
...
...
src/Predicate.hs
View file @
15acc2cd
{-# LANGUAGE
LambdaCase,
FlexibleInstances #-}
{-# LANGUAGE FlexibleInstances
, LambdaCase
#-}
-- | Convenient predicates
module
Predicate
(
module
Expression
,
stage
,
stage0
,
stage1
,
stage2
,
notStage0
,
package
,
notPackage
,
builder
,
input
,
output
,
way
module
Expression
,
stage
,
stage0
,
stage1
,
stage2
,
notStage0
,
builder
,
package
,
notPackage
,
input
,
output
,
way
)
where
import
Base
...
...
src/Rules/Generate.hs
View file @
15acc2cd
...
...
@@ -107,10 +107,8 @@ generatePackageCode context@(Context stage pkg _) =
file
<~
gen
=
generate
file
context
gen
in
do
generated
?>
\
file
->
do
maybeValue
<-
findGenerator
context
file
(
src
,
builder
)
<-
case
maybeValue
of
Nothing
->
error
$
"No generator for "
++
file
++
"."
Just
value
->
return
value
let
unpack
=
fromMaybe
.
error
$
"No generator for "
++
file
++
"."
(
src
,
builder
)
<-
unpack
<$>
findGenerator
context
file
need
[
src
]
build
$
Target
context
builder
[
src
]
[
file
]
let
srcBoot
=
src
-<.>
"hs-boot"
...
...
src/Rules/Gmp.hs
View file @
15acc2cd
...
...
@@ -54,7 +54,7 @@ gmpRules = do
-- That's because the doc/ directory contents are under the GFDL,
-- which causes problems for Debian.
tarballs
<-
getDirectoryFiles
""
[
gmpBase
-/-
"tarball/gmp*.tar.bz2"
]
tarball
<-
case
tarballs
of
tarball
<-
case
tarballs
of
-- TODO: Drop code duplication.
[
file
]
->
return
$
unifyPath
file
_
->
error
$
"gmpRules: exactly one tarball expected"
++
"(found: "
++
show
tarballs
++
")."
...
...
@@ -70,11 +70,10 @@ gmpRules = do
copyFile
src
patchPath
applyPatch
tmp
patch
let
name
=
dropExtension
.
dropExtension
$
takeFileName
tarball
libName
<-
case
stripSuffix
"-nodoc-patched"
name
of
Just
rest
->
return
rest
Nothing
->
error
$
"gmpRules: expected suffix "
let
name
=
dropExtension
.
dropExtension
$
takeFileName
tarball
unpack
=
fromMaybe
.
error
$
"gmpRules: expected suffix "
++
"-nodoc-patched (found: "
++
name
++
")."
libName
=
unpack
$
stripSuffix
"-nodoc-patched"
name
moveDirectory
(
tmp
-/-
libName
)
gmpBuildPath
...
...
src/Rules/Libffi.hs
View file @
15acc2cd
...
...
@@ -72,7 +72,7 @@ libffiRules = do
createDirectory
$
buildRootPath
-/-
stageString
Stage0
tarballs
<-
getDirectoryFiles
""
[
"libffi-tarballs/libffi*.tar.gz"
]
tarball
<-
case
tarballs
of
tarball
<-
case
tarballs
of
-- TODO: Drop code duplication.
[
file
]
->
return
$
unifyPath
file
_
->
error
$
"libffiRules: exactly one tarball expected"
++
"(found: "
++
show
tarballs
++
")."
...
...
src/Settings/Builders/GhcCabal.hs
View file @
15acc2cd
...
...
@@ -114,7 +114,7 @@ withBuilderKey b = case b of
Happy
->
"--with-happy="
GhcPkg
_
->
"--with-ghc-pkg="
HsColour
->
"--with-hscolour="
_
->
error
"withBuilderKey: not supported builder
"
_
->
error
$
"withBuilderKey: not supported builder
"
++
show
b
-- Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex.
with
::
Builder
->
Args
...
...
Write
Preview
Markdown
is supported
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