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
49419bc5
Commit
49419bc5
authored
Jul 19, 2015
by
Andrey Mokhov
Browse files
Refactor oracles, add comments.
parent
03f90e74
Changes
15
Hide whitespace changes
Inline
Side-by-side
src/Builder.hs
View file @
49419bc5
...
...
@@ -11,9 +11,6 @@ import Oracles.Base
import
Oracles.Flag
import
Oracles.Setting
import
GHC.Generics
import
Development.Shake
import
Development.Shake.Classes
import
Development.Shake.FilePath
-- A Builder is an external command invoked in separate process using Shake.cmd
--
...
...
src/Expression.hs
View file @
49419bc5
...
...
@@ -20,7 +20,6 @@ import Oracles.Base
import
Data.List
import
Data.Monoid
import
Control.Monad.Reader
hiding
(
liftIO
)
import
Development.Shake
-- Expr a is a computation that produces a value of type Action a and can read
-- parameters of the current build Target.
...
...
src/Main.hs
View file @
49419bc5
import
Rules
import
Config
import
Development.Shake
main
=
shakeArgs
shakeOptions
{
shakeFiles
=
"_build/"
}
$
do
...
...
src/Oracles.hs
deleted
100644 → 0
View file @
03f90e74
module
Oracles
(
module
Oracles
.
Base
,
configOracle
,
packageDataOracle
,
dependencyOracle
)
where
import
Util
import
Config
import
Oracles.Base
import
Oracles.PackageData
import
Oracles.DependencyList
import
Data.List
import
Data.Function
import
qualified
Data.HashMap.Strict
as
M
import
Control.Applicative
import
Control.Monad.Extra
import
Development.Shake
import
Development.Shake.Util
import
Development.Shake.Config
import
Development.Shake.FilePath
-- Oracle for configuration files
configOracle
::
Rules
()
configOracle
=
do
let
configFile
=
cfgPath
</>
"system.config"
cfg
<-
newCache
$
\
()
->
do
unlessM
(
doesFileExist
$
configFile
<.>
"in"
)
$
redError_
$
"
\n
Configuration file '"
++
(
configFile
<.>
"in"
)
++
"' is missing; unwilling to proceed."
need
[
configFile
]
putOracle
$
"Reading "
++
unifyPath
configFile
++
"..."
liftIO
$
readConfigFile
configFile
addOracle
$
\
(
ConfigKey
key
)
->
M
.
lookup
key
<$>
cfg
()
return
()
-- Oracle for 'package-data.mk' files
packageDataOracle
::
Rules
()
packageDataOracle
=
do
pkgData
<-
newCache
$
\
file
->
do
need
[
file
]
putOracle
$
"Reading "
++
file
++
"..."
liftIO
$
readConfigFile
file
addOracle
$
\
(
PackageDataKey
(
file
,
key
))
->
M
.
lookup
key
<$>
pkgData
(
unifyPath
file
)
return
()
bimap
::
(
a
->
b
)
->
(
c
->
d
)
->
(
a
,
c
)
->
(
b
,
d
)
bimap
f
g
(
x
,
y
)
=
(
f
x
,
g
y
)
-- Oracle for 'path/dist/*.deps' files
dependencyOracle
::
Rules
()
dependencyOracle
=
do
deps
<-
newCache
$
\
file
->
do
need
[
file
]
putOracle
$
"Reading "
++
file
++
"..."
contents
<-
parseMakefile
<$>
(
liftIO
$
readFile
file
)
return
$
M
.
fromList
$
map
(
bimap
unifyPath
(
map
unifyPath
))
$
map
(
bimap
head
concat
.
unzip
)
$
groupBy
((
==
)
`
on
`
fst
)
$
sortBy
(
compare
`
on
`
fst
)
contents
addOracle
$
\
(
DependencyListKey
(
file
,
obj
))
->
M
.
lookup
(
unifyPath
obj
)
<$>
deps
(
unifyPath
file
)
return
()
-- Make oracle's output more distinguishable
putOracle
::
String
->
Action
()
putOracle
=
putColoured
Blue
src/Oracles/ArgsHash.hs
View file @
49419bc5
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module
Oracles.ArgsHash
(
ArgsHashKey
(
..
),
askArgsHash
,
argsHashOracle
askArgsHash
,
argsHashOracle
)
where
import
Expression
...
...
@@ -11,8 +11,12 @@ import Development.Shake
import
Development.Shake.Classes
newtype
ArgsHashKey
=
ArgsHashKey
FullTarget
deriving
(
Show
,
Typeable
,
Eq
,
Hashable
,
Binary
,
NFData
)
deriving
(
Show
,
Typeable
,
Eq
,
Hashable
,
Binary
,
NFData
)
-- This is an action that given a full target determines the corresponding
-- argument list and computes its hash. The resulting value is tracked in a
-- Shake oracle, hence initiating rebuilts when the hash is changed (a hash
-- change indicates changes in the build system).
askArgsHash
::
FullTarget
->
Action
Int
askArgsHash
=
askOracle
.
ArgsHashKey
...
...
src/Oracles/Base.hs
View file @
49419bc5
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module
Oracles.Base
(
ConfigKey
(
..
),
askConfigWithDefault
,
askConfig
module
Development
.
Shake
,
module
Development
.
Shake
.
Util
,
module
Development
.
Shake
.
Config
,
module
Development
.
Shake
.
Classes
,
module
Development
.
Shake
.
FilePath
,
askConfigWithDefault
,
askConfig
,
configOracle
,
configPath
,
putOracle
)
where
import
Util
import
Control.Applicative
import
Control.Monad.Extra
import
Development.Shake
import
Development.Shake.Util
import
Development.Shake.Config
import
Development.Shake.Classes
import
Development.Shake.FilePath
import
qualified
Data.HashMap.Strict
as
Map
configPath
::
FilePath
configPath
=
"shake"
</>
"cfg"
newtype
ConfigKey
=
ConfigKey
String
deriving
(
Show
,
Typeable
,
Eq
,
Hashable
,
Binary
,
NFData
)
...
...
@@ -20,5 +35,23 @@ askConfigWithDefault key defaultAction = do
Nothing
->
defaultAction
askConfig
::
String
->
Action
String
askConfig
key
=
askConfigWithDefault
key
$
redError
$
"Cannot find key '"
++
key
++
"' in configuration files."
askConfig
key
=
askConfigWithDefault
key
.
redError
$
"Cannot find key '"
++
key
++
"' in configuration files."
-- Oracle for configuration files
configOracle
::
Rules
()
configOracle
=
do
let
configFile
=
configPath
</>
"system.config"
cfg
<-
newCache
$
\
()
->
do
unlessM
(
doesFileExist
$
configFile
<.>
"in"
)
$
redError_
$
"
\n
Configuration file '"
++
(
configFile
<.>
"in"
)
++
"' is missing; unwilling to proceed."
need
[
configFile
]
putOracle
$
"Reading "
++
unifyPath
configFile
++
"..."
liftIO
$
readConfigFile
configFile
addOracle
$
\
(
ConfigKey
key
)
->
Map
.
lookup
key
<$>
cfg
()
return
()
-- Make oracle's output more distinguishable
putOracle
::
String
->
Action
()
putOracle
=
putColoured
Blue
src/Oracles/DependencyList.hs
View file @
49419bc5
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module
Oracles.DependencyList
(
DependencyList
(
..
),
DependencyListKey
(
..
),
dependencyList
dependencyList
,
dependencyListOracle
)
where
import
Util
import
Oracles.Base
import
Data.List
import
Data.Maybe
import
Development.Shake
import
Development.Shake.Classes
data
DependencyList
=
DependencyList
FilePath
FilePath
import
Data.Function
import
qualified
Data.HashMap.Strict
as
Map
import
Control.Applicative
newtype
DependencyListKey
=
DependencyListKey
(
FilePath
,
FilePath
)
deriving
(
Show
,
Typeable
,
Eq
,
Hashable
,
Binary
,
NFData
)
deriving
(
Show
,
Typeable
,
Eq
,
Hashable
,
Binary
,
NFData
)
-- dependencyList depFile objFile is an action that looks up dependencies of an
-- object file (objFile) in a generated dependecy file (depFile).
dependencyList
::
FilePath
->
FilePath
->
Action
[
FilePath
]
dependencyList
depFile
objFile
=
do
res
<-
askOracle
$
DependencyListKey
(
depFile
,
objFile
)
return
$
fromMaybe
[]
res
-- Oracle for 'path/dist/*.deps' files
dependencyListOracle
::
Rules
()
dependencyListOracle
=
do
deps
<-
newCache
$
\
file
->
do
need
[
file
]
putOracle
$
"Reading "
++
file
++
"..."
contents
<-
parseMakefile
<$>
(
liftIO
$
readFile
file
)
return
$
Map
.
fromList
$
map
(
bimap
unifyPath
(
map
unifyPath
))
$
map
(
bimap
head
concat
.
unzip
)
$
groupBy
((
==
)
`
on
`
fst
)
$
sortBy
(
compare
`
on
`
fst
)
contents
addOracle
$
\
(
DependencyListKey
(
file
,
obj
))
->
Map
.
lookup
(
unifyPath
obj
)
<$>
deps
(
unifyPath
file
)
return
()
dependencyList
::
DependencyList
->
Action
[
FilePath
]
dependencyList
(
DependencyList
file
obj
)
=
do
res
<-
askOracle
$
DependencyListKey
(
file
,
obj
)
return
$
fromMaybe
[]
res
bimap
::
(
a
->
b
)
->
(
c
->
d
)
->
(
a
,
c
)
->
(
b
,
d
)
bimap
f
g
(
x
,
y
)
=
(
f
x
,
g
y
)
src/Oracles/Flag.hs
View file @
49419bc5
...
...
@@ -5,7 +5,6 @@ module Oracles.Flag (
import
Util
import
Oracles.Base
import
Development.Shake
data
Flag
=
LaxDeps
|
DynamicGhcPrograms
...
...
src/Oracles/PackageData.hs
View file @
49419bc5
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module
Oracles.PackageData
(
PackageData
(
..
),
PackageDataMulti
(
..
),
PackageDataKey
(
..
),
pkgData
,
pkgDataMulti
PackageData
(
..
),
PackageDataList
(
..
),
pkgData
,
pkgDataList
,
packageDataOracle
)
where
import
Util
import
Oracles.Base
import
Data.List
import
Data.Maybe
import
Development.Shake
import
Development.Shake.Classes
import
Development.Shake.FilePath
import
Control.Applicative
import
qualified
Data.HashMap.Strict
as
Map
-- 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 action that consults the file and
-- returns "1.2.3.4".
--
-- PackageData
Multi
is used for multiple string options separated by spaces,
-- PackageData
List
is used for multiple string options separated by spaces,
-- such as 'path_MODULES = Data.Array Data.Array.Base ...'.
-- pkgMultiData Modules therefore returns ["Data.Array", "Data.Array.Base", ...]
-- pkgListData Modules therefore returns ["Data.Array", "Data.Array.Base", ...]
data
PackageData
=
Version
FilePath
|
PackageKey
FilePath
|
Synopsis
FilePath
data
PackageData
Multi
=
Modules
FilePath
|
SrcDirs
FilePath
|
IncludeDirs
FilePath
|
Deps
FilePath
|
DepKeys
FilePath
|
DepNames
FilePath
|
CppArgs
FilePath
|
HsArgs
FilePath
|
CcArgs
FilePath
|
CSrcs
FilePath
|
DepIncludeDirs
FilePath
data
PackageData
List
=
Modules
FilePath
|
SrcDirs
FilePath
|
IncludeDirs
FilePath
|
Deps
FilePath
|
DepKeys
FilePath
|
DepNames
FilePath
|
CppArgs
FilePath
|
HsArgs
FilePath
|
CcArgs
FilePath
|
CSrcs
FilePath
|
DepIncludeDirs
FilePath
newtype
PackageDataKey
=
PackageDataKey
(
FilePath
,
String
)
deriving
(
Show
,
Typeable
,
Eq
,
Hashable
,
Binary
,
NFData
)
deriving
(
Show
,
Typeable
,
Eq
,
Hashable
,
Binary
,
NFData
)
askPackageData
::
FilePath
->
String
->
Action
String
askPackageData
path
key
=
do
...
...
@@ -61,8 +59,8 @@ pkgData packageData = do
return
$
fromMaybe
(
error
$
"No key '"
++
key
++
"' in "
++
unifyPath
pkgData
++
"."
)
res
pkgData
Multi
::
PackageData
Multi
->
Action
[
String
]
pkgData
Multi
packageData
=
do
pkgData
List
::
PackageData
List
->
Action
[
String
]
pkgData
List
packageData
=
do
let
(
key
,
path
,
defaultValue
)
=
case
packageData
of
Modules
path
->
(
"MODULES"
,
path
,
""
)
SrcDirs
path
->
(
"HS_SRC_DIRS"
,
path
,
"."
)
...
...
@@ -84,3 +82,14 @@ pkgDataMulti packageData = do
++
unifyPath
pkgData
++
"."
Just
""
->
defaultValue
Just
value
->
value
-- Oracle for 'package-data.mk' files
packageDataOracle
::
Rules
()
packageDataOracle
=
do
pkgData
<-
newCache
$
\
file
->
do
need
[
file
]
putOracle
$
"Reading "
++
file
++
"..."
liftIO
$
readConfigFile
file
addOracle
$
\
(
PackageDataKey
(
file
,
key
))
->
Map
.
lookup
key
<$>
pkgData
(
unifyPath
file
)
return
()
src/Oracles/Setting.hs
View file @
49419bc5
module
Oracles.Setting
(
Setting
(
..
),
Setting
Multi
(
..
),
setting
,
setting
Multi
,
Setting
(
..
),
Setting
List
(
..
),
setting
,
setting
List
,
windowsHost
)
where
import
Stage
import
Oracles.Base
import
Development.Shake
-- Each Setting comes from the system.config file, e.g. 'target-os = mingw32'.
-- setting TargetOs looks up the config file and returns "mingw32".
--
-- Setting
Multi
is used for multiple string values separated by spaces, such
-- Setting
List
is used for multiple string values separated by spaces, such
-- as 'src-hc-args = -H32m -O'.
-- setting
Multi
SrcHcArgs therefore returns a list of strings ["-H32", "-O"].
-- setting
List
SrcHcArgs therefore returns a list of strings ["-H32", "-O"].
data
Setting
=
TargetOs
|
TargetArch
|
TargetPlatformFull
...
...
@@ -22,18 +21,18 @@ data Setting = TargetOs
|
ProjectVersion
|
GhcSourcePath
data
Setting
Multi
=
SrcHcArgs
|
ConfCcArgs
Stage
|
ConfGccLinkerArgs
Stage
|
ConfLdLinkerArgs
Stage
|
ConfCppArgs
Stage
|
IconvIncludeDirs
|
IconvLibDirs
|
GmpIncludeDirs
|
GmpLibDirs
data
Setting
List
=
SrcHcArgs
|
ConfCcArgs
Stage
|
ConfGccLinkerArgs
Stage
|
ConfLdLinkerArgs
Stage
|
ConfCppArgs
Stage
|
IconvIncludeDirs
|
IconvLibDirs
|
GmpIncludeDirs
|
GmpLibDirs
setting
::
Setting
->
Action
String
setting
s
=
askConfig
$
case
s
of
setting
key
=
askConfig
$
case
key
of
TargetOs
->
"target-os"
TargetArch
->
"target-arch"
TargetPlatformFull
->
"target-platform-full"
...
...
@@ -42,19 +41,17 @@ setting s = askConfig $ case s of
ProjectVersion
->
"project-version"
GhcSourcePath
->
"ghc-source-path"
setting
Multi
::
Setting
Multi
->
Action
[
String
]
setting
Multi
s
=
fmap
words
$
askConfig
$
case
s
of
setting
List
::
Setting
List
->
Action
[
String
]
setting
List
key
=
fmap
words
$
askConfig
$
case
key
of
SrcHcArgs
->
"src-hc-args"
ConfCcArgs
stage
->
"conf-cc-args"
++
show
Stage
stage
ConfCppArgs
stage
->
"conf-cpp-args"
++
show
Stage
stage
ConfGccLinkerArgs
stage
->
"conf-gcc-linker-args"
++
show
Stage
stage
ConfLdLinkerArgs
stage
->
"conf-ld-linker-args"
++
show
Stage
stage
ConfCcArgs
stage
->
"conf-cc-args
-stage
"
++
show
stage
ConfCppArgs
stage
->
"conf-cpp-args
-stage
"
++
show
stage
ConfGccLinkerArgs
stage
->
"conf-gcc-linker-args
-stage
"
++
show
stage
ConfLdLinkerArgs
stage
->
"conf-ld-linker-args
-stage
"
++
show
stage
IconvIncludeDirs
->
"iconv-include-dirs"
IconvLibDirs
->
"iconv-lib-dirs"
GmpIncludeDirs
->
"gmp-include-dirs"
GmpLibDirs
->
"gmp-lib-dirs"
where
showStage
=
(
"-stage"
++
)
.
show
windowsHost
::
Action
Bool
windowsHost
=
do
...
...
src/Rules.hs
View file @
49419bc5
module
Rules
(
generateTargets
,
packageRules
,
oracleRules
,
module
Rules
.
Package
,
module
Rules
.
Config
,
)
where
import
Stage
import
Expression
import
Rules.Config
import
Rules.Package
import
Rules.Oracles
import
Settings.Packages
...
...
src/Config.hs
→
src/
Rules/
Config.hs
View file @
49419bc5
module
Config
(
autoconfRules
,
configureRules
,
cfgPath
module
Rules.
Config
(
autoconfRules
,
configureRules
)
where
import
Util
import
Development.Shake
import
Development.Shake.FilePath
cfgPath
::
FilePath
cfgPath
=
"shake"
</>
"cfg"
import
Oracles.Base
autoconfRules
::
Rules
()
autoconfRules
=
do
"configure"
%>
\
out
->
do
copyFile'
(
c
f
gPath
</>
"configure.ac"
)
"configure.ac"
copyFile'
(
c
onfi
gPath
</>
"configure.ac"
)
"configure.ac"
putColoured
White
$
"Running autoconf..."
cmd
"bash autoconf"
-- TODO: get rid of 'bash'
configureRules
::
Rules
()
configureRules
=
do
c
f
gPath
</>
"system.config"
%>
\
out
->
do
need
[
c
f
gPath
</>
"system.config.in"
,
"configure"
]
c
onfi
gPath
</>
"system.config"
%>
\
out
->
do
need
[
c
onfi
gPath
</>
"system.config.in"
,
"configure"
]
putColoured
White
"Running configure..."
cmd
"bash configure"
-- TODO: get rid of 'bash'
src/Rules/Oracles.hs
View file @
49419bc5
...
...
@@ -2,11 +2,12 @@ module Rules.Oracles (
oracleRules
)
where
import
Oracles
import
Oracles
.Base
import
Oracles.ArgsHash
import
Oracles.PackageData
import
Oracles.DependencyList
import
Data.Monoid
import
Development.Shake
oracleRules
::
Rules
()
oracleRules
=
configOracle
<>
packageDataOracle
<>
dependencyOracle
<>
argsHashOracle
configOracle
<>
packageDataOracle
<>
dependency
List
Oracle
<>
argsHashOracle
src/Settings/GhcCabal.hs
View file @
49419bc5
...
...
@@ -17,8 +17,6 @@ import Settings.Packages
import
Settings.TargetDirectory
import
Data.List
import
Control.Applicative
import
Development.Shake
import
Development.Shake.FilePath
cabalArgs
::
Args
cabalArgs
=
builder
GhcCabal
?
do
...
...
src/Settings/Util.hs
View file @
49419bc5
...
...
@@ -16,7 +16,6 @@ import Stage
import
Builder
import
Oracles.Base
import
Expression
import
Development.Shake
-- A single argument.
arg
::
String
->
Args
...
...
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