Squashed 'hadrian/' content from commit 438dc57
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 6 Nov 2017 22:59:37 +0000 (22:59 +0000)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 6 Nov 2017 22:59:37 +0000 (22:59 +0000)
git-subtree-dir: hadrian
git-subtree-split: 438dc576e7b84c473a09d1d7ec7798a30303bc4e

112 files changed:
.ghci [new file with mode: 0644]
.gitignore [new file with mode: 0644]
.travis.yml [new file with mode: 0644]
LICENSE [new file with mode: 0644]
README.md [new file with mode: 0644]
appveyor.yml [new file with mode: 0644]
build.bat [new file with mode: 0644]
build.cabal.sh [new file with mode: 0644]
build.global-db.bat [new file with mode: 0644]
build.global-db.sh [new file with mode: 0755]
build.sh [new file with mode: 0755]
build.stack.bat [new file with mode: 0644]
build.stack.nix.sh [new file with mode: 0755]
build.stack.sh [new file with mode: 0755]
cabal.project [new file with mode: 0644]
cfg/system.config.in [new file with mode: 0644]
circle.yml [new file with mode: 0644]
doc/cross-compile.md [new file with mode: 0644]
doc/flavours.md [new file with mode: 0644]
doc/user-settings.md [new file with mode: 0644]
doc/windows.md [new file with mode: 0644]
hadrian.cabal [new file with mode: 0644]
src/Base.hs [new file with mode: 0644]
src/Builder.hs [new file with mode: 0644]
src/CommandLine.hs [new file with mode: 0644]
src/Context.hs [new file with mode: 0644]
src/Environment.hs [new file with mode: 0644]
src/Expression.hs [new file with mode: 0644]
src/Flavour.hs [new file with mode: 0644]
src/GHC.hs [new file with mode: 0644]
src/Hadrian/Builder.hs [new file with mode: 0644]
src/Hadrian/Builder/Ar.hs [new file with mode: 0644]
src/Hadrian/Builder/Sphinx.hs [new file with mode: 0644]
src/Hadrian/Builder/Tar.hs [new file with mode: 0644]
src/Hadrian/Expression.hs [new file with mode: 0644]
src/Hadrian/Haskell/Cabal.hs [new file with mode: 0644]
src/Hadrian/Haskell/Cabal/Parse.hs [new file with mode: 0644]
src/Hadrian/Oracles/ArgsHash.hs [new file with mode: 0644]
src/Hadrian/Oracles/DirectoryContents.hs [new file with mode: 0644]
src/Hadrian/Oracles/Path.hs [new file with mode: 0644]
src/Hadrian/Oracles/TextFile.hs [new file with mode: 0644]
src/Hadrian/Package.hs [new file with mode: 0644]
src/Hadrian/Target.hs [new file with mode: 0644]
src/Hadrian/Utilities.hs [new file with mode: 0644]
src/Main.hs [new file with mode: 0644]
src/Oracles/Flag.hs [new file with mode: 0644]
src/Oracles/ModuleFiles.hs [new file with mode: 0644]
src/Oracles/PackageData.hs [new file with mode: 0644]
src/Oracles/Setting.hs [new file with mode: 0644]
src/Rules.hs [new file with mode: 0644]
src/Rules/Clean.hs [new file with mode: 0644]
src/Rules/Compile.hs [new file with mode: 0644]
src/Rules/Configure.hs [new file with mode: 0644]
src/Rules/Dependencies.hs [new file with mode: 0644]
src/Rules/Documentation.hs [new file with mode: 0644]
src/Rules/Generate.hs [new file with mode: 0644]
src/Rules/Gmp.hs [new file with mode: 0644]
src/Rules/Install.hs [new file with mode: 0644]
src/Rules/Libffi.hs [new file with mode: 0644]
src/Rules/Library.hs [new file with mode: 0644]
src/Rules/PackageData.hs [new file with mode: 0644]
src/Rules/Program.hs [new file with mode: 0644]
src/Rules/Register.hs [new file with mode: 0644]
src/Rules/Selftest.hs [new file with mode: 0644]
src/Rules/SourceDist.hs [new file with mode: 0644]
src/Rules/Test.hs [new file with mode: 0644]
src/Rules/Wrappers.hs [new file with mode: 0644]
src/Settings.hs [new file with mode: 0644]
src/Settings/Builders/Alex.hs [new file with mode: 0644]
src/Settings/Builders/Cc.hs [new file with mode: 0644]
src/Settings/Builders/Common.hs [new file with mode: 0644]
src/Settings/Builders/Configure.hs [new file with mode: 0644]
src/Settings/Builders/DeriveConstants.hs [new file with mode: 0644]
src/Settings/Builders/GenPrimopCode.hs [new file with mode: 0644]
src/Settings/Builders/Ghc.hs [new file with mode: 0644]
src/Settings/Builders/GhcCabal.hs [new file with mode: 0644]
src/Settings/Builders/GhcPkg.hs [new file with mode: 0644]
src/Settings/Builders/Haddock.hs [new file with mode: 0644]
src/Settings/Builders/Happy.hs [new file with mode: 0644]
src/Settings/Builders/HsCpp.hs [new file with mode: 0644]
src/Settings/Builders/Hsc2Hs.hs [new file with mode: 0644]
src/Settings/Builders/Ld.hs [new file with mode: 0644]
src/Settings/Builders/Make.hs [new file with mode: 0644]
src/Settings/Builders/Xelatex.hs [new file with mode: 0644]
src/Settings/Default.hs [new file with mode: 0644]
src/Settings/Default.hs-boot [new file with mode: 0644]
src/Settings/Flavours/Development.hs [new file with mode: 0644]
src/Settings/Flavours/Performance.hs [new file with mode: 0644]
src/Settings/Flavours/Profiled.hs [new file with mode: 0644]
src/Settings/Flavours/Quick.hs [new file with mode: 0644]
src/Settings/Flavours/QuickCross.hs [new file with mode: 0644]
src/Settings/Flavours/Quickest.hs [new file with mode: 0644]
src/Settings/Packages/Base.hs [new file with mode: 0644]
src/Settings/Packages/Cabal.hs [new file with mode: 0644]
src/Settings/Packages/Compiler.hs [new file with mode: 0644]
src/Settings/Packages/Ghc.hs [new file with mode: 0644]
src/Settings/Packages/GhcCabal.hs [new file with mode: 0644]
src/Settings/Packages/GhcPkg.hs [new file with mode: 0644]
src/Settings/Packages/GhcPrim.hs [new file with mode: 0644]
src/Settings/Packages/Ghci.hs [new file with mode: 0644]
src/Settings/Packages/Haddock.hs [new file with mode: 0644]
src/Settings/Packages/Haskeline.hs [new file with mode: 0644]
src/Settings/Packages/IntegerGmp.hs [new file with mode: 0644]
src/Settings/Packages/Rts.hs [new file with mode: 0644]
src/Settings/Packages/RunGhc.hs [new file with mode: 0644]
src/Settings/Warnings.hs [new file with mode: 0644]
src/Stage.hs [new file with mode: 0644]
src/Target.hs [new file with mode: 0644]
src/UserSettings.hs [new file with mode: 0644]
src/Utilities.hs [new file with mode: 0644]
src/Way.hs [new file with mode: 0644]
stack.yaml [new file with mode: 0644]

diff --git a/.ghci b/.ghci
new file mode 100644 (file)
index 0000000..8bb287b
--- /dev/null
+++ b/.ghci
@@ -0,0 +1,11 @@
+:set -Wall -fno-warn-name-shadowing -isrc -i../libraries/Cabal/Cabal
+:set -XDeriveFunctor
+:set -XDeriveGeneric 
+:set -XFlexibleInstances
+:set -XGeneralizedNewtypeDeriving
+:set -XLambdaCase
+:set -XRecordWildCards
+:set -XScopedTypeVariables
+:set -XTupleSections
+
+:load Main
diff --git a/.gitignore b/.gitignore
new file mode 100644 (file)
index 0000000..697afc9
--- /dev/null
@@ -0,0 +1,26 @@
+# generated by the configure script
+cfg/system.config
+
+# build.bat and build.sh specific
+/bin/
+
+# build.cabal.sh specific
+/dist/
+/.cabal-sandbox/
+cabal.sandbox.config
+
+# build.cabal-new.sh specific
+/dist-newstyle/
+.ghc.environment.*
+
+# build.stack.sh and build.stack.bat specific
+/.stack-work/
+
+# the user settings
+/UserSettings.hs
+
+# Mostly temp file by emacs
+*~
+
+# ghcid output
+/ghcid.txt
\ No newline at end of file
diff --git a/.travis.yml b/.travis.yml
new file mode 100644 (file)
index 0000000..e2455b2
--- /dev/null
@@ -0,0 +1,90 @@
+sudo: true
+matrix:
+    include:
+        - os: linux
+          env: MODE="--flavour=quickest inplace/bin/ghc-stage1"
+          compiler: "GHC 8.0.2"
+          addons:
+              apt:
+                  packages:
+                      - ghc-8.0.2
+                      - cabal-install-2.0
+                      - zlib1g-dev
+                  sources: hvr-ghc
+
+          before_install:
+              - PATH="/opt/ghc/8.0.2/bin:$PATH"
+              - PATH="/opt/cabal/2.0/bin:$PATH"
+
+          script:
+              # Run internal Hadrian tests
+              - ./build.sh selftest
+
+              # Build GHC
+              - ./build.sh -j $MODE --no-progress --progress-colour=never --profile=-
+
+        - os: linux
+          env: MODE="--flavour=quickest --integer-simple"
+          compiler: "GHC 8.2.1"
+          addons:
+              apt:
+                  packages:
+                      - ghc-8.2.1
+                      - cabal-install-1.22
+                      - zlib1g-dev
+                  sources: hvr-ghc
+
+          before_install:
+              - PATH="/opt/ghc/8.2.1/bin:$PATH"
+              - PATH="/opt/cabal/1.22/bin:$PATH"
+
+          script:
+              # Build GHC
+              - ./build.sh -j $MODE --no-progress --progress-colour=never --profile=-
+
+              # Test GHC binary
+              - cd ..
+              - inplace/bin/ghc-stage2 -e 1+2
+
+        - os: osx
+          osx_image: xcode8
+          env: MODE="--flavour=quickest --integer-simple inplace/bin/ghc-stage1"
+          before_install:
+              - brew update
+              - brew install ghc cabal-install python3
+
+          script:
+              # Due to timeout limit of OS X build on Travis CI,
+              # we will ignore selftest and build only stage1
+              - ./build.sh -j $MODE --no-progress --progress-colour=never --profile=-
+
+install:
+    # Add Cabal to PATH
+    - PATH="$HOME/.cabal/bin:$PATH"
+    - export PATH
+    - env
+
+    # Fetch GHC sources into ./ghc
+    - git --version
+    - git config --global url."git://github.com/ghc/packages-".insteadOf git://github.com/ghc/packages/
+    - git clone --depth 1 --recursive git://github.com/ghc/ghc
+    # --shallow-submodules is not supported on travis standard git 1.8 (linux), but it is supported
+    # on Travis Mac OS X machines. But it does not work with github mirrors because it cannot
+    # find commits.
+
+    # Install all Hadrian and GHC build dependencies
+    - cabal update
+    - cabal install alex happy
+
+    # Travis has already cloned Hadrian into ./ and we need to move it
+    # to ./ghc/hadrian -- one way to do it is to move the .git directory
+    # and perform a hard reset in order to regenerate Hadrian files
+    - mkdir ghc/hadrian
+    - mv .git ghc/hadrian
+    - cd ghc/hadrian
+    - git reset --hard HEAD
+
+cache:
+    directories:
+        - $HOME/.cabal
+        - $HOME/.ghc
diff --git a/LICENSE b/LICENSE
new file mode 100644 (file)
index 0000000..ff60fa8
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2014-2017 Andrey Mokhov
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
diff --git a/README.md b/README.md
new file mode 100644 (file)
index 0000000..eb3dd86
--- /dev/null
+++ b/README.md
@@ -0,0 +1,194 @@
+Hadrian
+=======
+
+[![Linux & OS X status](https://img.shields.io/travis/snowleopard/hadrian/master.svg?label=Linux%20%26%20OS%20X)](https://travis-ci.org/snowleopard/hadrian) [![Windows status](https://img.shields.io/appveyor/ci/snowleopard/hadrian/master.svg?label=Windows)](https://ci.appveyor.com/project/snowleopard/hadrian) [![OS X status](https://img.shields.io/circleci/project/github/snowleopard/hadrian.svg?label=OS%20X)](https://circleci.com/gh/snowleopard/hadrian)
+
+Hadrian is a new build system for the [Glasgow Haskell Compiler][ghc]. It is based
+on [Shake][shake] and we hope that it will soon replace the current
+[Make-based build system][make]. If you are curious about the rationale behind the
+project and the architecture of the build system you can find more details in
+this [Haskell Symposium 2016 paper][paper] and this [Haskell eXchange 2016 talk][talk].
+
+The new build system can work side-by-side with the existing build system. Note, there is
+some interaction between them: they put (some) build results in the same directories,
+e.g. the resulting GHC is `inplace/bin/ghc-stage2`.
+
+Your first build
+----------------
+
+Beware, the build system is in the alpha development phase. Things are shaky and sometimes
+break; there are numerous [known issues][issues]. Not afraid? Then put on the helmet and
+run the following command from root of the GHC tree:
+
+```
+hadrian/build.sh -j
+```
+
+or on Windows:
+
+```
+hadrian/build.bat -j
+```
+
+Here flag `-j` enables parallelism and is optional. We will further refer to the build script
+simply as `build`. Note that Hadrian runs the `boot` and `configure` scripts automatically when
+needed. Use `--skip-configure` to suppress this behaviour (see the overview of command line
+flags below).
+
+Notes:
+
+* If the default build script doesn't work, you might want to give a try to another one, e.g. based
+on Cabal sandboxes (`build.cabal.*`), Stack (`build.stack.*`) or the global package database
+(`build.global-db.*`). Also see [instructions for building GHC on Windows using Stack][windows-build].
+
+* Hadrian is written in Haskell and depends on the following packages:
+`ansi-terminal extra mtl quickcheck shake`.
+
+* If you have never built GHC before, start with the [preparation guide][ghc-preparation].
+
+Using the build system
+----------------------
+Once your first build is successful, simply run `build` to rebuild. Build results
+are placed into `_build` and `inplace` directories.
+
+#### Command line flags
+
+In addition to standard Shake flags (try `--help`), the build system
+currently supports several others:
+* `--flavour=FLAVOUR`: choose a build flavour. The following settings are currently supported:
+`default`, `quick`, `quickest`, `perf`, `prof`, `devel1` and `devel2`. As an example, the
+`quickest` flavour adds `-O0` flag to all GHC invocations and builds libraries only in the
+`vanilla` way, which speeds up builds by 3-4x. Build flavours are documented
+[here](https://github.com/snowleopard/hadrian/blob/master/doc/flavours.md).
+
+* `--freeze1`: freeze Stage1 GHC, i.e. do not rebuild it even if some of its source files
+are out-of-date. This allows to significantly reduce the rebuild time when you are working
+on a feature that affects both Stage1 and Stage2 compilers, but may lead to incorrect
+build results. To unfreeze Stage1 GHC simply drop the `--freeze1` flag and Hadrian will
+rebuild all out-of-date files.
+
+* `--integer-simple`: build GHC using the `integer-simple` integer library (instead
+of `integer-gmp`).
+
+* `--progress-colour=MODE`: choose whether to use colours when printing build progress
+info. There are three settings: `never` (do not use colours), `auto` (attempt to detect
+whether the console supports colours; this is the default setting), and `always` (use
+colours).
+
+* `--progress-info=STYLE`: choose how build progress info is printed. There are four
+settings: `none`, `brief` (one line per build command; this is the default setting),
+`normal` (typically a box per build command), and `unicorn` (when `normal` just won't do).
+
+* `--skip-configure`: use this flag to suppress the default behaviour of Hadrian that
+runs the `boot` and `configure` scripts automatically when needed, so that you don't have
+to remember to run them manually. With `--skip-configure` you will need to manually run:
+    ```bash
+    ./boot
+    ./configure # On Windows run ./configure --enable-tarballs-autodownload
+    ```
+    as you normally do when using `make`. Beware, by default Hadrian may do network I/O on
+Windows to download necessary tarballs, which may sometimes be undesirable; `--skip-configure`
+is your friend in such cases.
+
+* `--split-objects`: generate split objects, which are switched off by default. Due to
+a GHC [bug][ghc-split-objs-bug], you need a full clean rebuild when using this flag.
+
+* `--verbose`: run Hadrian in verbose mode. In particular this prints diagnostic messages
+by Shake oracles.
+
+#### User settings
+
+The Make-based build system uses `mk/build.mk` to specify user build settings. We
+use `hadrian/UserSettings.hs` for the same purpose, see [documentation](doc/user-settings.md).
+
+#### Clean and full rebuild
+
+* `build clean` removes all build artefacts.
+
+* `build -B` forces Shake to rerun all rules, even if the previous build results are
+are still up-to-date.
+
+#### Documentation
+
+To build GHC documentation, run `build docs`. Note that finer-grain documentation
+targets (e.g. building only HTML documentation or only the GHC User's Guide)
+are currently not supported.
+
+#### Source distribution
+
+To build a GHC source distribution tarball, run `build sdist-ghc`.
+
+#### Installation
+
+To build and install GHC artifacts, run `build install`.
+
+By default, GHC will be installed to the specified _prefix_ path on your system,
+relative to the root of the file system. For example on UNIX, GHC will be installed
+to `/usr/local/bin`. By setting the command line flag `--install-destdir=[DESTDIR]`,
+you can install GHC to path `DESTDIR/<prefix>` instead. Make sure you use correct
+absolute path as `DESTDIR` on Windows, e.g. `C:/path`, which installs GHC
+into `C:/path/usr/local`.
+
+#### Testing
+
+* `build validate` runs GHC tests by simply executing `make fast` in `testsuite/tests`
+directory. This can be used instead of `sh validate --fast --no-clean` in the existing
+build system. Note: this will rebuild Stage2 GHC, `ghc-pkg` and `hpc` if they are out of date.
+
+* `build test` runs GHC tests by calling the `testsuite/driver/runtests.py` python
+script with appropriate flags. The current implementation is limited and cannot
+replace the `validate` script (see [#187][validation-issue]).
+
+* `build selftest` runs tests of the build system. Current test coverage is close to
+zero (see [#197][test-issue]).
+
+Current limitations
+-------------------
+The new build system still lacks many important features:
+* Validation is not implemented: [#187][validation-issue].
+* Dynamic linking on Windows is not supported [#343][dynamic-windows-issue].
+* There is no support for binary distribution: [#219][bin-dist-issue].
+
+Check out [milestones] to see when we hope to resolve the above limitations.
+
+How to contribute
+-----------------
+
+The best way to contribute is to try the new build system, report the issues
+you found, and attempt to fix them. Please note: the codebase is very unstable
+at present and we expect a lot of further refactoring. If you would like to
+work on a particular issue, please let everyone know by adding a comment about
+this. The issues that are currently on the critical path and therefore require
+particular attention are listed in [#239](https://github.com/snowleopard/hadrian/issues/239).
+Also have a look at [projects](https://github.com/snowleopard/hadrian/projects)
+where open issues and pull requests are grouped into categories.
+
+Acknowledgements
+----------------
+
+I started this project as part of my 6-month research visit to Microsoft
+Research Cambridge, which was funded by Newcastle University, EPSRC, and
+Microsoft Research. I would like to thank Simon Peyton Jones, Neil Mitchell
+and Simon Marlow for kick-starting the project and for their guidance.
+Zhen Zhang has done fantastic work on Hadrian as part of his Summer of
+Haskell 2017 [project](https://summer.haskell.org/ideas.html#hadrian-ghc),
+solving a few heavy and long-overdue issues. Last but not least, big thanks
+to all other project [contributors][contributors], who helped me endure and
+enjoy the project.
+
+[ghc]: https://en.wikipedia.org/wiki/Glasgow_Haskell_Compiler
+[shake]: https://github.com/ndmitchell/shake
+[make]: https://ghc.haskell.org/trac/ghc/wiki/Building/Architecture
+[paper]: https://www.staff.ncl.ac.uk/andrey.mokhov/Hadrian.pdf
+[talk]: https://skillsmatter.com/skillscasts/8722-meet-hadrian-a-new-build-system-for-ghc
+[issues]: https://github.com/snowleopard/hadrian/issues
+[ghc-preparation]: https://ghc.haskell.org/trac/ghc/wiki/Building/Preparation
+[ghc-windows-quick-build]: https://ghc.haskell.org/trac/ghc/wiki/Building/Preparation/Windows#AQuickBuild
+[windows-build]: https://github.com/snowleopard/hadrian/blob/master/doc/windows.md
+[ghc-split-objs-bug]: https://ghc.haskell.org/trac/ghc/ticket/11315
+[test-issue]: https://github.com/snowleopard/hadrian/issues/197
+[validation-issue]: https://github.com/snowleopard/hadrian/issues/187
+[dynamic-windows-issue]: https://github.com/snowleopard/hadrian/issues/343
+[bin-dist-issue]: https://github.com/snowleopard/hadrian/issues/219
+[milestones]: https://github.com/snowleopard/hadrian/milestones
+[contributors]: https://github.com/snowleopard/hadrian/graphs/contributors
diff --git a/appveyor.yml b/appveyor.yml
new file mode 100644 (file)
index 0000000..fbedf8f
--- /dev/null
@@ -0,0 +1,39 @@
+clone_folder: "c:\\ghc\\hadrian"
+environment:
+  global:
+    STACK_ROOT: "c:\\sr"
+
+cache:
+    - "c:\\sr -> appveyor.yml"
+
+install:
+    # Get Stack
+    - curl -ostack.zip -LsS --insecure https://www.stackage.org/stack/windows-x86_64
+    - 7z x stack.zip stack.exe
+
+    # Fetch GHC sources into c:\ghc
+    # Note: AppVeyor has already cloned Hadrian into c:\ghc\hadrian, so it's tricky
+    - cd ..
+    - git init
+    - git remote add origin git://git.haskell.org/ghc.git
+    - git pull --recurse-submodules origin master
+    - git submodule update --init --recursive --quiet
+
+    # Install all Hadrian and GHC build dependencies
+    - cd hadrian
+    - stack setup > nul
+    - appveyor-retry stack exec -- pacman -S autoconf automake-wrapper make patch python tar --noconfirm
+
+build_script:
+    # Build Hadrian
+    - stack build alex happy # Otherwise 'build' fails on AppVeyor
+
+    # Run internal Hadrian tests
+    - build selftest
+
+    # Build GHC
+    - build -j --flavour=quickest --no-progress --progress-colour=never --profile=-
+
+    # Test GHC binary
+    - cd ..
+    - inplace\bin\ghc-stage2 -e 1+2
diff --git a/build.bat b/build.bat
new file mode 100644 (file)
index 0000000..01a869f
--- /dev/null
+++ b/build.bat
@@ -0,0 +1,6 @@
+@echo off
+setlocal
+cd %~dp0
+
+rem By default on Windows we build Hadrian using Stack
+./build.stack.bat %*
diff --git a/build.cabal.sh b/build.cabal.sh
new file mode 100644 (file)
index 0000000..d2bdb85
--- /dev/null
@@ -0,0 +1,74 @@
+#!/usr/bin/env bash
+
+CABAL=cabal
+
+set -euo pipefail
+
+# readlink on os x, doesn't support -f, to prevent the
+# need of installing coreutils (e.g. through brew, just
+# for readlink, we use the follownig substitute.
+#
+# source: http://stackoverflow.com/a/1116890
+function rl {
+    TARGET_FILE="$1"
+
+    cd "$(dirname "$TARGET_FILE")"
+    TARGET_FILE="$(basename "$TARGET_FILE")"
+
+    # Iterate down a (possible) chain of symlinks
+    while [ -L "$TARGET_FILE" ]
+    do
+        TARGET_FILE="$(readlink "$TARGET_FILE")"
+        cd "$(dirname "$TARGET_FILE")"
+        TARGET_FILE="$(basename "$TARGET_FILE")"
+    done
+
+    # Compute the canonicalized name by finding the physical path
+    # for the directory we're in and appending the target file.
+    PHYS_DIR="$(pwd -P)"
+    RESULT="$PHYS_DIR/$TARGET_FILE"
+    echo "$RESULT"
+}
+
+absoluteRoot="$(dirname "$(rl "$0")")"
+cd "$absoluteRoot"
+
+if ! type "$CABAL" > /dev/null; then
+    echo "Please make sure 'cabal' is in your PATH"
+    exit 2
+fi
+
+CABVERSTR=$("$CABAL" --numeric-version)
+
+CABVER=( ${CABVERSTR//./ } )
+
+if [ "${CABVER[0]}" -gt 2 -o "${CABVER[0]}" -eq 2 -a "${CABVER[1]}" -ge 1 ]; then
+    # New enough Cabal version detected, so let's use the superior new-build + new-run
+    # modes. Note that pre-2.1 Cabal does not support passing additional parameters
+    # to the executable (hadrian) after the separator '--', see #438.
+
+    "$CABAL" new-build --disable-profiling --disable-documentation -j exe:hadrian
+    "$CABAL" new-run hadrian --        \
+        --lint                         \
+        --directory "$absoluteRoot/.." \
+        "$@"
+
+else
+    # The logic below is quite fragile, but it's better than nothing for pre-2.1 Cabal.
+    echo "Old pre cabal 2.1 version detected. Falling back to legacy 'cabal sandbox' mode."
+
+    # Initialize sandbox if necessary
+    if ! ( "$CABAL" sandbox hc-pkg list > /dev/null 2>&1); then
+        "$CABAL" sandbox init
+        "$CABAL" sandbox add-source ../libraries/Cabal/Cabal
+        "$CABAL" install                \
+            --dependencies-only         \
+            --disable-library-profiling \
+            --disable-shared
+    fi
+
+    "$CABAL" run hadrian --            \
+        --lint                         \
+        --directory "$absoluteRoot/.." \
+        "$@"
+fi
diff --git a/build.global-db.bat b/build.global-db.bat
new file mode 100644 (file)
index 0000000..0d6a696
--- /dev/null
@@ -0,0 +1,32 @@
+@echo off
+setlocal
+cd %~dp0
+mkdir bin 2> nul
+
+set ghcArgs=--make                     ^
+            -Wall                      ^
+            -fno-warn-name-shadowing   ^
+            -XRecordWildCards          ^
+            src\Main.hs                ^
+            -threaded                  ^
+            -isrc                      ^
+            -i..\libraries\Cabal\Cabal ^
+            -rtsopts                   ^
+            -with-rtsopts=-I0          ^
+            -outputdir=bin             ^
+            -j                         ^
+            -O                         ^
+            -o bin\hadrian
+
+set hadrianArgs=--lint      ^
+                --directory ^
+                ".."        ^
+                %*
+
+ghc %ghcArgs%
+
+if %ERRORLEVEL% NEQ 0 EXIT /B %ERRORLEVEL%
+
+rem Unset GHC_PACKAGE_PATH variable, as otherwise ghc-cabal complains
+set GHC_PACKAGE_PATH=
+bin\hadrian %hadrianArgs%
diff --git a/build.global-db.sh b/build.global-db.sh
new file mode 100755 (executable)
index 0000000..5f1579b
--- /dev/null
@@ -0,0 +1,52 @@
+#!/usr/bin/env bash
+
+set -euo pipefail
+
+# readlink on os x, doesn't support -f, to prevent the
+# need of installing coreutils (e.g. through brew, just
+# for readlink, we use the follownig substitute.
+#
+# source: http://stackoverflow.com/a/1116890
+function rl {
+    TARGET_FILE="$1"
+
+    cd "$(dirname "$TARGET_FILE")"
+    TARGET_FILE="$(basename "$TARGET_FILE")"
+
+    # Iterate down a (possible) chain of symlinks
+    while [ -L "$TARGET_FILE" ]
+    do
+        TARGET_FILE="$(readlink "$TARGET_FILE")"
+        cd "$(dirname "$TARGET_FILE")"
+        TARGET_FILE="$(basename "$TARGET_FILE")"
+    done
+
+    # Compute the canonicalized name by finding the physical path
+    # for the directory we're in and appending the target file.
+    PHYS_DIR="$(pwd -P)"
+    RESULT="$PHYS_DIR/$TARGET_FILE"
+    echo "$RESULT"
+}
+
+root="$(dirname "$(rl "$0")")"
+
+mkdir -p "$root/bin"
+
+ghc                                      \
+    "$root/src/Main.hs"                  \
+    -Wall                                \
+    -fno-warn-name-shadowing             \
+    -XRecordWildCards                    \
+    -i"$root/src"                        \
+    -i"$root/../libraries/Cabal/Cabal"   \
+    -rtsopts                             \
+    -with-rtsopts=-I0                    \
+    -threaded                            \
+    -outputdir="$root/bin" \
+    -j -O                                \
+    -o "$root/bin/hadrian"
+
+"$root/bin/hadrian"        \
+    --lint                 \
+    --directory "$root/.." \
+    "$@"
\ No newline at end of file
diff --git a/build.sh b/build.sh
new file mode 100755 (executable)
index 0000000..ad502b3
--- /dev/null
+++ b/build.sh
@@ -0,0 +1,35 @@
+#!/usr/bin/env bash
+
+set -euo pipefail
+
+# readlink on os x, doesn't support -f, to prevent the
+# need of installing coreutils (e.g. through brew, just
+# for readlink, we use the follownig substitute.
+#
+# source: http://stackoverflow.com/a/1116890
+function rl {
+    TARGET_FILE="$1"
+
+    cd "$(dirname "$TARGET_FILE")"
+    TARGET_FILE="$(basename "$TARGET_FILE")"
+
+    # Iterate down a (possible) chain of symlinks
+    while [ -L "$TARGET_FILE" ]
+    do
+        TARGET_FILE="$(readlink "$TARGET_FILE")"
+        cd "$(dirname "$TARGET_FILE")"
+        TARGET_FILE="$(basename "$TARGET_FILE")"
+    done
+
+    # Compute the canonicalized name by finding the physical path
+    # for the directory we're in and appending the target file.
+    PHYS_DIR="$(pwd -P)"
+    RESULT="$PHYS_DIR/$TARGET_FILE"
+    echo "$RESULT"
+}
+
+root="$(dirname "$(rl "$0")")"
+
+# By default on Linux/MacOS we build Hadrian using Cabal
+chmod a+x "$root/build.cabal.sh"
+(. "$root/build.cabal.sh" "$@")
diff --git a/build.stack.bat b/build.stack.bat
new file mode 100644 (file)
index 0000000..674375a
--- /dev/null
@@ -0,0 +1,11 @@
+@echo off
+setlocal
+rem Change the current directory to the one containing this script
+cd %~dp0
+
+rem Build Hadrian and dependencies and exit the script if the build failed
+stack build
+if %errorlevel% neq 0 exit /B %errorlevel%
+
+rem Run Hadrian in GHC top directory forwarding additional user arguments
+stack exec hadrian -- --lint --directory ".." %*
diff --git a/build.stack.nix.sh b/build.stack.nix.sh
new file mode 100755 (executable)
index 0000000..59ac061
--- /dev/null
@@ -0,0 +1,33 @@
+#!/usr/bin/env bash
+
+set -euo pipefail
+
+# readlink on os x, doesn't support -f, to prevent the
+# need of installing coreutils (e.g. through brew, just
+# for readlink, we use the follownig substitute.
+#
+# source: http://stackoverflow.com/a/1116890
+function rl {
+    TARGET_FILE="$1"
+
+    cd "$(dirname "$TARGET_FILE")"
+    TARGET_FILE="$(basename "$TARGET_FILE")"
+
+    # Iterate down a (possible) chain of symlinks
+    while [ -L "$TARGET_FILE" ]
+    do
+        TARGET_FILE="$(readlink "$TARGET_FILE")"
+        cd "$(dirname "$TARGET_FILE")"
+        TARGET_FILE="$(basename "$TARGET_FILE")"
+    done
+
+    # Compute the canonicalized name by finding the physical path
+    # for the directory we're in and appending the target file.
+    PHYS_DIR="$(pwd -P)"
+    RESULT="$PHYS_DIR/$TARGET_FILE"
+    echo "$RESULT"
+}
+
+absoluteRoot="$(dirname "$(rl "$0")")"
+
+HADRIAN_NIX=YES ${absoluteRoot}/build.stack.sh
diff --git a/build.stack.sh b/build.stack.sh
new file mode 100755 (executable)
index 0000000..2b1ff1d
--- /dev/null
@@ -0,0 +1,39 @@
+#!/usr/bin/env bash
+
+set -euo pipefail
+
+# readlink on os x, doesn't support -f, to prevent the
+# need of installing coreutils (e.g. through brew, just
+# for readlink, we use the follownig substitute.
+#
+# source: http://stackoverflow.com/a/1116890
+function rl {
+    TARGET_FILE="$1"
+
+    cd "$(dirname "$TARGET_FILE")"
+    TARGET_FILE="$(basename "$TARGET_FILE")"
+
+    # Iterate down a (possible) chain of symlinks
+    while [ -L "$TARGET_FILE" ]
+    do
+        TARGET_FILE="$(readlink "$TARGET_FILE")"
+        cd "$(dirname "$TARGET_FILE")"
+        TARGET_FILE="$(basename "$TARGET_FILE")"
+    done
+
+    # Compute the canonicalized name by finding the physical path
+    # for the directory we're in and appending the target file.
+    PHYS_DIR="$(pwd -P)"
+    RESULT="$PHYS_DIR/$TARGET_FILE"
+    echo "$RESULT"
+}
+
+absoluteRoot="$(dirname "$(rl "$0")")"
+cd "$absoluteRoot"
+
+stack build --no-library-profiling ${HADRIAN_NIX:+--nix}
+
+stack exec hadrian --              \
+    --lint                         \
+    --directory "$absoluteRoot/.." \
+    "$@"
diff --git a/cabal.project b/cabal.project
new file mode 100644 (file)
index 0000000..1ef81ca
--- /dev/null
@@ -0,0 +1,2 @@
+packages: ../libraries/Cabal/Cabal/
+          ./
diff --git a/cfg/system.config.in b/cfg/system.config.in
new file mode 100644 (file)
index 0000000..913a2b4
--- /dev/null
@@ -0,0 +1,141 @@
+# This file is processed by the configure script.
+# See hadrian/src/UserSettings.hs for user-defined settings.
+#===========================================================
+
+# Paths to builders:
+#===================
+
+alex           = @AlexCmd@
+ar             = @ArCmd@
+cc             = @CC@
+happy          = @HappyCmd@
+hs-cpp         = @HaskellCPPCmd@
+ld             = @LdCmd@
+make           = @MakeCmd@
+nm             = @NmCmd@
+objdump        = @ObjdumpCmd@
+ranlib         = @REAL_RANLIB_CMD@
+sphinx-build   = @SPHINXBUILD@
+system-ar      = @AR_STAGE0@
+system-cc      = @CC_STAGE0@
+system-ghc     = @WithGhc@
+system-ghc-pkg = @GhcPkgCmd@
+tar            = @TarCmd@
+patch          = @PatchCmd@
+perl           = @PerlCmd@
+ln-s           = @LN_S@
+xelatex        = @XELATEX@
+
+# Information about builders:
+#============================
+
+ar-supports-at-file = @ArSupportsAtFile@
+cc-clang-backend    = @CC_CLANG_BACKEND@
+cc-llvm-backend     = @CC_LLVM_BACKEND@
+gcc-is-clang        = @GccIsClang@
+gcc-lt-34           = @GccLT34@
+gcc-lt-44           = @GccLT44@
+gcc-lt-46           = @GccLT46@
+hs-cpp-args         = @HaskellCPPArgs@
+
+# Build options:
+#===============
+
+solaris-broken-shld  = @SOLARIS_BROKEN_SHLD@
+split-objects-broken = @SplitObjsBroken@
+ghc-unregisterised   = @Unregisterised@
+ghc-source-path      = @hardtop@
+leading-underscore   = @LeadingUnderscore@
+
+# Information about build, host and target systems:
+#==================================================
+
+build-platform        = @BuildPlatform@
+build-arch            = @BuildArch_CPP@
+build-os              = @BuildOS_CPP@
+build-vendor          = @BuildVendor_CPP@
+
+host-platform         = @HostPlatform@
+host-arch             = @HostArch_CPP@
+host-os               = @HostOS_CPP@
+host-vendor           = @HostVendor_CPP@
+
+target-platform       = @TargetPlatform@
+target-platform-full  = @TargetPlatformFull@
+target-arch           = @TargetArch_CPP@
+target-os             = @TargetOS_CPP@
+target-vendor         = @TargetVendor_CPP@
+llvm-target           = @LLVMTarget_CPP@
+
+cross-compiling       = @CrossCompiling@
+
+dynamic-extension     = @soext_target@
+
+ghc-version           = @GhcVersion@
+ghc-major-version     = @GhcMajVersion@
+ghc-minor-version     = @GhcMinVersion@
+ghc-patch-level       = @GhcPatchLevel@
+
+supports-this-unit-id = @SUPPORTS_THIS_UNIT_ID@
+
+project-name          = @ProjectName@
+project-version       = @ProjectVersion@
+project-version-int   = @ProjectVersionInt@
+project-patch-level   = @ProjectPatchLevel@
+project-patch-level1  = @ProjectPatchLevel1@
+project-patch-level2  = @ProjectPatchLevel2@
+project-git-commit-id = @ProjectGitCommitId@
+
+# Compilation and linking flags:
+#===============================
+
+conf-cc-args-stage0         = @CONF_CC_OPTS_STAGE0@
+conf-cc-args-stage1         = @CONF_CC_OPTS_STAGE1@
+conf-cc-args-stage2         = @CONF_CC_OPTS_STAGE2@
+
+conf-cpp-args-stage0        = @CONF_CPP_OPTS_STAGE0@
+conf-cpp-args-stage1        = @CONF_CPP_OPTS_STAGE1@
+conf-cpp-args-stage2        = @CONF_CPP_OPTS_STAGE2@
+
+conf-gcc-linker-args-stage0 = @CONF_GCC_LINKER_OPTS_STAGE0@
+conf-gcc-linker-args-stage1 = @CONF_GCC_LINKER_OPTS_STAGE1@
+conf-gcc-linker-args-stage2 = @CONF_GCC_LINKER_OPTS_STAGE2@
+
+conf-ld-linker-args-stage0  = @CONF_LD_LINKER_OPTS_STAGE0@
+conf-ld-linker-args-stage1  = @CONF_LD_LINKER_OPTS_STAGE1@
+conf-ld-linker-args-stage2  = @CONF_LD_LINKER_OPTS_STAGE2@
+
+# Include and library directories:
+#=================================
+
+curses-lib-dir    = @CURSES_LIB_DIRS@
+
+iconv-include-dir = @ICONV_INCLUDE_DIRS@
+iconv-lib-dir     = @ICONV_LIB_DIRS@
+
+gmp-include-dir   = @GMP_INCLUDE_DIRS@
+gmp-lib-dir       = @GMP_LIB_DIRS@
+
+use-system-ffi    = @UseSystemLibFFI@
+ffi-include-dir   = @FFIIncludeDir@
+ffi-lib-dir       = @FFILibDir@
+
+# Optional Dependencies:
+#=======================
+
+with-libdw = @UseLibdw@
+have-lib-mingw-ex = @HaveLibMingwEx@
+
+# Installation:
+#=======================
+
+install-prefix          = @prefix@
+install-bindir          = @prefix@/bin
+install-libdir          = @prefix@/lib
+install-datarootdir     = @prefix@/share
+
+install         = @INSTALL@
+install-program = @INSTALL@ -m 755
+install-script  = @INSTALL@ -m 755
+install-data    = @INSTALL@ -m 644
+install-dir     = @INSTALL@ -m 755 -d
diff --git a/circle.yml b/circle.yml
new file mode 100644 (file)
index 0000000..a386d72
--- /dev/null
@@ -0,0 +1,41 @@
+machine:
+  xcode:
+    version: 8.0
+  environment:
+    MODE: --flavour=quickest --integer-simple
+
+dependencies:
+  override:
+    - brew update
+    - brew install ghc cabal-install python3
+    - cabal update
+    - cabal install alex happy ansi-terminal mtl shake quickcheck
+  cache_directories:
+    - $HOME/.cabal
+    - $HOME/.ghc
+
+compile:
+  override:
+    # Fetch GHC sources into ./ghc
+    - git --version
+    - git config --global url."git://github.com/ghc/packages-".insteadOf git://github.com/ghc/packages/
+    - git clone --depth 1 --recursive git://github.com/ghc/ghc
+
+    - mkdir ghc/hadrian
+    # move hadrian's .git into ./ghc/hadrian and perform a hard reset in order to regenerate Hadrian files
+    - mv .git ghc/hadrian
+    # NOTE: we must write them in the same line because each line
+    # in CircleCI is a separate process, thus you can't "cd" for the other lines
+    - cd ghc/hadrian; git reset --hard HEAD
+
+    # XXX: export PATH doesn't work well either, so we use inline env
+    # Self test
+    - PATH=$HOME/.cabal/bin:$PATH ghc/hadrian/build.sh selftest
+
+    # Build GHC
+    - PATH=$HOME/.cabal/bin:$PATH ghc/hadrian/build.sh -j $MODE --no-progress --progress-colour=never --profile=-
+
+test:
+  override:
+    # Test GHC binary
+    - ghc/inplace/bin/ghc-stage2 -e 1+2
diff --git a/doc/cross-compile.md b/doc/cross-compile.md
new file mode 100644 (file)
index 0000000..1bff4ec
--- /dev/null
@@ -0,0 +1,57 @@
+## Build a cross-compiling GHC
+
+In this example, our host machine is "Ubuntu 16.04.2 LTS, Linux ubuntu 4.4.0-79-generic 86_64".
+
+We need to download necessary tools, including:
+
+- [LLVM-4.0 source](http://releases.llvm.org/4.0.0/llvm-4.0.0.src.tar.xz), you need to build it yourself. Remember to choose release channel and use gold linker (`cmake -DCMAKE_BUILD_TYPE=Release -DLLVM_USE_LINKER=gold ..`)
+- `sudo apt-get install gcc-arm-linux-gnueabihf` to install the GCC cross-compiler
+- Download and install [Haskell Platform 8.0.2](https://haskell.org/platform/download/8.0.2/haskell-platform-8.0.2-unknown-posix--full-x86_64.tar.gz). Install it according to [instructions here](https://www.haskell.org/platform/linux.html#linux-generic)
+
+After all the dependencies are in place:
+
+- `git clone https://github.com/ghc/ghc`
+- `cd ghc`
+- `git clone https://github.com/snowleopard/hadrian`
+- `git submodule update --init`
+- `./configure --target=arm-linux-gnueabihf`
+- `cd hadrian`
+- Modify `src/Settings.hs`, set `stage1Only` and `crossCompiling` to `True`.
+- Build the compiler by e.g. `./build.sh --flavour=quickest --integer-simple --skip-configure -V -j`
+
+After that, you should have built `inplace/bin/ghc-stage1` cross compiler. We will go to the next section to validate this.
+
+## Test run
+
+Write a simple hello world haskell program:
+
+```haskell
+module Main where
+main = putStrLn "Hello, world!"
+```
+Compile it with cross-compiling GHC: `<ghc-folder>/inplace/bin/ghc-stage1 -static Main`. Note that we created a static version of it which packs together all depending libraries.
+
+- Install QEMU: `sudo apt-get install qemu-system-arm`
+- Download `vmlinuz` (kernel) and `initrd.gz` (initial ramdisk), e.g. from [this mirror](https://mirrors.tuna.tsinghua.edu.cn/ubuntu-ports/dists/xenial/main/installer-armhf/current/images/generic-lpae/cdrom/).
+- Add the ARM Linux executable `Main` to the initial ramdisk so we can load it directly into memory. No need for real installation
+  + `gunzip initrd.gz` to get `initrd`
+  + `mkdir tmp2; cd tmp2; sudo cpio -id < ../initrd` to get a file system
+  + `cp /PATH/TO/Main usr/bin`
+  + `find . | cpio --create --format='newc' > /tmp/newinitrd` to pack back the `initrd`
+  + `gzip /tmp/newinitrd`
+  + Move `newinitrd` to where `vmlinuz` is, rename it to `newinitrd.img`
+  + Run the following configured QEMU:
+
+```bash
+#!/bin/sh
+qemu-system-arm \
+    -kernel vmlinuz \
+    -initrd newinitrd.img \
+    -append "root=/dev/vda2 rootfstype=ext4" \
+    -no-reboot \
+    -nographic \
+    -m 1024 \
+    -M virt
+```
+
+This will lead you to a installer interface. But we don't need to do that, so we can save ourself from the hassle of setting up networks etc. We just keep `Go Back`, until see a line `Execute a shell`, and select it. Now you get a shell, go find `/usr/bin/Main` and run it!
diff --git a/doc/flavours.md b/doc/flavours.md
new file mode 100644 (file)
index 0000000..f276dbb
--- /dev/null
@@ -0,0 +1,176 @@
+# Build flavours
+
+Hadrian supports a few predefined _build flavours_, i.e. collections of build
+settings that fully define a GHC build (see `src/Flavour.hs`). Users can add their
+own build flavours if need be, as described
+[here](https://github.com/snowleopard/hadrian/blob/master/doc/user-settings.md#build-flavour).
+
+## Arguments
+
+The following table summarises extra arguments passed to GHC in different build flavours.
+There are four groups of arguments: arguments in `hsDefault` are passed to GHC for all Haskell
+source files, `hsLibrary` arguments are added when compiling libraries, `hsCompiler`
+when compiling the `compiler` library, and `hsGhc` when compiling/linking the GHC program.
+
+<table>
+  <tr>
+    <th rowspan="3">Flavour</th>
+    <th colspan="8">Extra arguments</th>
+  </tr>
+  <tr>
+    <th colspan="2">hsDefault</td>
+    <th colspan="2">hsLibrary</td>
+    <th colspan="2">hsCompiler</td>
+    <th colspan="2">hsGhc</td>
+  </tr>
+  <tr>
+    <th>stage0</td>
+    <th>stage1+</td>
+    <th>stage0</td>
+    <th>stage1+</td>
+    <th>stage0</td>
+    <th>stage1+</td>
+    <th>stage0</td>
+    <th>stage1+</td>
+  </tr>
+  <tr>
+    <th>default<br></td>
+    <td>-O<br>-H64m<br></td>
+    <td>-O2<br>-H64m</td>
+    <td></td>
+    <td></td>
+    <td></td>
+    <td></td>
+    <td></td>
+    <td></td>
+  </tr>
+  <tr>
+    <th>quick</td>
+    <td>-O0<br>-H64m</td>
+    <td>-O0<br>-H64m</td>
+    <td></td>
+    <td>-O</td>
+    <td>-O</td>
+    <td></td>
+    <td>-O</td>
+    <td></td>
+  </tr>
+  <tr>
+    <th>quickest</td>
+    <td>-O0<br>-H64m</td>
+    <td>-O0<br>-H64m</td>
+    <td></td>
+    <td></td>
+    <td>-O</td>
+    <td></td>
+    <td>-O</td>
+    <td></td>
+  </tr>
+  <tr>
+    <th>perf</td>
+    <td>-O<br>-H64m</td>
+    <td>-O<br>-H64m</td>
+    <td></td>
+    <td>-O2</td>
+    <td>-O</td>
+    <td>-O2</td>
+    <td>-O</td>
+    <td>-O2</td>
+  </tr>
+  <tr>
+    <th>prof</td>
+    <td>-O0<br>-H64m</td>
+    <td>-O0<br>-H64m</td>
+    <td></td>
+    <td>-O</td>
+    <td>-O</td>
+    <td>-O</td>
+    <td>-O</td>
+    <td>-O</td>
+  </tr>
+  <tr>
+    <th>devel1</td>
+    <td>-O<br>-H64m</td>
+    <td>-O<br>-H64m</td>
+    <td></td>
+    <td>-dcore-lint</td>
+    <td>-O0<br>-DDEBUG</td>
+    <td></td>
+    <td>-O0<br>-DDEBUG</td>
+    <td></td>
+  </tr>
+  <tr>
+    <th>devel2</td>
+    <td>-O<br>-H64m</td>
+    <td>-O<br>-H64m</td>
+    <td></td>
+    <td>-dcore-lint</td>
+    <td></td>
+    <td>-O0<br>-DDEBUG</td>
+    <td></td>
+    <td>-O0<br>-DDEBUG</td>
+  </tr>
+</table>
+
+## Ways
+
+Libraries and GHC can be built in different _ways_, e.g. with or without profiling
+information. The following table lists ways that are built in different flavours.
+
+<table>
+    <tr>
+        <th rowspan="2">Flavour</th>
+        <th colspan="2">Library ways</th>
+        <th colspan="2">RTS ways</th>
+        <th colspan="2">Profiled GHC</th>
+    </tr>
+    <tr>
+        <th>stage0</th>
+        <th>stage1+</th>
+        <th>stage0</th>
+        <th>stage1+</th>
+        <th>stage0</th>
+        <th>stage1+</th>
+    </tr>
+    <tr>
+    <th>default<br>perf<br>prof<br>devel1<br>devel2</td>
+    <td>vanilla</td>
+    <td>vanilla<br>profiling<br>dynamic</td>
+    <td>logging<br>debug<br>threaded<br>threadedDebug<br>threadedLogging
+        <br>debugDynamic<br>threadedDynamic<br>threadedDebugDynamic
+        <br>loggingDynamic<br>threadedLoggingDynamic
+    </td>
+    <td>
+        logging<br>debug<br>threaded<br>threadedDebug<br>
+        threadedLogging<br>threadedProfiling
+        <br>debugDynamic<br>threadedDynamic<br>threadedDebugDynamic
+        <br>loggingDynamic<br>threadedLoggingDynamic
+    </td>
+    <td>Only in<br>prof<br>flavour</td>
+    <td>Only in<br>prof<br>flavour</td>
+</tr>
+<tr>
+    <th>quick</th>
+    <td>vanilla</td>
+    <td>vanilla<br>dynamic</td>
+    <td>logging<br>debug<br>threaded<br>threadedDebug<br>threadedLogging
+        <br>debugDynamic<br>threadedDynamic<br>threadedDebugDynamic
+        <br>loggingDynamic<br>threadedLoggingDynamic
+    </td>
+    <td>logging<br>debug<br>threaded<br>threadedDebug<br>threadedLogging
+        <br>debugDynamic<br>threadedDynamic<br>threadedDebugDynamic
+        <br>loggingDynamic<br>threadedLoggingDynamic
+    </td>
+    <td>No</td>
+    <td>No</td>
+</tr>
+<tr>
+    <th>quickest</th>
+    <td>vanilla</td>
+    <td>vanilla</td>
+    <td>vanilla<br>threaded</td>
+    <td>vanilla<br>threaded</td>
+    <td>No</td>
+    <td>No</td>
+</tr>
+</table>
diff --git a/doc/user-settings.md b/doc/user-settings.md
new file mode 100644 (file)
index 0000000..c719045
--- /dev/null
@@ -0,0 +1,212 @@
+# User settings
+
+You can customise Hadrian by copying the file `hadrian/src/UserSettings.hs` to
+`hadrian/UserSettings.hs` and overriding the default build settings (if you don't
+copy the file your changes will be tracked by `git` and you can accidentally commit
+them). Here we document currently supported settings.
+
+## Build directory
+
+Hadrian puts build results into `_build` directory by default, which is
+specified by `userBuildRoot`:
+```haskell
+-- | All build results are put into the 'buildRoot' directory.
+userBuildRoot :: BuildRoot
+userBuildRoot = BuildRoot "_build"
+```
+
+## Build flavour
+
+Build _flavour_ is a collection of build settings that fully define a GHC build
+(see `src/Flavour.hs`):
+```haskell
+data Flavour = Flavour {
+    -- | Flavour name, to select this flavour from command line.
+    name :: String,
+    -- | Use these command line arguments.
+    args :: Args,
+    -- | Build these packages.
+    packages :: Stage -> Action [Package],
+    -- | Either 'integerGmp' or 'integerSimple'.
+    integerLibrary :: Action Package,
+    -- | Build libraries these ways.
+    libraryWays :: Ways,
+    -- | Build RTS these ways.
+    rtsWays :: Ways,
+    -- | Build split objects.
+    splitObjects :: Predicate,
+    -- | Build dynamic GHC programs.
+    dynamicGhcPrograms :: Bool,
+    -- | Enable GHCi debugger.
+    ghciWithDebugger :: Bool,
+    -- | Build profiled GHC.
+    ghcProfiled :: Bool,
+    -- | Build GHC with debug information.
+    ghcDebugged :: Bool }
+```
+Hadrian provides several built-in flavours (`defaultFlavour`, `quickFlavour`, and a few
+others; see `hadrian/doc/flavours.md`), which can be activated from the command line,
+e.g. by passing `--flavour=quick`. Users can define new build flavours by adding them
+to `userFlavours` list:
+```haskell
+-- | User-defined build flavours. See 'userFlavour' as an example.
+userFlavours :: [Flavour]
+userFlavours = [userFlavour] -- Add more build flavours if need be.
+
+-- | This is an example user-defined build flavour. Feel free to modify it and
+-- use by passing @--flavour=user@ from the command line.
+userFlavour :: Flavour
+userFlavour = defaultFlavour { name = "user" } -- Modify other settings here.
+```
+Now `--flavour=user` will run Hadrian with `userFlavour` settings. In the
+following sections we look at specific fields of the `Flavour` record in
+more detail. Note: `defaultFlavour`, as well as its individual fields such
+as `defaultArgs`, `defaultPackages`, etc. that we use below, are defined in module
+`Settings.Default`.
+
+## Command line arguments
+
+One of the key features of Hadrian is that users can easily modify any build command.
+The build system will detect the change and will rerun all affected build rules during
+the next build, without requiring a full rebuild.
+
+For example, here is how to pass an extra argument `-O0` to all invocations of
+GHC when compiling package `cabal`:
+```haskell
+userFlavour :: Flavour
+userFlavour = defaultFlavour { name = "user", args = defaultArgs <> userArgs }
+
+userArgs :: Args
+userArgs = builder Ghc ? package cabal ? arg "-O0"
+```
+Builders such as `Ghc` are defined in `src/Builder.hs`, and all packages that
+are currently built as part of the GHC are defined in `src/GHC.hs`.
+
+You can combine several custom command line settings using `mconcat`:
+```haskell
+userArgs :: Args
+userArgs = mconcat
+    [ builder Ghc ? package cabal ? arg "-O0"
+    , package rts ? input "//Evac_thr.c" ? pure [ "-DPARALLEL_GC", "-Irts/sm" ] ]
+```
+You can match any combination of the `builder`, `stage`, `package`, `way`, `input`
+and `output` predicates when specifying custom command line arguments. File
+patterns such as `"//Prelude.*"` can be used when matching input and output files,
+where `//` matches an arbitrary number of path components and `*` matches an entire
+path component, excluding any separators.
+
+## Packages
+
+Users can add and remove packages from particular build stages. As an example,
+below we add package `base` to Stage0 and remove package `haskeline` from Stage1:
+```haskell
+userFlavour :: Flavour
+userFlavour = defaultFlavour { name = "user", packages = modifiedPackages }
+
+modifiedPackages :: Stage -> Action [Package]
+modifiedPackages stage = do
+    packages <- defaultPackages stage
+    return $ case stage of
+        Stage0 -> packages ++ [base]
+        Stage1 -> packages \\ [haskeline]
+        _      -> packages
+```
+If you are working on a new GHC package you need to let Hadrian know about it
+by adding it to `userPackages`:
+```haskell
+userPackages :: [Package]
+userPackages = [userPackage]
+
+-- An example package that lives in "libraries/user-package" directory.
+userPackage :: Package
+userPackage = library "user-package"
+```
+You will also need to add `userPackage` to a specific build stage by modifying
+the `packages` setting of the user flavour as otherwise it will not be built.
+
+You can choose which integer library to use when builing GHC using the
+`integerLibrary` setting of the build flavour. Possible values are: `integerGmp`
+(default) and `integerSimple`.
+```haskell
+userFlavour :: Flavour
+userFlavour = defaultFlavour { name = "user", integerLibrary = integerSimple }
+```
+## Build ways
+
+Packages can be built in a number of ways, such as `vanilla`, `profiling` (with
+profiling information enabled), and many others as defined in `src/Way.hs`. You
+can change the default build ways by modifying `libraryWays` and `rtsWays` fields
+of the `Flavour` record as required. As an example, below we remove `profiling`
+from the list of library ways:
+```haskell
+noProfilingFlavour :: Flavour
+noProfilingFlavour = defaultFlavour
+    { name        = "no-profiling"
+    , libraryWays = remove [profiling] defaultLibraryWays
+    , ghcProfiled = False } -- Can't build profiled GHC without profiled libraries
+```
+Note that `rtsWays` is computed from `libraryWays` by default, therefore the above
+change will lead to the removal of `threadedProfiling` way from `rtsWays`. To
+change this behaviour, you can override the default `rtsWays` setting.
+
+## Verbose command lines
+
+By default Hadrian does not print full command lines during the build process
+and instead prints short human readable digests for each executed command. You
+can suppress this behaviour completely or partially using `verboseCommands` setting:
+```haskell
+-- | Set to 'True' to print full command lines during the build process. Note:
+-- this is a 'Predicate', hence you can enable verbose output only for certain
+-- targets, e.g.: @verboseCommand = package ghcPrim@.
+verboseCommand :: Predicate
+verboseCommand = do
+    verbosity <- expr getVerbosity
+    return $ verbosity >= Loud
+```
+For example, to print the full command lines used to compile GHC executables,
+set `verboseCommands` to:
+```haskell
+verboseCommands :: Predicate
+verboseCommands = input "ghc/Main.hs"
+```
+Below are a few other examples:
+```haskell
+-- Print command lines for all Ghc Link invocations:
+verboseCommands = builder (Ghc Link)
+
+-- Print command lines when compiling files in package compiler using Gcc:
+verboseCommands = builder (Gcc Compile) &&^ package compiler
+
+-- Use patterns when matching files:
+verboseCommands = output "//rts/sm/*" &&^ way threaded
+
+-- Print all commands:
+verboseCommands = return True
+```
+
+## Miscellaneous
+
+By setting `stage1Only = True` you can disable building Stage2 GHC (i.e. the
+`ghc-stage2` executable) and Stage2 utilities, such as `haddock`. Note that all
+Stage0 and Stage1 libraries (including `compiler`) will still be built. Enabling
+this flag during installation leads to installing `ghc-stage1` instead of
+`ghc-stage2`, and `ghc-pkg` that was build with the Stage0 compiler.
+
+To change the default behaviour of Hadrian with respect to building split
+objects, override the `splitObjects` setting of the `Flavour` record:
+```haskell
+userFlavour :: Flavour
+userFlavour = defaultFlavour { name = "user", splitObjects = return False }
+```
+
+Hadrian prints various progress info during the build. You can change the colours
+used by default by overriding `buildProgressColour` and `successColour`:
+```haskell
+-- | Set colour for build progress messages (e.g. executing a build command).
+buildProgressColour :: BuildProgressColour
+buildProgressColour = BuildProgressColour (Dull, Magenta)
+
+-- | Set colour for success messages (e.g. a package is built successfully).
+successColour :: SuccessColour
+successColour = SuccessColour (Dull, Green)
+```
diff --git a/doc/windows.md b/doc/windows.md
new file mode 100644 (file)
index 0000000..b374074
--- /dev/null
@@ -0,0 +1,69 @@
+# Building GHC on Windows\r
+\r
+[![Windows status](https://img.shields.io/appveyor/ci/snowleopard/hadrian/master.svg?label=Windows)](https://ci.appveyor.com/project/snowleopard/hadrian)\r
+\r
+Here is how you can build GHC, from source, on Windows. We assume that `git` and `stack` are installed\r
+(see [prerequisites](https://github.com/snowleopard/hadrian/blob/master/doc/windows.md#prerequisites)).\r
+\r
+```sh\r
+# Get GHC and Hadrian sources; git core.autocrlf should be set to false (see Prerequisites section)\r
+git clone --recursive git://git.haskell.org/ghc.git\r
+cd ghc\r
+git clone git://github.com/snowleopard/hadrian\r
+\r
+# Download and install the bootstrapping GHC and MSYS2\r
+cd hadrian\r
+stack setup\r
+\r
+# Install utilities required during the GHC build process\r
+stack exec -- pacman -S autoconf automake-wrapper make patch python tar --noconfirm\r
+\r
+# Build Hadrian and dependencies (including GHC dependencies Alex and Happy)\r
+stack build\r
+\r
+# Build GHC\r
+stack exec hadrian -- --directory ".." -j --flavour=quickest\r
+\r
+# Test GHC\r
+cd ..\r
+inplace\bin\ghc-stage2 -e 1+2\r
+```\r
+\r
+The entire process should take about 20 minutes. Note, this will build GHC without\r
+optimisations. If you need an optimised GHC, drop the `--flavour=quickest` flag from\r
+the build command line (this will slow down the build to about an hour).\r
+\r
+These are currently not the\r
+[official GHC building instructions](https://ghc.haskell.org/trac/ghc/wiki/Building/Preparation/Windows),\r
+but are much simpler and may also be more robust.\r
+\r
+The `stack build` and `stack exec hadrian` commands can be replaced by an invocation\r
+of Hadrian's Stack-based build script: `build.stack.bat -j --flavour=quickest`. Use this\r
+script if you plan to work on Hadrian and/or rebuild GHC often.\r
+\r
+## Prerequisites\r
+\r
+The above works on a clean machine with `git` and `stack` installed (tested with default\r
+installation settings), which you can get from https://git-scm.com/download/win and\r
+https://www.stackage.org/stack/windows-x86_64-installer.\r
+\r
+Note that `git` should be configured to check out Unix-style line endings. The default behaviour\r
+of `git` on Windows is to check out Windows-style line endings which can cause issues during the\r
+build. This can be changed using the following command:\r
+\r
+    git config --global core.autocrlf false\r
+\r
+If you would like to restore the default behaviour later run:\r
+\r
+    git config --global core.autocrlf true\r
+\r
+## Testing\r
+\r
+These instructions have been tested on a clean Windows 10 machine using the\r
+[free VirtualBox image](https://dev.windows.com/en-us/microsoft-edge/tools/vms/windows/),\r
+and are also routinely tested on\r
+[Hadrian's AppVeyor CI instance](https://ci.appveyor.com/project/snowleopard/hadrian/history).\r
+\r
+## Notes\r
+\r
+Beware of the [current limitations of Hadrian](https://github.com/snowleopard/hadrian#current-limitations).\r
diff --git a/hadrian.cabal b/hadrian.cabal
new file mode 100644 (file)
index 0000000..566437e
--- /dev/null
@@ -0,0 +1,142 @@
+name:                hadrian
+version:             0.1.0.0
+synopsis:            GHC build system
+license:             BSD3
+license-file:        LICENSE
+author:              Andrey Mokhov <andrey.mokhov@gmail.com>, github: @snowleopard
+maintainer:          Andrey Mokhov <andrey.mokhov@gmail.com>, github: @snowleopard
+copyright:           Andrey Mokhov 2014-2017
+category:            Development
+build-type:          Simple
+cabal-version:       >=1.10
+
+source-repository head
+    type:     git
+    location: https://github.com/snowleopard/hadrian
+
+executable hadrian
+    main-is:             Main.hs
+    hs-source-dirs:      .
+                       , src
+    other-modules:       Base
+                       , Builder
+                       , CommandLine
+                       , Context
+                       , Environment
+                       , Expression
+                       , Flavour
+                       , GHC
+                       , Hadrian.Builder
+                       , Hadrian.Builder.Ar
+                       , Hadrian.Builder.Sphinx
+                       , Hadrian.Builder.Tar
+                       , Hadrian.Expression
+                       , Hadrian.Haskell.Cabal
+                       , Hadrian.Haskell.Cabal.Parse
+                       , Hadrian.Oracles.ArgsHash
+                       , Hadrian.Oracles.DirectoryContents
+                       , Hadrian.Oracles.Path
+                       , Hadrian.Oracles.TextFile
+                       , Hadrian.Package
+                       , Hadrian.Target
+                       , Hadrian.Utilities
+                       , Oracles.Flag
+                       , Oracles.Setting
+                       , Oracles.ModuleFiles
+                       , Oracles.PackageData
+                       , Rules
+                       , Rules.Clean
+                       , Rules.Compile
+                       , Rules.Configure
+                       , Rules.PackageData
+                       , Rules.Dependencies
+                       , Rules.Documentation
+                       , Rules.Generate
+                       , Rules.Gmp
+                       , Rules.Install
+                       , Rules.Libffi
+                       , Rules.Library
+                       , Rules.Program
+                       , Rules.Register
+                       , Rules.Selftest
+                       , Rules.SourceDist
+                       , Rules.Test
+                       , Rules.Wrappers
+                       , Settings
+                       , Settings.Builders.Alex
+                       , Settings.Builders.Common
+                       , Settings.Builders.Cc
+                       , Settings.Builders.Configure
+                       , Settings.Builders.DeriveConstants
+                       , Settings.Builders.GenPrimopCode
+                       , Settings.Builders.Ghc
+                       , Settings.Builders.GhcCabal
+                       , Settings.Builders.GhcPkg
+                       , Settings.Builders.Haddock
+                       , Settings.Builders.Happy
+                       , Settings.Builders.Hsc2Hs
+                       , Settings.Builders.HsCpp
+                       , Settings.Builders.Ld
+                       , Settings.Builders.Make
+                       , Settings.Builders.Xelatex
+                       , Settings.Default
+                       , Settings.Flavours.Development
+                       , Settings.Flavours.Performance
+                       , Settings.Flavours.Profiled
+                       , Settings.Flavours.Quick
+                       , Settings.Flavours.QuickCross
+                       , Settings.Flavours.Quickest
+                       , Settings.Packages.Base
+                       , Settings.Packages.Cabal
+                       , Settings.Packages.Compiler
+                       , Settings.Packages.Ghc
+                       , Settings.Packages.GhcCabal
+                       , Settings.Packages.Ghci
+                       , Settings.Packages.GhcPkg
+                       , Settings.Packages.GhcPrim
+                       , Settings.Packages.Haddock
+                       , Settings.Packages.Haskeline
+                       , Settings.Packages.IntegerGmp
+                       , Settings.Packages.Rts
+                       , Settings.Packages.RunGhc
+                       , Settings.Warnings
+                       , Stage
+                       , Target
+                       , UserSettings
+                       , Utilities
+                       , Way
+    default-language:    Haskell2010
+    default-extensions:  DeriveFunctor
+                       , DeriveGeneric
+                       , FlexibleInstances
+                       , GeneralizedNewtypeDeriving
+                       , LambdaCase
+                       , RecordWildCards
+                       , ScopedTypeVariables
+                       , TupleSections
+    other-extensions:    MultiParamTypeClasses
+                       , TypeFamilies
+    build-depends:       base >= 4.8 && < 5
+                       , ansi-terminal        == 0.6.*
+                       , Cabal                == 2.0.0.2
+                       , containers           == 0.5.*
+                       , directory            >= 1.2 && < 1.4
+                       , extra                >= 1.4.7
+                       , mtl                  == 2.2.*
+                       , QuickCheck           >= 2.6 && < 2.10
+                       , shake                == 0.16.*
+                       , transformers         >= 0.4 && < 0.6
+                       , unordered-containers == 0.2.*
+    build-tools:         alex  >= 3.1
+                       , happy >= 1.19.4
+    ghc-options:       -Wall
+                       -Wincomplete-record-updates
+                       -Wredundant-constraints
+                       -fno-warn-name-shadowing
+                       -rtsopts
+                       -- * -I0: Disable idle GC to avoid redundant GCs while
+                       --        waiting for external processes
+                       -- * -qg: Don't use parallel GC as the synchronization
+                       --        time tends to eat any benefit.
+                       "-with-rtsopts=-I0 -qg"
+                       -threaded
diff --git a/src/Base.hs b/src/Base.hs
new file mode 100644 (file)
index 0000000..38c8792
--- /dev/null
@@ -0,0 +1,121 @@
+module Base (
+    -- * General utilities
+    module Control.Applicative,
+    module Control.Monad.Extra,
+    module Data.List.Extra,
+    module Data.Maybe,
+    module Data.Semigroup,
+    module Hadrian.Utilities,
+
+    -- * Shake
+    module Development.Shake,
+    module Development.Shake.Classes,
+    module Development.Shake.FilePath,
+    module Development.Shake.Util,
+
+    -- * Basic data types
+    module Hadrian.Package,
+    module Stage,
+    module Way,
+
+    -- * Paths
+    hadrianPath, configPath, configFile, sourcePath, configH, shakeFilesDir,
+    generatedDir, inplaceBinPath, inplaceLibBinPath, inplaceLibPath,
+    inplaceLibCopyTargets, templateHscPath, stage0PackageDbDir,
+    inplacePackageDbPath, packageDbPath, packageDbStamp
+    ) where
+
+import Control.Applicative
+import Control.Monad.Extra
+import Control.Monad.Reader
+import Data.List.Extra
+import Data.Maybe
+import Data.Semigroup
+import Development.Shake hiding (parallel, unit, (*>), Normal)
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import Development.Shake.Util
+import Hadrian.Utilities
+import Hadrian.Package
+
+import Stage
+import Way
+
+-- | Hadrian lives in the 'hadrianPath' directory of the GHC tree.
+hadrianPath :: FilePath
+hadrianPath = "hadrian"
+
+-- TODO: Move this to build directory?
+-- | Path to system configuration files, such as 'configFile'.
+configPath :: FilePath
+configPath = hadrianPath -/- "cfg"
+
+-- | Path to the system configuration file generated by the @configure@ script.
+configFile :: FilePath
+configFile = configPath -/- "system.config"
+
+-- | Path to source files of the build system, e.g. this file is located at
+-- @sourcePath -/- "Base.hs"@. We use this to track some of the source files.
+sourcePath :: FilePath
+sourcePath = hadrianPath -/- "src"
+
+-- TODO: Change @mk/config.h@ to @shake-build/cfg/config.h@.
+-- | Path to the generated @mk/config.h@ file.
+configH :: FilePath
+configH = "mk/config.h"
+
+-- | The directory in 'buildRoot' containing the Shake database and other
+-- auxiliary files generated by Hadrian.
+shakeFilesDir :: FilePath
+shakeFilesDir = "hadrian"
+
+-- | The directory in 'buildRoot' containing generated source files that are not
+-- package-specific, e.g. @ghcplatform.h@.
+generatedDir :: FilePath
+generatedDir = "generated"
+
+-- | The directory in 'buildRoot' containing the 'Stage0' package database.
+stage0PackageDbDir :: FilePath
+stage0PackageDbDir = "stage0/bootstrapping.conf"
+
+-- | Path to the inplace package database used in 'Stage1' and later.
+inplacePackageDbPath :: FilePath
+inplacePackageDbPath = "inplace/lib/package.conf.d"
+
+-- | Path to the package database used in a given 'Stage'.
+packageDbPath :: Stage -> Action FilePath
+packageDbPath Stage0 = buildRoot <&> (-/- stage0PackageDbDir)
+packageDbPath _      = return inplacePackageDbPath
+
+-- | We use a stamp file to track the existence of a package database.
+packageDbStamp :: FilePath
+packageDbStamp = ".stamp"
+
+-- | Directory for binaries that are built "in place".
+inplaceBinPath :: FilePath
+inplaceBinPath = "inplace/bin"
+
+-- | Directory for libraries that are built "in place".
+inplaceLibPath :: FilePath
+inplaceLibPath = "inplace/lib"
+
+-- | Directory for binary wrappers, and auxiliary binaries such as @touchy@.
+inplaceLibBinPath :: FilePath
+inplaceLibBinPath = "inplace/lib/bin"
+
+-- ref: ghc/ghc.mk:142
+-- ref: driver/ghc.mk
+-- ref: utils/hsc2hs/ghc.mk:35
+-- | Files that need to be copied over to 'inplaceLibPath'.
+inplaceLibCopyTargets :: [FilePath]
+inplaceLibCopyTargets = map (inplaceLibPath -/-)
+    [ "ghc-usage.txt"
+    , "ghci-usage.txt"
+    , "llvm-targets"
+    , "platformConstants"
+    , "settings"
+    , "template-hsc.h" ]
+
+-- | Path to hsc2hs template.
+templateHscPath :: FilePath
+templateHscPath = "inplace/lib/template-hsc.h"
diff --git a/src/Builder.hs b/src/Builder.hs
new file mode 100644 (file)
index 0000000..2b99c03
--- /dev/null
@@ -0,0 +1,296 @@
+{-# LANGUAGE InstanceSigs #-}
+module Builder (
+    -- * Data types
+    ArMode (..), CcMode (..), GhcMode (..), GhcPkgMode (..), HaddockMode (..),
+    SphinxMode (..), TarMode (..), Builder (..),
+
+    -- * Builder properties
+    builderProvenance, systemBuilderPath, builderPath, isSpecified, needBuilder,
+    runBuilder, runBuilderWith, runBuilderWithCmdOptions, getBuilderPath,
+    builderEnvironment,
+
+    -- * Ad hoc builder invokation
+    applyPatch, installDirectory, installData, installScript, installProgram,
+    linkSymbolic
+    ) where
+
+import Development.Shake.Classes
+import GHC.Generics
+import qualified Hadrian.Builder as H
+import Hadrian.Builder hiding (Builder)
+import Hadrian.Builder.Ar
+import Hadrian.Builder.Sphinx
+import Hadrian.Builder.Tar
+import Hadrian.Oracles.Path
+import Hadrian.Oracles.TextFile
+import Hadrian.Utilities
+import qualified System.Directory.Extra as IO
+
+import Base
+import Context
+import GHC
+import Oracles.Flag
+import Oracles.Setting
+
+-- | C compiler can be used in two different modes:
+-- * Compile or preprocess a source file.
+-- * Extract source dependencies by passing @-MM@ command line argument.
+data CcMode = CompileC | FindCDependencies deriving (Eq, Generic, Show)
+
+instance Binary   CcMode
+instance Hashable CcMode
+instance NFData   CcMode
+
+-- | GHC can be used in four different modes:
+-- * Compile a Haskell source file.
+-- * Compile a C source file.
+-- * Extract source dependencies by passing @-M@ command line argument.
+-- * Link object files & static libraries into an executable.
+data GhcMode = CompileHs | CompileCWithGhc | FindHsDependencies | LinkHs
+    deriving (Eq, Generic, Show)
+
+instance Binary   GhcMode
+instance Hashable GhcMode
+instance NFData   GhcMode
+
+-- | GhcPkg can initialise a package database and register packages in it.
+data GhcPkgMode = Init | Update deriving (Eq, Generic, Show)
+
+instance Binary   GhcPkgMode
+instance Hashable GhcPkgMode
+instance NFData   GhcPkgMode
+
+-- | Haddock can be used in two different modes:
+-- * Generate documentation for a single package
+-- * Generate an index page for a collection of packages
+data HaddockMode = BuildPackage | BuildIndex deriving (Eq, Generic, Show)
+
+instance Binary   HaddockMode
+instance Hashable HaddockMode
+instance NFData   HaddockMode
+
+-- | A 'Builder' is an external command invoked in a separate process via 'cmd'.
+-- @Ghc Stage0@ is the bootstrapping compiler.
+-- @Ghc StageN@, N > 0, is the one built in stage (N - 1).
+-- @GhcPkg Stage0@ is the bootstrapping @GhcPkg@.
+-- @GhcPkg Stage1@ is the one built in Stage0.
+data Builder = Alex
+             | Ar ArMode Stage
+             | DeriveConstants
+             | Cc CcMode Stage
+             | Configure FilePath
+             | GenApply
+             | GenPrimopCode
+             | Ghc GhcMode Stage
+             | GhcCabal
+             | GhcPkg GhcPkgMode Stage
+             | Haddock HaddockMode
+             | Happy
+             | Hpc
+             | HsCpp
+             | Hsc2Hs
+             | Ld
+             | Make FilePath
+             | Nm
+             | Objdump
+             | Patch
+             | Perl
+             | Ranlib
+             | Sphinx SphinxMode
+             | Tar TarMode
+             | Unlit
+             | Xelatex
+             deriving (Eq, Generic, Show)
+
+instance Binary   Builder
+instance Hashable Builder
+instance NFData   Builder
+
+-- | Some builders are built by this very build system, in which case
+-- 'builderProvenance' returns the corresponding build 'Context' (which includes
+-- 'Stage' and GHC 'Package').
+builderProvenance :: Builder -> Maybe Context
+builderProvenance = \case
+    DeriveConstants  -> context Stage0 deriveConstants
+    GenApply         -> context Stage0 genapply
+    GenPrimopCode    -> context Stage0 genprimopcode
+    Ghc _ Stage0     -> Nothing
+    Ghc _ stage      -> context (pred stage) ghc
+    GhcCabal         -> context Stage0 ghcCabal
+    GhcPkg _ Stage0  -> Nothing
+    GhcPkg _ _       -> context Stage0 ghcPkg
+    Haddock _        -> context Stage2 haddock
+    Hpc              -> context Stage1 hpcBin
+    Hsc2Hs           -> context Stage0 hsc2hs
+    Unlit            -> context Stage0 unlit
+    _                -> Nothing
+  where
+    context s p = Just $ vanillaContext s p
+
+instance H.Builder Builder where
+    builderPath :: Builder -> Action FilePath
+    builderPath builder = case builderProvenance builder of
+        Nothing      -> systemBuilderPath builder
+        Just context -> programPath context
+
+    needBuilder :: Builder -> Action ()
+    needBuilder builder = do
+        path <- H.builderPath builder
+        case builder of
+            Configure dir -> need [dir -/- "configure"]
+            Hsc2Hs        -> need [path, templateHscPath]
+            Make dir      -> need [dir -/- "Makefile"]
+            _             -> when (isJust $ builderProvenance builder) $ need [path]
+
+    runBuilderWith :: Builder -> BuildInfo -> Action ()
+    runBuilderWith builder BuildInfo {..} = do
+        path <- builderPath builder
+        withResources buildResources $ do
+            verbosity <- getVerbosity
+            let input  = fromSingleton msgIn buildInputs
+                msgIn  = "[runBuilderWith] Exactly one input file expected."
+                output = fromSingleton msgOut buildOutputs
+                msgOut = "[runBuilderWith] Exactly one output file expected."
+                -- Suppress stdout depending on the Shake's verbosity setting.
+                echo = EchoStdout (verbosity >= Loud)
+                -- Capture stdout and write it to the output file.
+                captureStdout = do
+                    Stdout stdout <- cmd [path] buildArgs
+                    writeFileChanged output stdout
+            case builder of
+                Ar Pack _ -> do
+                    useTempFile <- flag ArSupportsAtFile
+                    if useTempFile then runAr                path buildArgs
+                                   else runArWithoutTempFile path buildArgs
+
+                Ar Unpack _ -> cmd echo [Cwd output] [path] buildArgs
+
+                Configure dir -> do
+                    -- Inject /bin/bash into `libtool`, instead of /bin/sh,
+                    -- otherwise Windows breaks. TODO: Figure out why.
+                    bash <- bashPath
+                    let env = AddEnv "CONFIG_SHELL" bash
+                    cmd echo env [Cwd dir] ["sh", path] buildOptions buildArgs
+
+                HsCpp    -> captureStdout
+                GenApply -> captureStdout
+
+                GenPrimopCode -> do
+                    stdin <- readFile' input
+                    Stdout stdout <- cmd (Stdin stdin) [path] buildArgs
+                    writeFileChanged output stdout
+
+                Make dir -> cmd echo path ["-C", dir] buildArgs
+
+                Xelatex -> do
+                    unit $ cmd [Cwd output] [path]        buildArgs
+                    unit $ cmd [Cwd output] [path]        buildArgs
+                    unit $ cmd [Cwd output] [path]        buildArgs
+                    unit $ cmd [Cwd output] ["makeindex"] (input -<.> "idx")
+                    unit $ cmd [Cwd output] [path]        buildArgs
+                    unit $ cmd [Cwd output] [path]        buildArgs
+
+                _  -> cmd echo [path] buildArgs
+
+-- TODO: Some builders are required only on certain platforms. For example,
+-- 'Objdump' is only required on OpenBSD and AIX. Add support for platform
+-- specific optional builders as soon as we can reliably test this feature.
+-- See https://github.com/snowleopard/hadrian/issues/211.
+isOptional :: Builder -> Bool
+isOptional = \case
+    Objdump  -> True
+    _        -> False
+
+-- | Determine the location of a system 'Builder'.
+systemBuilderPath :: Builder -> Action FilePath
+systemBuilderPath builder = case builder of
+    Alex            -> fromKey "alex"
+    Ar _ Stage0     -> fromKey "system-ar"
+    Ar _ _          -> fromKey "ar"
+    Cc  _  Stage0   -> fromKey "system-cc"
+    Cc  _  _        -> fromKey "cc"
+    -- We can't ask configure for the path to configure!
+    Configure _     -> return "configure"
+    Ghc _  Stage0   -> fromKey "system-ghc"
+    GhcPkg _ Stage0 -> fromKey "system-ghc-pkg"
+    Happy           -> fromKey "happy"
+    HsCpp           -> fromKey "hs-cpp"
+    Ld              -> fromKey "ld"
+    Make _          -> fromKey "make"
+    Nm              -> fromKey "nm"
+    Objdump         -> fromKey "objdump"
+    Patch           -> fromKey "patch"
+    Perl            -> fromKey "perl"
+    Ranlib          -> fromKey "ranlib"
+    Sphinx _        -> fromKey "sphinx-build"
+    Tar _           -> fromKey "tar"
+    Xelatex         -> fromKey "xelatex"
+    _               -> error $ "No entry for " ++ show builder ++ inCfg
+  where
+    inCfg = " in " ++ quote configFile ++ " file."
+    fromKey key = do
+        let unpack = fromMaybe . error $ "Cannot find path to builder "
+                ++ quote key ++ inCfg ++ " Did you skip configure?"
+        path <- unpack <$> lookupValue configFile key
+        if null path
+        then do
+            unless (isOptional builder) . error $ "Non optional builder "
+                ++ quote key ++ " is not specified" ++ inCfg
+            return "" -- TODO: Use a safe interface.
+        else fixAbsolutePathOnWindows =<< lookupInPath path
+
+-- | Was the path to a given system 'Builder' specified in configuration files?
+isSpecified :: Builder -> Action Bool
+isSpecified = fmap (not . null) . systemBuilderPath
+
+-- | Apply a patch by executing the 'Patch' builder in a given directory.
+applyPatch :: FilePath -> FilePath -> Action ()
+applyPatch dir patch = do
+    let file = dir -/- patch
+    needBuilder Patch
+    path <- builderPath Patch
+    putBuild $ "| Apply patch " ++ file
+    quietly $ cmd [Cwd dir, FileStdin file] [path, "-p0"]
+
+-- | Install a directory.
+installDirectory :: FilePath -> Action ()
+installDirectory dir = do
+    path <- fixAbsolutePathOnWindows =<< setting InstallDir
+    putBuild $ "| Install directory " ++ dir
+    quietly $ cmd path dir
+
+-- | Install data files to a directory and track them.
+installData :: [FilePath] -> FilePath -> Action ()
+installData fs dir = do
+    path <- fixAbsolutePathOnWindows =<< setting InstallData
+    need fs
+    forM_ fs $ \f -> putBuild $ "| Install data " ++ f ++ " to " ++ dir
+    quietly $ cmd path fs dir
+
+-- | Install an executable file to a directory and track it.
+installProgram :: FilePath -> FilePath -> Action ()
+installProgram f dir = do
+    path <- fixAbsolutePathOnWindows =<< setting InstallProgram
+    need [f]
+    putBuild $ "| Install program " ++ f ++ " to " ++ dir
+    quietly $ cmd path f dir
+
+-- | Install an executable script to a directory and track it.
+installScript :: FilePath -> FilePath -> Action ()
+installScript f dir = do
+    path <- fixAbsolutePathOnWindows =<< setting InstallScript
+    need [f]
+    putBuild $ "| Install script " ++ f ++ " to " ++ dir
+    quietly $ cmd path f dir
+
+-- | Create a symbolic link from source file to target file (when symbolic links
+-- are supported) and track the source file.
+linkSymbolic :: FilePath -> FilePath -> Action ()
+linkSymbolic source target = do
+    lns <- setting LnS
+    unless (null lns) $ do
+        need [source] -- Guarantee source is built before printing progress info.
+        let dir = takeDirectory target
+        liftIO $ IO.createDirectoryIfMissing True dir
+        putProgressInfo =<< renderAction "Create symbolic link" source target
+        quietly $ cmd lns source target
diff --git a/src/CommandLine.hs b/src/CommandLine.hs
new file mode 100644 (file)
index 0000000..1ba38c4
--- /dev/null
@@ -0,0 +1,137 @@
+module CommandLine (
+    optDescrs, cmdLineArgsMap, cmdFlavour, lookupFreeze1, cmdIntegerSimple,
+    cmdProgressColour, cmdProgressInfo, cmdSkipConfigure, cmdSplitObjects,
+    cmdInstallDestDir
+    ) where
+
+import Data.Either
+import qualified Data.HashMap.Strict as Map
+import Data.List.Extra
+import Development.Shake hiding (Normal)
+import Hadrian.Utilities
+import System.Console.GetOpt
+import System.Environment
+
+-- | All arguments that can be passed to Hadrian via the command line.
+data CommandLineArgs = CommandLineArgs
+    { flavour        :: Maybe String
+    , freeze1        :: Bool
+    , installDestDir :: Maybe String
+    , integerSimple  :: Bool
+    , progressColour :: UseColour
+    , progressInfo   :: ProgressInfo
+    , skipConfigure  :: Bool
+    , splitObjects   :: Bool }
+    deriving (Eq, Show)
+
+-- | Default values for 'CommandLineArgs'.
+defaultCommandLineArgs :: CommandLineArgs
+defaultCommandLineArgs = CommandLineArgs
+    { flavour        = Nothing
+    , freeze1        = False
+    , installDestDir = Nothing
+    , integerSimple  = False
+    , progressColour = Auto
+    , progressInfo   = Brief
+    , skipConfigure  = False
+    , splitObjects   = False }
+
+readFreeze1 :: Either String (CommandLineArgs -> CommandLineArgs)
+readFreeze1 = Right $ \flags -> flags { freeze1 = True }
+
+readFlavour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readFlavour ms = Right $ \flags -> flags { flavour = lower <$> ms }
+
+readInstallDestDir :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readInstallDestDir ms = Right $ \flags -> flags { installDestDir = ms }
+
+readIntegerSimple :: Either String (CommandLineArgs -> CommandLineArgs)
+readIntegerSimple = Right $ \flags -> flags { integerSimple = True }
+
+readProgressColour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readProgressColour ms =
+    maybe (Left "Cannot parse progress-colour") (Right . set) (go =<< lower <$> ms)
+  where
+    go :: String -> Maybe UseColour
+    go "never"   = Just Never
+    go "auto"    = Just Auto
+    go "always"  = Just Always
+    go _         = Nothing
+    set :: UseColour -> CommandLineArgs -> CommandLineArgs
+    set flag flags = flags { progressColour = flag }
+
+readProgressInfo :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readProgressInfo ms =
+    maybe (Left "Cannot parse progress-info") (Right . set) (go =<< lower <$> ms)
+  where
+    go :: String -> Maybe ProgressInfo
+    go "none"    = Just None
+    go "brief"   = Just Brief
+    go "normal"  = Just Normal
+    go "unicorn" = Just Unicorn
+    go _         = Nothing
+    set :: ProgressInfo -> CommandLineArgs -> CommandLineArgs
+    set flag flags = flags { progressInfo = flag }
+
+readSkipConfigure :: Either String (CommandLineArgs -> CommandLineArgs)
+readSkipConfigure = Right $ \flags -> flags { skipConfigure = True }
+
+readSplitObjects :: Either String (CommandLineArgs -> CommandLineArgs)
+readSplitObjects = Right $ \flags -> flags { splitObjects = True }
+
+-- | Standard 'OptDescr' descriptions of Hadrian's command line arguments.
+optDescrs :: [OptDescr (Either String (CommandLineArgs -> CommandLineArgs))]
+optDescrs =
+    [ Option [] ["flavour"] (OptArg readFlavour "FLAVOUR")
+      "Build flavour (Default, Devel1, Devel2, Perf, Prof, Quick or Quickest)."
+    , Option [] ["freeze1"] (NoArg readFreeze1)
+      "Freeze Stage1 GHC."
+    , Option [] ["install-destdir"] (OptArg readInstallDestDir "DESTDIR")
+      "Installation destination directory."
+    , Option [] ["integer-simple"] (NoArg readIntegerSimple)
+      "Build GHC with integer-simple library."
+    , Option [] ["progress-colour"] (OptArg readProgressColour "MODE")
+      "Use colours in progress info (Never, Auto or Always)."
+    , Option [] ["progress-info"] (OptArg readProgressInfo "STYLE")
+      "Progress info style (None, Brief, Normal or Unicorn)."
+    , Option [] ["skip-configure"] (NoArg readSkipConfigure)
+      "Skip the boot and configure scripts (if you want to run them manually)."
+    , Option [] ["split-objects"] (NoArg readSplitObjects)
+      "Generate split objects (requires a full clean rebuild)." ]
+
+-- | A type-indexed map containing Hadrian command line arguments to be passed
+-- to Shake via 'shakeExtra'.
+cmdLineArgsMap :: IO (Map.HashMap TypeRep Dynamic)
+cmdLineArgsMap = do
+    (opts, _, _) <- getOpt Permute optDescrs <$> getArgs
+    let args = foldl (flip id) defaultCommandLineArgs (rights opts)
+    return $ insertExtra (progressColour args) -- Accessed by Hadrian.Utilities
+           $ insertExtra (progressInfo   args) -- Accessed by Hadrian.Utilities
+           $ insertExtra args Map.empty
+
+cmdLineArgs :: Action CommandLineArgs
+cmdLineArgs = userSetting defaultCommandLineArgs
+
+cmdFlavour :: Action (Maybe String)
+cmdFlavour = flavour <$> cmdLineArgs
+
+lookupFreeze1 :: Map.HashMap TypeRep Dynamic -> Bool
+lookupFreeze1 = freeze1 . lookupExtra defaultCommandLineArgs
+
+cmdInstallDestDir :: Action (Maybe String)
+cmdInstallDestDir = installDestDir <$> cmdLineArgs
+
+cmdIntegerSimple :: Action Bool
+cmdIntegerSimple = integerSimple <$> cmdLineArgs
+
+cmdProgressColour :: Action UseColour
+cmdProgressColour = progressColour <$> cmdLineArgs
+
+cmdProgressInfo :: Action ProgressInfo
+cmdProgressInfo = progressInfo <$> cmdLineArgs
+
+cmdSkipConfigure :: Action Bool
+cmdSkipConfigure = skipConfigure <$> cmdLineArgs
+
+cmdSplitObjects :: Action Bool
+cmdSplitObjects = splitObjects <$> cmdLineArgs
diff --git a/src/Context.hs b/src/Context.hs
new file mode 100644 (file)
index 0000000..ad1a2d7
--- /dev/null
@@ -0,0 +1,158 @@
+module Context (
+    -- * Context
+    Context (..), vanillaContext, stageContext,
+
+    -- * Expressions
+    getStage, getPackage, getWay, getStagedSettingList, getBuildPath,
+    withHsPackage,
+
+    -- * Paths
+    contextDir, buildPath, pkgInplaceConfig, pkgDataFile, pkgSetupConfigFile,
+    pkgHaddockFile, pkgLibraryFile, pkgLibraryFile0, pkgGhciLibraryFile,
+    pkgConfFile, objectPath
+    ) where
+
+import GHC.Generics
+import Hadrian.Expression
+import Hadrian.Haskell.Cabal
+
+import Base
+import Oracles.Setting
+
+-- | Build context for a currently built 'Target'. We generate potentially
+-- different build rules for each 'Context'.
+data Context = Context
+    { stage   :: Stage   -- ^ Currently build Stage
+    , package :: Package -- ^ Currently build Package
+    , way     :: Way     -- ^ Currently build Way (usually 'vanilla')
+    } deriving (Eq, Generic, Show)
+
+instance Binary   Context
+instance Hashable Context
+instance NFData   Context
+
+-- | Most targets are built only one way, hence the notion of 'vanillaContext'.
+vanillaContext :: Stage -> Package -> Context
+vanillaContext s p = Context s p vanilla
+
+-- | Partial context with undefined 'Package' field. Useful for 'Packages'
+-- expressions that only read the environment and current 'Stage'.
+stageContext :: Stage -> Context
+stageContext s = vanillaContext s $ error "stageContext: package not set"
+
+-- | Get the 'Stage' of the current 'Context'.
+getStage :: Expr Context b Stage
+getStage = stage <$> getContext
+
+-- | Get the 'Package' of the current 'Context'.
+getPackage :: Expr Context b Package
+getPackage = package <$> getContext
+
+-- | Get the 'Way' of the current 'Context'.
+getWay :: Expr Context b Way
+getWay = way <$> getContext
+
+-- | Get a list of configuration settings for the current stage.
+getStagedSettingList :: (Stage -> SettingList) -> Args Context b
+getStagedSettingList f = getSettingList . f =<< getStage
+
+-- | Construct an expression that depends on the Cabal file of the current
+-- package and is empty in a non-Haskell context.
+withHsPackage :: (Monoid a, Semigroup a) => (FilePath -> Expr Context b a) -> Expr Context b a
+withHsPackage expr = do
+    pkg <- getPackage
+    case pkgCabalFile pkg of
+        Just file -> expr file
+        Nothing   -> mempty
+
+-- | The directory in 'buildRoot' containing build artefacts of a given 'Context'.
+contextDir :: Context -> FilePath
+contextDir Context {..} = stageString stage -/- pkgPath package
+
+-- | Path to the directory containing build artefacts of a given 'Context'.
+buildPath :: Context -> Action FilePath
+buildPath context = buildRoot <&> (-/- contextDir context)
+
+-- | Get the build path of the current 'Context'.
+getBuildPath :: Expr Context b FilePath
+getBuildPath = expr . buildPath =<< getContext
+
+pkgId :: Package -> Action FilePath
+pkgId package = case pkgCabalFile package of
+    Just file -> pkgIdentifier file
+    Nothing   -> return (pkgName package) -- Non-Haskell packages, e.g. rts
+
+pkgFile :: Context -> String -> String -> Action FilePath
+pkgFile context@Context {..} prefix suffix = do
+    path <- buildPath context
+    pid  <- pkgId package
+    return $ path -/- prefix ++ pid ++ suffix
+
+-- | Path to inplace package configuration file of a given 'Context'.
+pkgInplaceConfig :: Context -> Action FilePath
+pkgInplaceConfig context = do
+    path <- buildPath context
+    return $ path -/- "inplace-pkg-config"
+
+-- | Path to the @package-data.mk@ of a given 'Context'.
+pkgDataFile :: Context -> Action FilePath
+pkgDataFile context = do
+    path <- buildPath context
+    return $ path -/- "package-data.mk"
+
+-- | Path to the @setup-config@ of a given 'Context'.
+pkgSetupConfigFile :: Context -> Action FilePath
+pkgSetupConfigFile context = do
+    path <- buildPath context
+    return $ path -/- "setup-config"
+
+-- | Path to the haddock file of a given 'Context', e.g.:
+-- @_build/stage1/libraries/array/doc/html/array/array.haddock@.
+pkgHaddockFile :: Context -> Action FilePath
+pkgHaddockFile Context {..} = do
+    root <- buildRoot
+    let name = pkgName package
+    return $ root -/- "docs/html/libraries" -/- name -/- name <.> "haddock"
+
+-- | Path to the library file of a given 'Context', e.g.:
+-- @_build/stage1/libraries/array/build/libHSarray-0.5.1.0.a@.
+pkgLibraryFile :: Context -> Action FilePath
+pkgLibraryFile context@Context {..} = do
+    extension <- libsuf way
+    pkgFile context "libHS" extension
+
+-- | Path to the auxiliary library file of a given 'Context', e.g.:
+-- @_build/stage1/compiler/build/libHSghc-8.1-0.a@.
+pkgLibraryFile0 :: Context -> Action FilePath
+pkgLibraryFile0 context@Context {..} = do
+    extension <- libsuf way
+    pkgFile context "libHS" ("-0" ++ extension)
+
+-- | Path to the GHCi library file of a given 'Context', e.g.:
+-- @_build/stage1/libraries/array/build/HSarray-0.5.1.0.o@.
+pkgGhciLibraryFile :: Context -> Action FilePath
+pkgGhciLibraryFile context = pkgFile context "HS" ".o"
+
+-- | Path to the configuration file of a given 'Context'.
+pkgConfFile :: Context -> Action FilePath
+pkgConfFile Context {..} = do
+    root  <- buildRoot
+    pid   <- pkgId package
+    let dbDir | stage == Stage0 = root -/- stage0PackageDbDir
+              | otherwise       = inplacePackageDbPath
+    return $ dbDir -/- pid <.> "conf"
+
+-- | Given a 'Context' and a 'FilePath' to a source file, compute the 'FilePath'
+-- to its object file. For example:
+-- * "Task.c"                              -> "_build/stage1/rts/Task.thr_o"
+-- * "_build/stage1/rts/cmm/AutoApply.cmm" -> "_build/stage1/rts/cmm/AutoApply.o"
+objectPath :: Context -> FilePath -> Action FilePath
+objectPath context@Context {..} src = do
+    isGenerated <- isGeneratedSource src
+    path        <- buildPath context
+    let extension = drop 1 $ takeExtension src
+        obj       = src -<.> osuf way
+        result | isGenerated          = obj
+               | "*hs*" ?== extension = path -/- obj
+               | otherwise            = path -/- extension -/- obj
+    return result
diff --git a/src/Environment.hs b/src/Environment.hs
new file mode 100644 (file)
index 0000000..de43efa
--- /dev/null
@@ -0,0 +1,16 @@
+module Environment (setupEnvironment) where
+
+import System.Environment
+
+-- | The build system invokes many external builders whose behaviour is
+-- influenced by the environment variables. We need to modify some of them
+-- for better robustness of the build system.
+setupEnvironment :: IO ()
+setupEnvironment = do
+    -- ghc-cabal refuses to work when GHC_PACKAGE_PATH is set (e.g. by Stack)
+    unsetEnv "GHC_PACKAGE_PATH"
+
+    -- in MinGW if PWD is set to a Windows "C:\\" style path then configure
+    -- `pwd` will return the Windows path, and then modifying $PATH will fail.
+    -- See https://github.com/snowleopard/hadrian/issues/189 for details.
+    unsetEnv "PWD"
diff --git a/src/Expression.hs b/src/Expression.hs
new file mode 100644 (file)
index 0000000..7e8220e
--- /dev/null
@@ -0,0 +1,123 @@
+module Expression (
+    -- * Expressions
+    Expr, Predicate, Args, Ways,
+
+    -- ** Construction and modification
+    expr, exprIO, arg, remove,
+
+    -- ** Predicates
+    (?), stage, stage0, stage1, stage2, notStage0, package, notPackage,
+    libraryPackage, builder, way, input, inputs, output, outputs,
+
+    -- ** Evaluation
+    interpret, interpretInContext,
+
+    -- * Convenient accessors
+    getBuildRoot, getContext, getPkgData, getPkgDataList, getOutputs, getInputs,
+    getInput, getOutput,
+
+    -- * Re-exports
+    module Base,
+    module Builder,
+    module Context,
+    module GHC
+    ) where
+
+import qualified Hadrian.Expression as H
+import Hadrian.Expression hiding (Expr, Predicate, Args)
+
+import Base
+import Builder
+import GHC
+import Context hiding (stage, package, way)
+import Oracles.PackageData
+
+-- | @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 = 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 = H.Predicate Context Builder
+type Args      = H.Args      Context Builder
+type Ways      = Expr [Way]
+
+-- | Get a value from the @package-data.mk@ file of the current context.
+getPkgData :: (FilePath -> PackageData) -> Expr String
+getPkgData key = expr . pkgData . key =<< getBuildPath
+
+-- | Get a list of values from the @package-data.mk@ file of the current context.
+getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String]
+getPkgDataList key = expr . pkgDataList . key =<< getBuildPath
+
+-- | Is the build currently in the provided stage?
+stage :: Stage -> Predicate
+stage s = (s ==) <$> getStage
+
+-- | Is a particular package being built?
+package :: Package -> Predicate
+package p = (p ==) <$> getPackage
+
+-- | This type class allows the user to construct both precise builder
+-- predicates, such as @builder (Ghc CompileHs Stage1)@, as well as predicates
+-- covering a set of similar builders. For example, @builder (Ghc CompileHs)@
+-- matches any stage, and @builder Ghc@ matches any stage and any GHC mode.
+class BuilderPredicate a where
+    -- | Is a particular builder being used?
+    builder :: a -> Predicate
+
+instance BuilderPredicate Builder where
+    builder b = (b ==) <$> getBuilder
+
+instance BuilderPredicate a => BuilderPredicate (Stage -> a) where
+    builder f = builder . f =<< getStage
+
+instance BuilderPredicate a => BuilderPredicate (CcMode -> a) where
+    builder f = do
+        b <- getBuilder
+        case b of
+            Cc  c _ -> builder (f c)
+            _       -> return False
+
+instance BuilderPredicate a => BuilderPredicate (GhcMode -> a) where
+    builder f = do
+        b <- getBuilder
+        case b of
+            Ghc c _ -> builder (f c)
+            _       -> return False
+
+instance BuilderPredicate a => BuilderPredicate (FilePath -> a) where
+    builder f = do
+        b <- getBuilder
+        case b of
+            Configure path -> builder (f path)
+            _              -> return False
+
+-- | Is the current build 'Way' equal to a certain value?
+way :: Way -> Predicate
+way w = (w ==) <$> getWay
+
+-- | Is the build currently in stage 0?
+stage0 :: Predicate
+stage0 = stage Stage0
+
+-- | Is the build currently in stage 1?
+stage1 :: Predicate
+stage1 = stage Stage1
+
+-- | Is the build currently in stage 2?
+stage2 :: Predicate
+stage2 = stage Stage2
+
+-- | Is the build /not/ in stage 0 right now?
+notStage0 :: Predicate
+notStage0 = notM stage0
+
+-- | Is a certain package /not/ built right now?
+notPackage :: Package -> Predicate
+notPackage = notM . package
+
+-- | Is a library package currently being built?
+libraryPackage :: Predicate
+libraryPackage = isLibrary <$> getPackage
diff --git a/src/Flavour.hs b/src/Flavour.hs
new file mode 100644 (file)
index 0000000..fcbbb70
--- /dev/null
@@ -0,0 +1,34 @@
+module Flavour (Flavour (..)) where
+
+import Expression
+
+-- Please update doc/{flavours.md, user-settings.md} when changing this file.
+-- | 'Flavour' is a collection of build settings that fully define a GHC build.
+-- Note the following type semantics:
+-- * @Bool@: a plain Boolean flag whose value is known at compile time.
+-- * @Action Bool@: a flag whose value can depend on the build environment.
+-- * @Predicate@: a flag whose value can depend on the build environment and
+-- on the current build target.
+data Flavour = Flavour {
+    -- | Flavour name, to select this flavour from command line.
+    name :: String,
+    -- | Use these command line arguments.
+    args :: Args,
+    -- | Build these packages.
+    packages :: Stage -> Action [Package],
+    -- | Either 'integerGmp' or 'integerSimple'.
+    integerLibrary :: Action Package,
+    -- | Build libraries these ways.
+    libraryWays :: Ways,
+    -- | Build RTS these ways.
+    rtsWays :: Ways,
+    -- | Build split objects.
+    splitObjects :: Predicate,
+    -- | Build dynamic GHC programs.
+    dynamicGhcPrograms :: Bool,
+    -- | Enable GHCi debugger.
+    ghciWithDebugger :: Bool,
+    -- | Build profiled GHC.
+    ghcProfiled :: Bool,
+    -- | Build GHC with debug information.
+    ghcDebugged :: Bool }
diff --git a/src/GHC.hs b/src/GHC.hs
new file mode 100644 (file)
index 0000000..baae940
--- /dev/null
@@ -0,0 +1,289 @@
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+module GHC (
+    -- * GHC packages
+    array, base, binary, bytestring, cabal, compareSizes, compiler, containers,
+    deepseq, deriveConstants, directory, filepath, genapply, genprimopcode, ghc,
+    ghcBoot, ghcBootTh, ghcCabal, ghcCompact, ghci, ghcPkg, ghcPrim, ghcTags,
+    ghcSplit, haddock, haskeline, hsc2hs, hp2ps, hpc, hpcBin, integerGmp,
+    integerSimple, iservBin, libffi, mtl, parsec, parallel, pretty, primitive,
+    process, rts, runGhc, stm, templateHaskell, terminfo, text, time, touchy,
+    transformers, unlit, unix, win32, xhtml, ghcPackages, isGhcPackage,
+    defaultPackages,
+
+    -- * Package information
+    programName, nonCabalContext, nonHsMainPackage, autogenPath, installStage,
+
+    -- * Miscellaneous
+    programPath, ghcSplitPath, stripCmdPath, buildDll0
+    ) where
+
+import Base
+import CommandLine
+import Context
+import Oracles.Flag
+import Oracles.Setting
+
+-- | These are all GHC packages we know about. Build rules will be generated for
+-- all of them. However, not all of these packages will be built. For example,
+-- package 'win32' is built only on Windows. 'defaultPackages' defines default
+-- conditions for building each package. Users can add their own packages and
+-- modify build default build conditions in "UserSettings".
+ghcPackages :: [Package]
+ghcPackages =
+    [ array, base, binary, bytestring, cabal, compareSizes, compiler, containers
+    , deepseq, deriveConstants, directory, filepath, genapply, genprimopcode
+    , ghc, ghcBoot, ghcBootTh, ghcCabal, ghcCompact, ghci, ghcPkg, ghcPrim
+    , ghcTags, haddock, haskeline, hsc2hs, hp2ps, hpc, hpcBin, integerGmp
+    , integerSimple, iservBin, libffi, mtl, parsec, parallel, pretty, primitive
+    , process, rts, runGhc, stm, templateHaskell, terminfo, text, time, touchy
+    , transformers, unlit, unix, win32, xhtml ]
+
+-- TODO: Optimise by switching to sets of packages.
+isGhcPackage :: Package -> Bool
+isGhcPackage = (`elem` ghcPackages)
+
+-- | Package definitions, see 'Package'.
+array               = hsLib  "array"
+base                = hsLib  "base"
+binary              = hsLib  "binary"
+bytestring          = hsLib  "bytestring"
+cabal               = hsLib  "Cabal"           `setPath` "libraries/Cabal/Cabal"
+compareSizes        = hsUtil "compareSizes"    `setPath` "utils/compare_sizes"
+compiler            = hsTop  "ghc"             `setPath` "compiler"
+containers          = hsLib  "containers"
+deepseq             = hsLib  "deepseq"
+deriveConstants     = hsUtil "deriveConstants"
+directory           = hsLib  "directory"
+filepath            = hsLib  "filepath"
+genapply            = hsUtil "genapply"
+genprimopcode       = hsUtil "genprimopcode"
+ghc                 = hsPrg  "ghc-bin"         `setPath` "ghc"
+ghcBoot             = hsLib  "ghc-boot"
+ghcBootTh           = hsLib  "ghc-boot-th"
+ghcCabal            = hsUtil "ghc-cabal"
+ghcCompact          = hsLib  "ghc-compact"
+ghci                = hsLib  "ghci"
+ghcPkg              = hsUtil "ghc-pkg"
+ghcPrim             = hsLib  "ghc-prim"
+ghcTags             = hsUtil "ghctags"
+ghcSplit            = hsUtil "ghc-split"
+haddock             = hsUtil "haddock"
+haskeline           = hsLib  "haskeline"
+hsc2hs              = hsUtil "hsc2hs"
+hp2ps               = cUtil  "hp2ps"
+hpc                 = hsLib  "hpc"
+hpcBin              = hsUtil "hpc-bin"         `setPath` "utils/hpc"
+integerGmp          = hsLib  "integer-gmp"
+integerSimple       = hsLib  "integer-simple"
+iservBin            = hsPrg  "iserv-bin"       `setPath` "iserv"
+libffi              = cTop   "libffi"
+mtl                 = hsLib  "mtl"
+parsec              = hsLib  "parsec"
+parallel            = hsLib  "parallel"
+pretty              = hsLib  "pretty"
+primitive           = hsLib  "primitive"
+process             = hsLib  "process"
+rts                 = cTop   "rts"
+runGhc              = hsUtil "runghc"
+stm                 = hsLib  "stm"
+templateHaskell     = hsLib  "template-haskell"
+terminfo            = hsLib  "terminfo"
+text                = hsLib  "text"
+time                = hsLib  "time"
+touchy              = cUtil  "touchy"
+transformers        = hsLib  "transformers"
+unlit               = cUtil  "unlit"
+unix                = hsLib  "unix"
+win32               = hsLib  "Win32"
+xhtml               = hsLib  "xhtml"
+
+-- | Construct a Haskell library package, e.g. @array@.
+hsLib :: PackageName -> Package
+hsLib name = hsLibrary name ("libraries" -/- name)
+
+-- | Construct a top-level Haskell library package, e.g. @compiler@.
+hsTop :: PackageName -> Package
+hsTop name = hsLibrary name name
+
+-- | Construct a top-level C library package, e.g. @rts@.
+cTop :: PackageName -> Package
+cTop name = cLibrary name name
+
+-- | Construct a top-level Haskell program package, e.g. @ghc@.
+hsPrg :: PackageName -> Package
+hsPrg name = hsProgram name name
+
+-- | Construct a Haskell utility package, e.g. @haddock@.
+hsUtil :: PackageName -> Package
+hsUtil name = hsProgram name ("utils" -/- name)
+
+-- | Construct a C utility package, e.g. @haddock@.
+cUtil :: PackageName -> Package
+cUtil name = cProgram name ("utils" -/- name)
+
+-- | Amend a package path if it doesn't conform to a typical pattern.
+setPath :: Package -> FilePath -> Package
+setPath pkg path = pkg { pkgPath = path }
+
+-- | Packages that are built by default. You can change this in "UserSettings".
+defaultPackages :: Stage -> Action [Package]
+defaultPackages Stage0 = stage0Packages
+defaultPackages Stage1 = stage1Packages
+defaultPackages Stage2 = stage2Packages
+defaultPackages Stage3 = return []
+
+stage0Packages :: Action [Package]
+stage0Packages = do
+    win <- windowsHost
+    ios <- iosHost
+    cross <- crossCompiling
+    return $ [ binary
+             , cabal
+             , compareSizes
+             , compiler
+             , deriveConstants
+             , genapply
+             , genprimopcode
+             , ghc
+             , ghcBoot
+             , ghcBootTh
+             , ghcCabal
+             , ghci
+             , ghcPkg
+             , ghcTags
+             , hsc2hs
+             , hp2ps
+             , hpc
+             , mtl
+             , parsec
+             , templateHaskell
+             , text
+             , transformers
+             , unlit                       ]
+          ++ [ terminfo | not win, not ios, not cross ]
+          ++ [ touchy   | win              ]
+
+stage1Packages :: Action [Package]
+stage1Packages = do
+    win        <- windowsHost
+    intSimple  <- cmdIntegerSimple
+    libraries0 <- filter isLibrary <$> stage0Packages
+    return $ libraries0 -- Build all Stage0 libraries in Stage1
+          ++ [ array
+             , base
+             , bytestring
+             , containers
+             , deepseq
+             , directory
+             , filepath
+             , ghc
+             , ghcCabal
+             , ghcCompact
+             , ghcPrim
+             , haskeline
+             , hpcBin
+             , hsc2hs
+             , if intSimple then integerSimple else integerGmp
+             , pretty
+             , process
+             , rts
+             , runGhc
+             , stm
+             , time
+             , xhtml              ]
+          ++ [ iservBin | not win ]
+          ++ [ unix     | not win ]
+          ++ [ win32    | win     ]
+
+stage2Packages :: Action [Package]
+stage2Packages = return [haddock]
+
+-- | Given a 'Context', compute the name of the program that is built in it
+-- assuming that the corresponding package's type is 'Program'. For example, GHC
+-- built in 'Stage0' is called @ghc-stage1@. If the given package is a
+-- 'Library', the function simply returns its name.
+programName :: Context -> String
+programName Context {..}
+    | package == ghc      = "ghc-stage" ++ show (fromEnum stage + 1)
+    | package == hpcBin   = "hpc"
+    | package == runGhc   = "runhaskell"
+    | package == iservBin = "ghc-iserv"
+    | otherwise           = pkgName package
+
+-- | The build stage whose results are used when installing a package, or
+-- @Nothing@ if the package is not installed, e.g. because it is a user package.
+-- The current implementation installs the /latest/ build stage of a package.
+installStage :: Package -> Action (Maybe Stage)
+installStage pkg
+    | not (isGhcPackage pkg) = return Nothing -- Only GHC packages are installed
+    | otherwise = do
+        stages <- filterM (fmap (pkg `elem`) . defaultPackages) [Stage0 ..]
+        return $ if null stages then Nothing else Just (maximum stages)
+
+-- | Is the program corresponding to a given context built 'inplace', i.e. in
+-- the @inplace/bin@ directory? For most programs, only their /latest/ build
+-- stages are built 'inplace'. The only exception is the GHC itself, which is
+-- built 'inplace' in all stages. The function returns @False@ for libraries and
+-- all user packages.
+isBuiltInplace :: Context -> Action Bool
+isBuiltInplace Context {..}
+    | isLibrary package          = return False
+    | not (isGhcPackage package) = return False
+    | package == ghc             = return True
+    | otherwise                  = (Just stage ==) <$> installStage package
+
+-- | The 'FilePath' to a program executable in a given 'Context'.
+programPath :: Context -> Action FilePath
+programPath context@Context {..} = do
+    path    <- buildPath context
+    inplace <- isBuiltInplace context
+    let contextPath = if inplace then inplacePath else path
+    return $ contextPath -/- programName context <.> exe
+  where
+    inplacePath | package `elem` [touchy, unlit, iservBin] = inplaceLibBinPath
+                | otherwise                                = inplaceBinPath
+
+-- | Some contexts are special: their packages do not have @.cabal@ metadata or
+-- we cannot run @ghc-cabal@ on them, e.g. because the latter hasn't been built
+-- yet (this is the case with the 'ghcCabal' package in 'Stage0').
+nonCabalContext :: Context -> Bool
+nonCabalContext Context {..} = (package `elem` [hp2ps, rts, touchy, unlit])
+    || package == ghcCabal && stage == Stage0
+
+-- | Some program packages should not be linked with Haskell main function.
+nonHsMainPackage :: Package -> Bool
+nonHsMainPackage = (`elem` [ghc, hp2ps, iservBin, touchy, unlit])
+
+-- | Path to the autogen directory generated by @ghc-cabal@ of a given 'Context'.
+autogenPath :: Context -> Action FilePath
+autogenPath context@Context {..}
+    | isLibrary package   = autogen "build"
+    | package == ghc      = autogen "build/ghc"
+    | package == hpcBin   = autogen "build/hpc"
+    | package == iservBin = autogen "build/iserv"
+    | otherwise           = autogen $ "build" -/- pkgName package
+  where
+    autogen dir = buildPath context <&> (-/- dir -/- "autogen")
+
+-- | @ghc-split@ is a Perl script used by GHC with @-split-objs@ flag. It is
+-- generated in "Rules.Generators.GhcSplit".
+ghcSplitPath :: FilePath
+ghcSplitPath = inplaceLibBinPath -/- "ghc-split"
+
+-- ref: mk/config.mk
+-- | Command line tool for stripping.
+stripCmdPath :: Action FilePath
+stripCmdPath = do
+    targetPlatform <- setting TargetPlatform
+    top <- topDirectory
+    case targetPlatform of
+        "x86_64-unknown-mingw32" ->
+             return (top -/- "inplace/mingw/bin/strip.exe")
+        "arm-unknown-linux" ->
+             return ":" -- HACK: from the make-based system, see the ref above
+        _ -> return "strip"
+
+buildDll0 :: Context -> Action Bool
+buildDll0 Context {..} = do
+    windows <- windowsHost
+    return $ windows && stage == Stage1 && package == compiler
diff --git a/src/Hadrian/Builder.hs b/src/Hadrian/Builder.hs
new file mode 100644 (file)
index 0000000..4de658e
--- /dev/null
@@ -0,0 +1,125 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module     : Hadrian.Builder
+-- Copyright  : (c) Andrey Mokhov 2014-2017
+-- License    : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability  : experimental
+--
+-- A typical build system invokes several build tools, or /builders/, such as
+-- compilers, linkers, etc., some of which may be built by the build system
+-- itself. This module defines the 'Builder' type class and a few associated
+-- functions that can be used to invoke builders.
+-----------------------------------------------------------------------------
+module Hadrian.Builder (
+    Builder (..), BuildInfo (..), runBuilder, runBuilderWithCmdOptions,
+    build, buildWithResources, buildWithCmdOptions, getBuilderPath,
+    builderEnvironment
+    ) where
+
+import Data.List
+import Development.Shake
+
+import Hadrian.Expression hiding (inputs, outputs)
+import Hadrian.Oracles.ArgsHash
+import Hadrian.Target
+import Hadrian.Utilities
+
+-- | This data structure captures all information relevant to invoking a builder.
+data BuildInfo = BuildInfo {
+    -- | Command line arguments.
+    buildArgs :: [String],
+    -- | Input files.
+    buildInputs :: [FilePath],
+    -- | Output files.
+    buildOutputs :: [FilePath],
+    -- | Options to be passed to Shake's 'cmd' function.
+    buildOptions :: [CmdOption],
+    -- | Resources to be aquired.
+    buildResources :: [(Resource, Int)] }
+
+class ShakeValue b => Builder b where
+    -- | The path to a builder.
+    builderPath :: b -> Action FilePath
+
+    -- | Make sure a builder exists and rebuild it if out of date.
+    needBuilder :: b -> Action ()
+    needBuilder builder = do
+        path <- builderPath builder
+        need [path]
+
+    -- | Run a builder with a given 'BuildInfo'. Also see 'runBuilder'.
+    runBuilderWith :: b -> BuildInfo -> Action ()
+    runBuilderWith builder buildInfo = do
+        let args = buildArgs buildInfo
+        needBuilder builder
+        path <- builderPath builder
+        let msg = if null args then "" else " (" ++ intercalate ", " args ++ ")"
+        putBuild $ "| Run " ++ show builder ++ msg
+        quietly $ cmd (buildOptions buildInfo) [path] args
+
+-- | Run a builder with a specified list of command line arguments, reading a
+-- list of input files and writing a list of output files. A lightweight version
+-- of 'runBuilderWith'.
+runBuilder :: Builder b => b -> [String] -> [FilePath] -> [FilePath] -> Action ()
+runBuilder = runBuilderWithCmdOptions []
+
+-- | Like 'runBuilder' but passes given options to Shake's 'cmd'.
+runBuilderWithCmdOptions :: Builder b => [CmdOption] -> b -> [String] -> [FilePath] -> [FilePath] -> Action ()
+runBuilderWithCmdOptions opts builder args inputs outputs =
+    runBuilderWith builder $ BuildInfo { buildArgs      = args
+                                       , buildInputs    = inputs
+                                       , buildOutputs   = outputs
+                                       , buildOptions   = opts
+                                       , buildResources = [] }
+
+-- | Build a 'Target' using the list of command line arguments computed from a
+-- given 'Args' expression. Force a rebuild if the argument list has changed
+-- since the last build.
+build :: (Builder b, ShakeValue c) => Target c b -> Args c b -> Action ()
+build = buildWith [] []
+
+-- | Like 'build' but acquires necessary resources.
+buildWithResources :: (Builder b, ShakeValue c) => [(Resource, Int)] -> Target c b -> Args c b -> Action ()
+buildWithResources rs = buildWith rs []
+
+-- | Like 'build' but passes given options to Shake's 'cmd'.
+buildWithCmdOptions :: (Builder b, ShakeValue c) => [CmdOption] -> Target c b -> Args c b -> Action ()
+buildWithCmdOptions = buildWith []
+
+buildWith :: (Builder b, ShakeValue c) => [(Resource, Int)] -> [CmdOption] -> Target c b -> Args c b -> Action ()
+buildWith rs opts target args = do
+    needBuilder (builder target)
+    argList <- interpret target args
+    trackArgsHash target -- Rerun the rule if the hash of argList has changed.
+    putInfo target
+    verbose <- interpret target verboseCommand
+    let quietlyUnlessVerbose = if verbose then withVerbosity Loud else quietly
+    quietlyUnlessVerbose $ runBuilderWith (builder target) $
+        BuildInfo { buildArgs      = argList
+                  , buildInputs    = inputs target
+                  , buildOutputs   = outputs target
+                  , buildOptions   = opts
+                  , buildResources = rs }
+
+-- | Print out information about the command being executed.
+putInfo :: Show b => Target c b -> Action ()
+putInfo t = putProgressInfo =<< renderAction
+    ("Run " ++ show (builder t)) -- TODO: Bring back contextInfo.
+    (digest $ inputs  t)
+    (digest $ outputs t)
+  where
+    digest [] = "none"
+    digest [x] = x
+    digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"
+
+-- | Get the path to the current builder.
+getBuilderPath :: Builder b => b -> Expr c b FilePath
+getBuilderPath = expr . builderPath
+
+-- | Write a builder path into a given environment variable.
+builderEnvironment :: Builder b => String -> b -> Action CmdOption
+builderEnvironment variable builder = do
+    needBuilder builder
+    path <- builderPath builder
+    return $ AddEnv variable path
diff --git a/src/Hadrian/Builder/Ar.hs b/src/Hadrian/Builder/Ar.hs
new file mode 100644 (file)
index 0000000..ad74653
--- /dev/null
@@ -0,0 +1,68 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module     : Hadrian.Builder.Ar
+-- Copyright  : (c) Andrey Mokhov 2014-2017
+-- License    : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability  : experimental
+--
+-- Support for invoking the archiving utility @ar@. We take care not to exceed
+-- the limit on command line length, which differs across supported operating
+-- systems (see 'cmdLineLengthLimit'). We need to handle @ar@ in a special way
+-- because we sometimes archive __a lot__ of files (in the Cabal library, for
+-- example, command line length can reach 2MB!). To work around the limit on the
+-- command line length we pass the list of files to be archived via a temporary
+-- file (see 'runAr'), or alternatively, we split the argument list into chunks
+-- and call @ar@ multiple times, e.g. when passing arguments via a temporary
+-- file is not supported (see 'runArWithoutTempFile').
+-----------------------------------------------------------------------------
+module Hadrian.Builder.Ar (ArMode (..), args, runAr, runArWithoutTempFile) where
+
+import Control.Monad
+import Development.Shake
+import Development.Shake.Classes
+import GHC.Generics
+import Hadrian.Expression
+import Hadrian.Utilities
+
+-- | We support packing and unpacking archives with @ar@.
+data ArMode = Pack | Unpack deriving (Eq, Generic, Show)
+
+instance Binary   ArMode
+instance Hashable ArMode
+instance NFData   ArMode
+
+-- NOTE: Make sure to appropriately update 'arFlagsCount' when changing 'args'.
+-- | Default command line arguments for invoking the archiving utility @ar@.
+args :: (ShakeValue c, ShakeValue b) => ArMode -> Args c b
+args Pack   = mconcat [ arg "q", arg =<< getOutput, getInputs ]
+args Unpack = mconcat [ arg "x", arg =<< getInput ]
+
+-- This count includes "q" and the output file argumentes in 'args'. This is
+-- only relevant for the 'Pack' @ar@ mode.
+arFlagsCount :: Int
+arFlagsCount = 2
+
+-- | Invoke @ar@ given a path to it and a list of arguments. The list of files
+-- to be archived is passed via a temporary file. Passing arguments via a
+-- temporary file is not supported by some versions of @ar@, in which case you
+-- should use 'runArWithoutTempFile' instead.
+runAr :: FilePath -> [String] -> Action ()
+runAr arPath argList = withTempFile $ \tmp -> do
+    writeFile' tmp $ unwords fileArgs
+    cmd [arPath] flagArgs ('@' : tmp)
+  where
+    flagArgs = take arFlagsCount argList
+    fileArgs = drop arFlagsCount argList
+
+-- | Invoke @ar@ given a path to it and a list of arguments. Note that @ar@
+-- will be called multiple times if the list of files to be archived is too
+-- long and doesn't fit into the command line length limit. This function is
+-- typically much slower than 'runAr'.
+runArWithoutTempFile :: FilePath -> [String] -> Action ()
+runArWithoutTempFile arPath argList =
+    forM_ (chunksOfSize cmdLineLengthLimit fileArgs) $ \argsChunk ->
+        unit . cmd [arPath] $ flagArgs ++ argsChunk
+  where
+    flagArgs = take arFlagsCount argList
+    fileArgs = drop arFlagsCount argList
diff --git a/src/Hadrian/Builder/Sphinx.hs b/src/Hadrian/Builder/Sphinx.hs
new file mode 100644 (file)
index 0000000..44b522c
--- /dev/null
@@ -0,0 +1,39 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module     : Hadrian.Builder.Sphinx
+-- Copyright  : (c) Andrey Mokhov 2014-2017
+-- License    : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability  : experimental
+--
+-- Support for invoking the documentation utility Sphinx.
+-----------------------------------------------------------------------------
+module Hadrian.Builder.Sphinx (SphinxMode (..), args) where
+
+import Development.Shake
+import Development.Shake.Classes
+import GHC.Generics
+import Hadrian.Expression
+import Hadrian.Utilities
+
+-- | Sphinx can be used in three different modes to convert reStructuredText
+-- documents into HTML, LaTeX or Man pages.
+data SphinxMode = Html | Latex | Man deriving (Eq, Generic, Show)
+
+instance Binary   SphinxMode
+instance Hashable SphinxMode
+instance NFData   SphinxMode
+
+-- | Default command line arguments for invoking the archiving utility @tar@.
+args :: (ShakeValue c, ShakeValue b) => SphinxMode -> Args c b
+args mode = do
+    outPath <- getOutput
+    mconcat [ arg "-b", arg modeString
+            , arg "-d", arg $ outPath -/- (".doctrees-" ++ modeString)
+            , arg =<< getInput
+            , arg outPath ]
+  where
+    modeString = case mode of
+        Html  -> "html"
+        Latex -> "latex"
+        Man   -> "man"
diff --git a/src/Hadrian/Builder/Tar.hs b/src/Hadrian/Builder/Tar.hs
new file mode 100644 (file)
index 0000000..d51e3c7
--- /dev/null
@@ -0,0 +1,40 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module     : Hadrian.Builder.Tar
+-- Copyright  : (c) Andrey Mokhov 2014-2017
+-- License    : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability  : experimental
+--
+-- Support for invoking the archiving utility @tar@.
+-----------------------------------------------------------------------------
+module Hadrian.Builder.Tar (TarMode (..), args) where
+
+import Development.Shake
+import Development.Shake.Classes
+import GHC.Generics
+import Hadrian.Expression
+
+-- | Tar can be used to 'Create' an archive or 'Extract' from it.
+data TarMode = Create | Extract deriving (Eq, Generic, Show)
+
+instance Binary   TarMode
+instance Hashable TarMode
+instance NFData   TarMode
+
+-- | Default command line arguments for invoking the archiving utility @tar@.
+args :: (ShakeValue c, ShakeValue b) => TarMode -> Args c b
+args Create = mconcat
+    [ arg "-c"
+    , output "//*.gz"  ? arg "--gzip"
+    , output "//*.bz2" ? arg "--bzip2"
+    , output "//*.xz"  ? arg "--xz"
+    , arg "-f", arg =<< getOutput
+    , getInputs ]
+args Extract = mconcat
+    [ arg "-x"
+    , input "*.gz"  ? arg "--gzip"
+    , input "*.bz2" ? arg "--bzip2"
+    , input "*.xz"  ? arg "--xz"
+    , arg "-f", arg =<< getInput
+    , arg "-C", arg =<< getOutput ]
diff --git a/src/Hadrian/Expression.hs b/src/Hadrian/Expression.hs
new file mode 100644 (file)
index 0000000..e5c01f8
--- /dev/null
@@ -0,0 +1,153 @@
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}
+module Hadrian.Expression (
+    -- * Expressions
+    Expr, Predicate, Args,
+
+    -- ** Construction and modification
+    expr, exprIO, arg, remove,
+
+    -- ** Predicates
+    (?), input, inputs, output, outputs, VerboseCommand (..), verboseCommand,
+
+    -- ** Evaluation
+    interpret, interpretInContext,
+
+    -- * Convenient accessors
+    getBuildRoot, getContext, getBuilder, getOutputs, getInputs, getInput, getOutput
+    ) where
+
+import Control.Monad.Extra
+import Control.Monad.Trans
+import Control.Monad.Trans.Reader
+import Data.Semigroup
+import Development.Shake
+import Development.Shake.Classes
+
+import qualified Hadrian.Target as Target
+import Hadrian.Target (Target, target)
+import Hadrian.Utilities
+
+-- | '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 Bool c b where
+    toPredicate = pure
+
+instance ToPredicate p c b => ToPredicate (Action p) c b where
+    toPredicate = toPredicate . expr
+
+instance (c ~ c', b ~ b', ToPredicate p c' b') => ToPredicate (Expr c b p) c' b' where
+    toPredicate p = toPredicate =<< p
+
+-- | 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 directory of build results.
+getBuildRoot :: Expr c b FilePath
+getBuildRoot = expr buildRoot
+
+-- | Get the current build 'Context'.
+getContext :: Expr c b c
+getContext = Expr $ asks Target.context
+
+-- | Get the 'Builder' for the current 'Target'.
+getBuilder :: Expr c b b
+getBuilder = Expr $ asks Target.builder
+
+-- | Get the input files of the current 'Target'.
+getInputs :: Expr c b [FilePath]
+getInputs = Expr $ asks Target.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
+    fromSingleton ("Exactly one input file expected in " ++ show target) <$>
+        asks Target.inputs
+
+-- | Get the files produced by the current 'Target'.
+getOutputs :: Expr c b [FilePath]
+getOutputs = Expr $ asks Target.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
+    fromSingleton ("Exactly one output file expected in " ++ show target) <$>
+        asks Target.outputs
+
+-- | Does any of the input files match a given pattern?
+input :: FilePattern -> Predicate c b
+input f = any (f ?==) <$> getInputs
+
+-- | Does any of the input files match any of the given patterns?
+inputs :: [FilePattern] -> Predicate c b
+inputs = anyM input
+
+-- | Does any of the output files match a given pattern?
+output :: FilePattern -> Predicate c b
+output f = any (f ?==) <$> getOutputs
+
+-- | Does any of the output files match any of the given patterns?
+outputs :: [FilePattern] -> Predicate c b
+outputs = anyM output
+
+newtype VerboseCommand c b = VerboseCommand { predicate :: Predicate c b }
+    deriving Typeable
+
+verboseCommand :: (ShakeValue c, ShakeValue b) => Predicate c b
+verboseCommand = predicate =<< expr (userSetting . VerboseCommand $ return False)
diff --git a/src/Hadrian/Haskell/Cabal.hs b/src/Hadrian/Haskell/Cabal.hs
new file mode 100644 (file)
index 0000000..ab5f334
--- /dev/null
@@ -0,0 +1,44 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module     : Hadrian.Haskell.Cabal
+-- Copyright  : (c) Andrey Mokhov 2014-2017
+-- License    : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability  : experimental
+--
+-- Basic functionality for extracting Haskell package metadata stored in
+-- Cabal files.
+-----------------------------------------------------------------------------
+module Hadrian.Haskell.Cabal (
+    pkgVersion, pkgIdentifier, pkgDependencies, pkgSynopsis
+    ) where
+
+import Development.Shake
+
+import Hadrian.Haskell.Cabal.Parse
+import Hadrian.Package
+import Hadrian.Oracles.TextFile
+
+-- | Read a Cabal file and return the package version. The Cabal file is tracked.
+pkgVersion :: FilePath -> Action String
+pkgVersion cabalFile = version <$> readCabalFile cabalFile
+
+-- | Read a Cabal file and return the package identifier, e.g. @base-4.10.0.0@.
+-- The Cabal file is tracked.
+pkgIdentifier :: FilePath -> Action String
+pkgIdentifier cabalFile = do
+    cabal <- readCabalFile cabalFile
+    return $ if null (version cabal)
+        then name cabal
+        else name cabal ++ "-" ++ version cabal
+
+-- | Read a Cabal file and return the sorted list of the package dependencies.
+-- The current version does not take care of Cabal conditionals and therefore
+-- returns a crude overapproximation of actual dependencies. The Cabal file is
+-- tracked.
+pkgDependencies :: FilePath -> Action [PackageName]
+pkgDependencies cabalFile = dependencies <$> readCabalFile cabalFile
+
+-- | Read a Cabal file and return the package synopsis. The Cabal file is tracked.
+pkgSynopsis :: FilePath -> Action String
+pkgSynopsis cabalFile = synopsis <$> readCabalFile cabalFile
diff --git a/src/Hadrian/Haskell/Cabal/Parse.hs b/src/Hadrian/Haskell/Cabal/Parse.hs
new file mode 100644 (file)
index 0000000..578eeac
--- /dev/null
@@ -0,0 +1,63 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module     : Hadrian.Haskell.Cabal.Parse
+-- Copyright  : (c) Andrey Mokhov 2014-2017
+-- License    : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability  : experimental
+--
+-- Extracting Haskell package metadata stored in Cabal files.
+-----------------------------------------------------------------------------
+module Hadrian.Haskell.Cabal.Parse (Cabal (..), parseCabal) where
+
+import Data.List.Extra
+import Development.Shake
+import Development.Shake.Classes
+import qualified Distribution.Package                  as C
+import qualified Distribution.PackageDescription       as C
+import qualified Distribution.PackageDescription.Parse as C
+import qualified Distribution.Text                     as C
+import qualified Distribution.Types.CondTree           as C
+import qualified Distribution.Verbosity                as C
+
+import Hadrian.Package
+
+-- TODO: Use fine-grain tracking instead of tracking the whole Cabal file.
+-- | Haskell package metadata extracted from a Cabal file.
+data Cabal = Cabal
+    { dependencies :: [PackageName]
+    , name         :: PackageName
+    , synopsis     :: String
+    , version      :: String
+    } deriving (Eq, Read, Show, Typeable)
+
+instance Binary Cabal where
+    put = put . show
+    get = fmap read get
+
+instance Hashable Cabal where
+    hashWithSalt salt = hashWithSalt salt . show
+
+instance NFData Cabal where
+    rnf (Cabal a b c d) = a `seq` b `seq` c `seq` d `seq` ()
+
+-- | Parse a Cabal file.
+parseCabal :: FilePath -> IO Cabal
+parseCabal file = do
+    gpd <- liftIO $ C.readGenericPackageDescription C.silent file
+    let pd      = C.packageDescription gpd
+        pkgId   = C.package pd
+        name    = C.unPackageName (C.pkgName pkgId)
+        version = C.display (C.pkgVersion pkgId)
+        libDeps = collectDeps (C.condLibrary gpd)
+        exeDeps = map (collectDeps . Just . snd) (C.condExecutables gpd)
+        allDeps = concat (libDeps : exeDeps)
+        sorted  = sort [ C.unPackageName p | C.Dependency p _ <- allDeps ]
+        deps    = nubOrd sorted \\ [name]
+    return $ Cabal deps name (C.synopsis pd) version
+
+collectDeps :: Maybe (C.CondTree v [C.Dependency] a) -> [C.Dependency]
+collectDeps Nothing = []
+collectDeps (Just (C.CondNode _ deps ifs)) = deps ++ concatMap f ifs
+  where
+    f (C.CondBranch _ t mt) = collectDeps (Just t) ++ collectDeps mt
diff --git a/src/Hadrian/Oracles/ArgsHash.hs b/src/Hadrian/Oracles/ArgsHash.hs
new file mode 100644 (file)
index 0000000..bae2fdb
--- /dev/null
@@ -0,0 +1,51 @@
+{-# LANGUAGE TypeFamilies #-}
+module Hadrian.Oracles.ArgsHash (
+    TrackArgument, trackAllArguments, trackArgsHash, argsHashOracle
+    ) where
+
+import Control.Monad
+import Development.Shake
+import Development.Shake.Classes
+
+import Hadrian.Expression hiding (inputs, outputs)
+import Hadrian.Target
+
+-- | 'TrackArgument' is used to specify the arguments that should be tracked by
+-- the @ArgsHash@ oracle. The safest option is to track all arguments, but some
+-- arguments, such as @-jN@, do not change the build results, hence there is no
+-- need to initiate unnecessary rebuild if they are added to or removed from a
+-- command line. If all arguments should be tracked, use 'trackAllArguments'.
+type TrackArgument c b = Target c b -> String -> Bool
+
+-- | Returns 'True' for all targets and arguments, hence can be used a safe
+-- default for 'argsHashOracle'.
+trackAllArguments :: TrackArgument c b
+trackAllArguments _ _ = True
+
+-- | Given a 'Target' this 'Action' determines the corresponding argument list
+-- and computes its hash. The resulting value is tracked in a Shake oracle,
+-- hence initiating rebuilds when the hash changes (a hash change indicates
+-- changes in the build command for the given target).
+-- Note: for efficiency we replace the list of input files with its hash to
+-- avoid storing long lists of source files passed to some builders (e.g. ar)
+-- in the Shake database. This optimisation is normally harmless, because
+-- argument list constructors are assumed not to examine target sources, but
+-- only append them to argument lists where appropriate.
+trackArgsHash :: (ShakeValue c, ShakeValue b) => Target c b -> Action ()
+trackArgsHash t = do
+    let hashedInputs  = [ show $ hash (inputs t) ]
+        hashedTarget = target (context t) (builder t) hashedInputs (outputs t)
+    void (askOracle $ ArgsHash hashedTarget :: Action Int)
+
+newtype ArgsHash c b = ArgsHash (Target c b)
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult (ArgsHash c b) = Int
+
+-- | This oracle stores per-target argument list hashes in the Shake database,
+-- allowing the user to track them between builds using 'trackArgsHash' queries.
+argsHashOracle :: (ShakeValue c, ShakeValue b) => TrackArgument c b -> Args c b -> Rules ()
+argsHashOracle trackArgument args = void $
+    addOracle $ \(ArgsHash target) -> do
+        argList <- interpret target args
+        let trackedArgList = filter (trackArgument target) argList
+        return $ hash trackedArgList
diff --git a/src/Hadrian/Oracles/DirectoryContents.hs b/src/Hadrian/Oracles/DirectoryContents.hs
new file mode 100644 (file)
index 0000000..f302af9
--- /dev/null
@@ -0,0 +1,64 @@
+{-# LANGUAGE TypeFamilies #-}
+module Hadrian.Oracles.DirectoryContents (
+    directoryContents, copyDirectoryContents, directoryContentsOracle, copyDirectoryContentsUntracked,
+    Match (..), matches, matchAll
+    ) where
+
+import Control.Monad
+import Development.Shake
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import GHC.Generics
+
+import Hadrian.Utilities
+
+import qualified System.Directory.Extra as IO
+
+data Match = Test FilePattern | Not Match | And [Match] | Or [Match]
+    deriving (Generic, Eq, Show, Typeable)
+
+instance Binary   Match
+instance Hashable Match
+instance NFData   Match
+
+-- | A 'Match' expression that always evaluates to 'True' (i.e. always matches).
+matchAll :: Match
+matchAll = And []
+
+-- | Check if a file name matches a given 'Match' expression.
+matches :: Match -> FilePath -> Bool
+matches (Test p) f = p ?== f
+matches (Not  m) f = not $ matches m f
+matches (And ms) f = all (`matches` f) ms
+matches (Or  ms) f = any (`matches` f) ms
+
+-- | Given a 'Match' expression and a directory, recursively traverse it and all
+-- its subdirectories to find and return all matching contents.
+directoryContents :: Match -> FilePath -> Action [FilePath]
+directoryContents expr dir = askOracle $ DirectoryContents (expr, dir)
+
+-- | Copy the contents of the source directory that matches a given 'Match'
+-- expression into the target directory. The copied contents is tracked.
+copyDirectoryContents :: Match -> FilePath -> FilePath -> Action ()
+copyDirectoryContents expr source target = do
+    putProgressInfo =<< renderAction "Copy directory contents" source target
+    let cp file = copyFile file $ target -/- makeRelative source file
+    mapM_ cp =<< directoryContents expr source
+
+-- | Copy the contents of the source directory that matches a given 'Match'
+-- expression into the target directory. The copied contents is untracked.
+copyDirectoryContentsUntracked :: Match -> FilePath -> FilePath -> Action ()
+copyDirectoryContentsUntracked expr source target = do
+    putProgressInfo =<< renderAction "Copy directory contents (untracked)" source target
+    let cp file = copyFileUntracked file $ target -/- makeRelative source file
+    mapM_ cp =<< directoryContents expr source
+
+newtype DirectoryContents = DirectoryContents (Match, FilePath)
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult DirectoryContents = [FilePath]
+
+-- | This oracle answers 'directoryContents' queries and tracks the results.
+directoryContentsOracle :: Rules ()
+directoryContentsOracle = void $
+    addOracle $ \(DirectoryContents (expr, dir)) -> liftIO $ map unifyPath .
+        filter (matches expr) <$> IO.listFilesInside (return . matches expr) dir
diff --git a/src/Hadrian/Oracles/Path.hs b/src/Hadrian/Oracles/Path.hs
new file mode 100644 (file)
index 0000000..ceccc23
--- /dev/null
@@ -0,0 +1,62 @@
+{-# LANGUAGE TypeFamilies #-}
+module Hadrian.Oracles.Path (
+    lookupInPath, bashPath, fixAbsolutePathOnWindows, pathOracle
+    ) where
+
+import Control.Monad
+import Data.Maybe
+import Data.Char
+import Data.List.Extra
+import Development.Shake
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import System.Directory
+import System.Info.Extra
+
+import Hadrian.Utilities
+
+-- | Lookup a specified 'FilePath' in the system @PATH@.
+lookupInPath :: FilePath -> Action FilePath
+lookupInPath name
+    | name == takeFileName name = askOracle $ LookupInPath name
+    | otherwise                 = return name
+
+-- | Lookup the path to the @bash@ interpreter.
+bashPath :: Action FilePath
+bashPath = lookupInPath "bash"
+
+-- | Fix an absolute path on Windows:
+-- * "/c/" => "C:/"
+-- * "/usr/bin/tar.exe" => "C:/msys/usr/bin/tar.exe"
+fixAbsolutePathOnWindows :: FilePath -> Action FilePath
+fixAbsolutePathOnWindows path =
+    if isWindows
+    then do
+        let (dir, file) = splitFileName path
+        winDir <- askOracle $ WindowsPath dir
+        return $ winDir -/- file
+    else
+        return path
+
+newtype LookupInPath = LookupInPath String
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult LookupInPath = String
+
+newtype WindowsPath = WindowsPath FilePath
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult WindowsPath = String
+
+-- | Oracles for looking up paths. These are slow and require caching.
+pathOracle :: Rules ()
+pathOracle = do
+    void $ addOracle $ \(WindowsPath path) -> do
+        Stdout out <- quietly $ cmd ["cygpath", "-m", path]
+        let windowsPath = unifyPath $ dropWhileEnd isSpace out
+        putLoud $ "| Windows path mapping: " ++ path ++ " => " ++ windowsPath
+        return windowsPath
+
+    void $ addOracle $ \(LookupInPath name) -> do
+        let unpack = fromMaybe . error $ "Cannot find executable " ++ quote name
+        path <- unifyPath . unpack <$> liftIO (findExecutable name)
+        putLoud $ "| Executable found: " ++ name ++ " => " ++ path
+        return path
diff --git a/src/Hadrian/Oracles/TextFile.hs b/src/Hadrian/Oracles/TextFile.hs
new file mode 100644 (file)
index 0000000..6d4f048
--- /dev/null
@@ -0,0 +1,123 @@
+{-# LANGUAGE TypeFamilies #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module     : Hadrian.Oracles.TextFile
+-- Copyright  : (c) Andrey Mokhov 2014-2017
+-- License    : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability  : experimental
+--
+-- Read and parse text files, tracking their contents. This oracle can be used
+-- to read configuration or package metadata files and cache the parsing.
+-----------------------------------------------------------------------------
+module Hadrian.Oracles.TextFile (
+    readTextFile, lookupValue, lookupValueOrEmpty, lookupValueOrError,
+    lookupValues, lookupValuesOrEmpty, lookupValuesOrError, lookupDependencies,
+    readCabalFile, textFileOracle
+    ) where
+
+import Control.Monad
+import qualified Data.HashMap.Strict as Map
+import Data.Maybe
+import Development.Shake
+import Development.Shake.Classes
+import Development.Shake.Config
+
+import Hadrian.Haskell.Cabal.Parse
+import Hadrian.Utilities
+
+newtype TextFile = TextFile FilePath
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult TextFile = String
+
+newtype CabalFile = CabalFile FilePath
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult CabalFile = Cabal
+
+newtype KeyValue = KeyValue (FilePath, String)
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult KeyValue = Maybe String
+
+newtype KeyValues = KeyValues (FilePath, String)
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult KeyValues = Maybe [String]
+
+-- | Read a text file, caching and tracking the result. To read and track
+-- individual lines of a text file use 'lookupValue' and its derivatives.
+readTextFile :: FilePath -> Action String
+readTextFile = askOracle . TextFile
+
+-- | Lookup a value in a text file, tracking the result. Each line of the file
+-- is expected to have @key = value@ format.
+lookupValue :: FilePath -> String -> Action (Maybe String)
+lookupValue file key = askOracle $ KeyValue (file, key)
+
+-- | Like 'lookupValue' but returns the empty string if the key is not found.
+lookupValueOrEmpty :: FilePath -> String -> Action String
+lookupValueOrEmpty file key = fromMaybe "" <$> lookupValue file key
+
+-- | Like 'lookupValue' but raises an error if the key is not found.
+lookupValueOrError :: FilePath -> String -> Action String
+lookupValueOrError file key = fromMaybe (error msg) <$> lookupValue file key
+  where
+    msg = "Key " ++ quote key ++ " not found in file " ++ quote file
+
+-- | Lookup a list of values in a text file, tracking the result. Each line of
+-- the file is expected to have @key value1 value2 ...@ format.
+lookupValues :: FilePath -> String -> Action (Maybe [String])
+lookupValues file key = askOracle $ KeyValues (file, key)
+
+-- | Like 'lookupValues' but returns the empty list if the key is not found.
+lookupValuesOrEmpty :: FilePath -> String -> Action [String]
+lookupValuesOrEmpty file key = fromMaybe [] <$> lookupValues file key
+
+-- | Like 'lookupValues' but raises an error if the key is not found.
+lookupValuesOrError :: FilePath -> String -> Action [String]
+lookupValuesOrError file key = fromMaybe (error msg) <$> lookupValues file key
+  where
+    msg = "Key " ++ quote key ++ " not found in file " ++ quote file
+
+-- | The 'Action' @lookupDependencies depFile file@ looks up dependencies of a
+-- @file@ in a (typically generated) dependency file @depFile@. The action
+-- returns a pair @(source, files)@, such that the @file@ can be produced by
+-- compiling @source@, which in turn also depends on a number of other @files@.
+lookupDependencies :: FilePath -> FilePath -> Action (FilePath, [FilePath])
+lookupDependencies depFile file = do
+    deps <- lookupValues depFile file
+    case deps of
+        Nothing -> error $ "No dependencies found for file " ++ quote file
+        Just [] -> error $ "No source file found for file " ++ quote file
+        Just (source : files) -> return (source, files)
+
+-- | Read and parse a @.cabal@ file, caching and tracking the result.
+readCabalFile :: FilePath -> Action Cabal
+readCabalFile = askOracle . CabalFile
+
+-- | This oracle reads and parses text files to answer 'readTextFile' and
+-- 'lookupValue' queries, as well as their derivatives, tracking the results.
+textFileOracle :: Rules ()
+textFileOracle = do
+    text <- newCache $ \file -> do
+        need [file]
+        putLoud $ "| TextFile oracle: reading " ++ quote file ++ "..."
+        liftIO $ readFile file
+    void $ addOracle $ \(TextFile file) -> text file
+
+    kv <- newCache $ \file -> do
+        need [file]
+        putLoud $ "| KeyValue oracle: reading " ++ quote file ++ "..."
+        liftIO $ readConfigFile file
+    void $ addOracle $ \(KeyValue (file, key)) -> Map.lookup key <$> kv file
+
+    kvs <- newCache $ \file -> do
+        need [file]
+        putLoud $ "| KeyValues oracle: reading " ++ quote file ++ "..."
+        contents <- map words <$> readFileLines file
+        return $ Map.fromList [ (key, values) | (key:values) <- contents ]
+    void $ addOracle $ \(KeyValues (file, key)) -> Map.lookup key <$> kvs file
+
+    cabal <- newCache $ \file -> do
+        need [file]
+        putLoud $ "| CabalFile oracle: reading " ++ quote file ++ "..."
+        liftIO $ parseCabal file
+    void $ addOracle $ \(CabalFile file) -> cabal file
diff --git a/src/Hadrian/Package.hs b/src/Hadrian/Package.hs
new file mode 100644 (file)
index 0000000..11a6998
--- /dev/null
@@ -0,0 +1,120 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module     : Hadrian.Package
+-- Copyright  : (c) Andrey Mokhov 2014-2017
+-- License    : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability  : experimental
+--
+-- A /package/ is a collection of files. We currently only support C and Haskell
+-- packages and treat a package as either a library or a program. The latter is
+-- a gross oversimplification as, for example, Haskell packages can be both.
+-- This works for now, but should be improved in future.
+-----------------------------------------------------------------------------
+module Hadrian.Package (
+    -- * Data types
+    Package (..), PackageName, PackageLanguage, PackageType,
+
+    -- * Construction and properties
+    cLibrary, cProgram, hsLibrary, hsProgram,
+    isLibrary, isProgram, isCPackage, isHsPackage,
+
+    -- * Package directory structure
+    pkgCabalFile, unsafePkgCabalFile
+    ) where
+
+import Data.Maybe
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import GHC.Generics
+import GHC.Stack
+import Hadrian.Utilities
+
+data PackageLanguage = C | Haskell deriving (Generic, Show)
+
+-- TODO: Make PackageType more precise.
+-- See https://github.com/snowleopard/hadrian/issues/12.
+data PackageType = Library | Program deriving (Generic, Show)
+
+type PackageName = String
+
+-- TODO: Consider turning Package into a GADT indexed with language and type.
+data Package = Package {
+    -- | The package language. 'C' and 'Haskell' packages are supported.
+    pkgLanguage :: PackageLanguage,
+    -- | The package type. 'Library' and 'Program' packages are supported.
+    pkgType :: PackageType,
+    -- | The package name. We assume that all packages have different names,
+    -- hence two packages with the same name are considered equal.
+    pkgName :: PackageName,
+    -- | The path to the package source code relative to the root of the build
+    -- system. For example, @libraries/Cabal/Cabal@ and @ghc@ are paths to the
+    -- @Cabal@ and @ghc-bin@ packages in GHC.
+    pkgPath :: FilePath
+    } deriving (Generic, Show)
+
+instance Eq Package where
+    p == q = pkgName p == pkgName q
+
+instance Ord Package where
+    compare p q = compare (pkgName p) (pkgName q)
+
+instance Binary   PackageLanguage
+instance Hashable PackageLanguage
+instance NFData   PackageLanguage
+
+instance Binary   PackageType
+instance Hashable PackageType
+instance NFData   PackageType
+
+instance Binary   Package
+instance Hashable Package
+instance NFData   Package
+
+-- | Construct a C library package.
+cLibrary :: PackageName -> FilePath -> Package
+cLibrary = Package C Library
+
+-- | Construct a C program package.
+cProgram :: PackageName -> FilePath -> Package
+cProgram = Package C Program
+
+-- | Construct a Haskell library package.
+hsLibrary :: PackageName -> FilePath -> Package
+hsLibrary = Package Haskell Library
+
+-- | Construct a Haskell program package.
+hsProgram :: PackageName -> FilePath -> Package
+hsProgram = Package Haskell Program
+
+-- | Is this a library package?
+isLibrary :: Package -> Bool
+isLibrary (Package _ Library _ _) = True
+isLibrary _ = False
+
+-- | Is this a program package?
+isProgram :: Package -> Bool
+isProgram (Package _ Program _ _) = True
+isProgram _ = False
+
+-- | Is this a C package?
+isCPackage :: Package -> Bool
+isCPackage (Package C _ _ _) = True
+isCPackage _ = False
+
+-- | Is this a Haskell package?
+isHsPackage :: Package -> Bool
+isHsPackage (Package Haskell _ _ _) = True
+isHsPackage _ = False
+
+-- | The path to the Cabal file of a Haskell package, e.g. @ghc/ghc-bin.cabal@,
+-- or @Nothing@ if the argument is not a Haskell package.
+pkgCabalFile :: Package -> Maybe FilePath
+pkgCabalFile p | isHsPackage p = Just $ pkgPath p -/- pkgName p <.> "cabal"
+               | otherwise     = Nothing
+
+-- | Like 'pkgCabalFile' but raises an error on a non-Haskell package.
+unsafePkgCabalFile :: HasCallStack => Package -> FilePath
+unsafePkgCabalFile p = fromMaybe (error msg) (pkgCabalFile p)
+  where
+    msg = "[unsafePkgCabalFile] Not a Haskell package: " ++ show p
diff --git a/src/Hadrian/Target.hs b/src/Hadrian/Target.hs
new file mode 100644 (file)
index 0000000..8848977
--- /dev/null
@@ -0,0 +1,29 @@
+module Hadrian.Target (Target, target, context, builder, inputs, outputs) where
+
+import Development.Shake.Classes
+import GHC.Generics
+
+-- | 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)
diff --git a/src/Hadrian/Utilities.hs b/src/Hadrian/Utilities.hs
new file mode 100644 (file)
index 0000000..1cd22b1
--- /dev/null
@@ -0,0 +1,406 @@
+{-# LANGUAGE TypeFamilies #-}
+module Hadrian.Utilities (
+    -- * List manipulation
+    fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize,
+
+    -- * String manipulation
+    quote, yesNo,
+
+    -- * FilePath manipulation
+    unifyPath, (-/-),
+
+    -- * Accessing Shake's type-indexed map
+    insertExtra, lookupExtra, userSetting,
+
+    -- * Paths
+    BuildRoot (..), buildRoot, isGeneratedSource,
+
+    -- * File system operations
+    copyFile, copyFileUntracked, fixFile, makeExecutable, moveFile, removeFile,
+    createDirectory, copyDirectory, moveDirectory, removeDirectory,
+
+    -- * Diagnostic info
+    UseColour (..), putColoured, BuildProgressColour (..), putBuild,
+    SuccessColour (..), putSuccess, ProgressInfo (..),
+    putProgressInfo, renderAction, renderProgram, renderLibrary, renderBox,
+    renderUnicorn,
+
+    -- * Miscellaneous
+    (<&>), (%%>), cmdLineLengthLimit,
+
+    -- * Useful re-exports
+    Dynamic, fromDynamic, toDyn, TypeRep, typeOf
+    ) where
+
+import Control.Monad.Extra
+import Data.Char
+import Data.Dynamic (Dynamic, fromDynamic, toDyn)
+import Data.HashMap.Strict (HashMap)
+import Data.List.Extra
+import Data.Maybe
+import Data.Typeable (TypeRep, typeOf)
+import Development.Shake hiding (Normal)
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import System.Console.ANSI
+import System.Info.Extra
+
+import qualified Control.Exception.Base as IO
+import qualified Data.HashMap.Strict    as Map
+import qualified System.Directory.Extra as IO
+import qualified System.Info.Extra      as IO
+import qualified System.IO              as IO
+
+-- | Extract a value from a singleton list, or terminate with an error message
+-- if the list does not contain exactly one value.
+fromSingleton :: String -> [a] -> a
+fromSingleton _   [res] = res
+fromSingleton msg _     = error msg
+
+-- | Find and replace all occurrences of a value in a list.
+replaceEq :: Eq a => a -> a -> [a] -> [a]
+replaceEq from to = map (\cur -> if cur == from then to else cur)
+
+-- Explicit definition to avoid dependency on Data.List.Ordered
+-- | Difference of two ordered lists.
+minusOrd :: Ord a => [a] -> [a] -> [a]
+minusOrd [] _  = []
+minusOrd xs [] = xs
+minusOrd (x:xs) (y:ys) = case compare x y of
+    LT -> x : minusOrd xs (y:ys)
+    EQ ->     minusOrd xs ys
+    GT ->     minusOrd (x:xs) ys
+
+-- Explicit definition to avoid dependency on Data.List.Ordered. TODO: add tests
+-- | Intersection of two ordered lists by a predicate.
+intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
+intersectOrd cmp = loop
+  where
+    loop [] _ = []
+    loop _ [] = []
+    loop (x:xs) (y:ys) = case cmp x y of
+        LT ->     loop xs (y:ys)
+        EQ -> x : loop xs (y:ys)
+        GT ->     loop (x:xs) ys
+
+-- | Lookup all elements of a given sorted list in a given sorted dictionary.
+-- @lookupAll list dict@ is equivalent to @map (flip lookup dict) list@ but has
+-- linear complexity O(|list| + |dist|) instead of quadratic O(|list| * |dict|).
+--
+-- > lookupAll ["b", "c"] [("a", 1), ("c", 3), ("d", 4)] == [Nothing, Just 3]
+-- > list & dict are sorted: lookupAll list dict == map (flip lookup dict) list
+lookupAll :: Ord a => [a] -> [(a, b)] -> [Maybe b]
+lookupAll []     _      = []
+lookupAll (_:xs) []     = Nothing : lookupAll xs []
+lookupAll (x:xs) (y:ys) = case compare x (fst y) of
+    LT -> Nothing      : lookupAll xs (y:ys)
+    EQ -> Just (snd y) : lookupAll xs (y:ys)
+    GT -> lookupAll (x:xs) ys
+
+-- | @chunksOfSize size strings@ splits a given list of strings into chunks not
+-- exceeding the given @size@. If that is impossible, it uses singleton chunks.
+chunksOfSize :: Int -> [String] -> [[String]]
+chunksOfSize n = repeatedly f
+  where
+    f xs = splitAt (max 1 $ length $ takeWhile (<= n) $ scanl1 (+) $ map length xs) xs
+
+-- | Add single quotes around a String.
+quote :: String -> String
+quote s = "'" ++ s ++ "'"
+
+-- | Pretty-print a 'Bool' as a @"YES"@ or @"NO"@ string.
+yesNo :: Bool -> String
+yesNo True  = "YES"
+yesNo False = "NO"
+
+-- | Normalise a path and convert all path separators to @/@, even on Windows.
+unifyPath :: FilePath -> FilePath
+unifyPath = toStandard . normaliseEx
+
+-- | Combine paths with a forward slash regardless of platform.
+(-/-) :: FilePath -> FilePath -> FilePath
+"" -/- b = b
+a  -/- b
+    | last a == '/' = a ++       b
+    | otherwise     = a ++ '/' : b
+
+infixr 6 -/-
+
+-- | Like Shake's '%>' but gives higher priority to longer patterns. Useful
+-- in situations when a family of build rules, e.g. @"//*.a"@ and @"//*_p.a"@
+-- can be matched by the same file, such as @library_p.a@. We break the tie
+-- by preferring longer matches, which correpond to longer patterns.
+(%%>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()
+p %%> a = priority (fromIntegral (length p) + 1) $ p %> a
+
+infix 1 %%>
+
+-- | Build command lines can get very long; for example, when building the Cabal
+-- library, they can reach 2MB! Some operating systems do not support command
+-- lines of such length, and this function can be used to obtain a reasonable
+-- approximation of the limit. On Windows, it is theoretically 32768 characters
+-- (since Windows 7). In practice we use 31000 to leave some breathing space for
+-- the builder path & name, auxiliary flags, and other overheads. On Mac OS X,
+-- ARG_MAX is 262144, yet when using @xargs@ on OSX this is reduced by over
+-- 20000. Hence, 200000 seems like a sensible limit. On other operating systems
+-- we currently use the 4194304 setting.
+cmdLineLengthLimit :: Int
+cmdLineLengthLimit | isWindows = 31000
+                   | isMac     = 200000
+                   | otherwise = 4194304
+
+-- | Insert a value into Shake's type-indexed map.
+insertExtra :: Typeable a => a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
+insertExtra value = Map.insert (typeOf value) (toDyn value)
+
+-- | Lookup a value in Shake's type-indexed map.
+lookupExtra :: Typeable a => a -> Map.HashMap TypeRep Dynamic -> a
+lookupExtra defaultValue extra = fromMaybe defaultValue maybeValue
+  where
+    maybeValue = fromDynamic =<< Map.lookup (typeOf defaultValue) extra
+
+-- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the
+-- setting is not found, return the provided default value instead.
+userSetting :: Typeable a => a -> Action a
+userSetting defaultValue = do
+    extra <- shakeExtra <$> getShakeOptions
+    return $ lookupExtra defaultValue extra
+
+newtype BuildRoot = BuildRoot FilePath deriving Typeable
+
+-- | All build results are put into the 'buildRoot' directory.
+buildRoot :: Action FilePath
+buildRoot = do
+    BuildRoot path <- userSetting (BuildRoot "")
+    return path
+
+-- | A version of 'fmap' with flipped arguments. Useful for manipulating values
+-- in context, e.g. 'buildRoot', as in the example below.
+--
+-- @
+-- buildRoot <&> (-/- "dir") == fmap (-/- "dir") buildRoot
+-- @
+(<&>) :: Functor f => f a -> (a -> b) -> f b
+(<&>) = flip fmap
+
+infixl 1 <&>
+
+-- | Given a 'FilePath' to a source file, return 'True' if it is generated.
+-- The current implementation simply assumes that a file is generated if it
+-- lives in the 'buildRoot' directory. Since most files are not generated the
+-- test is usually very fast.
+isGeneratedSource :: FilePath -> Action Bool
+isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
+
+-- | Copy a file tracking the source. Create the target directory if missing.
+copyFile :: FilePath -> FilePath -> Action ()
+copyFile source target = do
+    need [source] -- Guarantee the source is built before printing progress info.
+    let dir = takeDirectory target
+    liftIO $ IO.createDirectoryIfMissing True dir
+    putProgressInfo =<< renderAction "Copy file" source target
+    quietly $ copyFileChanged source target
+
+-- | Copy a file without tracking the source. Create the target directory if missing.
+copyFileUntracked :: FilePath -> FilePath -> Action ()
+copyFileUntracked source target = do
+    let dir = takeDirectory target
+    liftIO $ IO.createDirectoryIfMissing True dir
+    putProgressInfo =<< renderAction "Copy file (untracked)" source target
+    liftIO $ IO.copyFile source target
+
+-- | Transform a given file by applying a function to its contents.
+fixFile :: FilePath -> (String -> String) -> Action ()
+fixFile file f = do
+    putProgressInfo $ "| Fix " ++ file
+    contents <- liftIO $ IO.withFile file IO.ReadMode $ \h -> do
+        old <- IO.hGetContents h
+        let new = f old
+        IO.evaluate $ rnf new
+        return new
+    liftIO $ writeFile file contents
+
+-- | Make a given file executable by running the @chmod +x@ command.
+makeExecutable :: FilePath -> Action ()
+makeExecutable file = do
+    putProgressInfo $ "| Make " ++ quote file ++ " executable."
+    quietly $ cmd "chmod +x " [file]
+
+-- | Move a file. Note that we cannot track the source, because it is moved.
+moveFile :: FilePath -> FilePath -> Action ()
+moveFile source target = do
+    putProgressInfo =<< renderAction "Move file" source target
+    quietly $ cmd ["mv", source, target]
+
+-- | Remove a file that doesn't necessarily exist.
+removeFile :: FilePath -> Action ()
+removeFile file = do
+    putProgressInfo $ "| Remove file " ++ file
+    liftIO . whenM (IO.doesFileExist file) $ IO.removeFile file
+
+-- | Create a directory if it does not already exist.
+createDirectory :: FilePath -> Action ()
+createDirectory dir = do
+    putProgressInfo $ "| Create directory " ++ dir
+    liftIO $ IO.createDirectoryIfMissing True dir
+
+-- | Copy a directory. The contents of the source directory is untracked.
+copyDirectory :: FilePath -> FilePath -> Action ()
+copyDirectory source target = do
+    putProgressInfo =<< renderAction "Copy directory" source target
+    quietly $ cmd ["cp", "-r", source, target]
+
+-- | Move a directory. The contents of the source directory is untracked.
+moveDirectory :: FilePath -> FilePath -> Action ()
+moveDirectory source target = do
+    putProgressInfo =<< renderAction "Move directory" source target
+    quietly $ cmd ["mv", source, target]
+
+-- | Remove a directory that doesn't necessarily exist.
+removeDirectory :: FilePath -> Action ()
+removeDirectory dir = do
+    putProgressInfo $ "| Remove directory " ++ dir
+    liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir
+
+data UseColour = Never | Auto | Always deriving (Eq, Show, Typeable)
+
+-- | A more colourful version of Shake's 'putNormal'.
+putColoured :: ColorIntensity -> Color -> String -> Action ()
+putColoured intensity colour msg = do
+    useColour <- userSetting Never
+    supported <- liftIO $ hSupportsANSI IO.stdout
+    let c Never  = False
+        c Auto   = supported || IO.isWindows -- Colours do work on Windows
+        c Always = True
+    when (c useColour) . liftIO $ setSGR [SetColor Foreground intensity colour]
+    putNormal msg
+    when (c useColour) . liftIO $ setSGR [] >> IO.hFlush IO.stdout
+
+newtype BuildProgressColour = BuildProgressColour (ColorIntensity, Color)
+    deriving Typeable
+
+-- | Default 'BuildProgressColour'.
+magenta :: BuildProgressColour
+magenta = BuildProgressColour (Dull, Magenta)
+
+-- | Print a build progress message (e.g. executing a build command).
+putBuild :: String -> Action ()
+putBuild msg = do
+    BuildProgressColour (intensity, colour) <- userSetting magenta
+    putColoured intensity colour msg
+
+newtype SuccessColour = SuccessColour (ColorIntensity, Color)
+    deriving Typeable
+
+-- | Default 'SuccessColour'.
+green :: SuccessColour
+green = SuccessColour (Dull, Green)
+
+-- | Print a success message (e.g. a package is built successfully).
+putSuccess :: String -> Action ()
+putSuccess msg = do
+    SuccessColour (intensity, colour) <- userSetting green
+    putColoured intensity colour msg
+
+data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show, Typeable)
+
+-- | Version of 'putBuild' controlled by @--progress-info@ command line argument.
+putProgressInfo :: String -> Action ()
+putProgressInfo msg = do
+    progressInfo <- userSetting None
+    when (progressInfo /= None) $ putBuild msg
+
+-- | Render an action.
+renderAction :: String -> FilePath -> FilePath -> Action String
+renderAction what input output = do
+    progressInfo <- userSetting Brief
+    return $ case progressInfo of
+        None    -> ""
+        Brief   -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
+        Normal  -> renderBox [ what, "     input: " ++ i, " => output: " ++ o ]
+        Unicorn -> renderUnicorn [ what, "     input: " ++ i, " => output: " ++ o ]
+  where
+    i = unifyPath input
+    o = unifyPath output
+
+-- | Render the successful build of a program.
+renderProgram :: String -> String -> Maybe String -> String
+renderProgram name bin synopsis = renderBox $
+    [ "Successfully built program " ++ name
+    , "Executable: " ++ bin ] ++
+    [ "Program synopsis: " ++ prettySynopsis synopsis | isJust synopsis ]
+
+-- | Render the successful build of a library.
+renderLibrary :: String -> String -> Maybe String -> String
+renderLibrary name lib synopsis = renderBox $
+    [ "Successfully built library " ++ name
+    , "Library: " ++ lib ] ++
+    [ "Library synopsis: " ++ prettySynopsis synopsis | isJust synopsis ]
+
+prettySynopsis :: Maybe String -> String
+prettySynopsis Nothing  = ""
+prettySynopsis (Just s) = dropWhileEnd isPunctuation s ++ "."
+
+-- | Render the given set of lines in an ASCII box. The minimum width and
+-- whether to use Unicode symbols are hardcoded in the function's body.
+--
+-- >>> renderBox (words "lorem ipsum")
+-- /----------\
+-- | lorem    |
+-- | ipsum    |
+-- \----------/
+renderBox :: [String] -> String
+renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
+  where
+    -- Minimum total width of the box in characters
+    minimumBoxWidth = 32
+
+    -- TODO: Make this setting configurable? Setting to True by default seems
+    -- to work poorly with many fonts.
+    useUnicode = False
+
+    -- Characters to draw the box
+    (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
+        | useUnicode = ('─', '│', '╭',  '╮', '╰', '╯', ' ')
+        | otherwise  = ('-', '|', '/', '\\', '\\', '/', ' ')
+
+    -- Box width, taking minimum desired length and content into account.
+    -- The -4 is for the beginning and end pipe/padding symbols, as
+    -- in "| xxx |".
+    boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
+      where
+        maxContentLength = maximum (map length ls)
+
+    renderLine l = concat
+        [ [pipe, padding]
+        , padToLengthWith boxContentWidth padding l
+        , [padding, pipe] ]
+      where
+        padToLengthWith n filler x = x ++ replicate (n - length x) filler
+
+    (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
+                       , botLeft : dashes ++ [botRight] )
+      where
+        -- +1 for each non-dash (= corner) char
+        dashes = replicate (boxContentWidth + 2) dash
+
+-- | Render the given set of lines next to our favorite unicorn Robert.
+renderUnicorn :: [String] -> String
+renderUnicorn ls =
+    unlines $ take (max (length ponyLines) (length boxLines)) $
+        zipWith (++) (ponyLines ++ repeat ponyPadding) (boxLines ++ repeat "")
+  where
+    ponyLines :: [String]
+    ponyLines = [ "                   ,;,,;'"
+                , "                  ,;;'(    Robert the spitting unicorn"
+                , "       __       ,;;' ' \\   wants you to know"
+                , "     /'  '\\'~~'~' \\ /'\\.)  that a task      "
+                , "  ,;(      )    /  |.  /   just finished!   "
+                , " ,;' \\    /-.,,(   ) \\                      "
+                , " ^    ) /       ) / )|     Almost there!    "
+                , "      ||        ||  \\)                      "
+                , "      (_\\       (_\\                         " ]
+    ponyPadding :: String
+    ponyPadding = "                                            "
+    boxLines :: [String]
+    boxLines = ["", "", ""] ++ (lines . renderBox $ ls)
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644 (file)
index 0000000..52af0ad
--- /dev/null
@@ -0,0 +1,59 @@
+module Main (main) where
+
+import Development.Shake
+import Hadrian.Expression
+import Hadrian.Utilities
+
+import qualified Base
+import qualified CommandLine
+import qualified Environment
+import qualified Rules
+import qualified Rules.Clean
+import qualified Rules.Documentation
+import qualified Rules.Install
+import qualified Rules.SourceDist
+import qualified Rules.Selftest
+import qualified Rules.Test
+import qualified UserSettings
+
+main :: IO ()
+main = do
+    -- Provide access to command line arguments and some user settings through
+    -- Shake's type-indexed map 'shakeExtra'.
+    argsMap <- CommandLine.cmdLineArgsMap
+    let extra = insertExtra UserSettings.buildProgressColour
+              $ insertExtra UserSettings.successColour
+              $ insertExtra UserSettings.userBuildRoot
+              $ insertExtra (VerboseCommand UserSettings.verboseCommand) argsMap
+
+        BuildRoot buildRoot = UserSettings.userBuildRoot
+
+        rebuild = [ (RebuildLater, buildRoot -/- "stage0//*")
+                  | CommandLine.lookupFreeze1 argsMap ]
+
+        options :: ShakeOptions
+        options = shakeOptions
+            { shakeChange   = ChangeModtimeAndDigest
+            , shakeFiles    = buildRoot -/- Base.shakeFilesDir
+            , shakeProgress = progressSimple
+            , shakeRebuild  = rebuild
+            , shakeTimings  = True
+            , shakeExtra    = extra }
+
+        rules :: Rules ()
+        rules = do
+            Rules.buildRules
+            Rules.Documentation.documentationRules
+            Rules.Clean.cleanRules
+            Rules.Install.installRules
+            Rules.oracleRules
+            Rules.Selftest.selftestRules
+            Rules.SourceDist.sourceDistRules
+            Rules.Test.testRules
+            Rules.topLevelTargets
+
+    shakeArgsWith options CommandLine.optDescrs $ \_ targets -> do
+        Environment.setupEnvironment
+        return . Just $ if null targets
+                        then rules
+                        else want targets >> withoutActions rules
diff --git a/src/Oracles/Flag.hs b/src/Oracles/Flag.hs
new file mode 100644 (file)
index 0000000..447f0bc
--- /dev/null
@@ -0,0 +1,80 @@
+module Oracles.Flag (
+    Flag (..), flag, crossCompiling, platformSupportsSharedLibs,
+    ghcWithSMP, ghcWithNativeCodeGen, supportsSplitObjects
+    ) where
+
+import Hadrian.Oracles.TextFile
+
+import Base
+import Oracles.Setting
+
+data Flag = ArSupportsAtFile
+          | CrossCompiling
+          | GccIsClang
+          | GccLt34
+          | GccLt44
+          | GccLt46
+          | GhcUnregisterised
+          | LeadingUnderscore
+          | SolarisBrokenShld
+          | SplitObjectsBroken
+          | WithLibdw
+          | HaveLibMingwEx
+          | UseSystemFfi
+
+-- Note, if a flag is set to empty string we treat it as set to NO. This seems
+-- fragile, but some flags do behave like this, e.g. GccIsClang.
+flag :: Flag -> Action Bool
+flag f = do
+    let key = case f of
+            ArSupportsAtFile   -> "ar-supports-at-file"
+            CrossCompiling     -> "cross-compiling"
+            GccIsClang         -> "gcc-is-clang"
+            GccLt34            -> "gcc-lt-34"
+            GccLt44            -> "gcc-lt-44"
+            GccLt46            -> "gcc-lt-46"
+            GhcUnregisterised  -> "ghc-unregisterised"
+            LeadingUnderscore  -> "leading-underscore"
+            SolarisBrokenShld  -> "solaris-broken-shld"
+            SplitObjectsBroken -> "split-objects-broken"
+            WithLibdw          -> "with-libdw"
+            HaveLibMingwEx     -> "have-lib-mingw-ex"
+            UseSystemFfi       -> "use-system-ffi"
+    value <- lookupValueOrError configFile key
+    when (value `notElem` ["YES", "NO", ""]) . error $ "Configuration flag "
+        ++ quote (key ++ " = " ++ value) ++ " cannot be parsed."
+    return $ value == "YES"
+
+crossCompiling :: Action Bool
+crossCompiling = flag CrossCompiling
+
+platformSupportsSharedLibs :: Action Bool
+platformSupportsSharedLibs = do
+    badPlatform   <- anyTargetPlatform [ "powerpc-unknown-linux"
+                                       , "x86_64-unknown-mingw32"
+                                       , "i386-unknown-mingw32" ]
+    solaris       <- anyTargetPlatform [ "i386-unknown-solaris2" ]
+    solarisBroken <- flag SolarisBrokenShld
+    return $ not (badPlatform || solaris && solarisBroken)
+
+ghcWithSMP :: Action Bool
+ghcWithSMP = do
+    goodArch <- anyTargetArch ["i386", "x86_64", "sparc", "powerpc", "arm"]
+    ghcUnreg <- flag GhcUnregisterised
+    return $ goodArch && not ghcUnreg
+
+ghcWithNativeCodeGen :: Action Bool
+ghcWithNativeCodeGen = do
+    goodArch <- anyTargetArch ["i386", "x86_64", "sparc", "powerpc"]
+    badOs    <- anyTargetOs ["ios", "aix"]
+    ghcUnreg <- flag GhcUnregisterised
+    return $ goodArch && not badOs && not ghcUnreg
+
+supportsSplitObjects :: Action Bool
+supportsSplitObjects = do
+    broken   <- flag SplitObjectsBroken
+    ghcUnreg <- flag GhcUnregisterised
+    goodArch <- anyTargetArch [ "i386", "x86_64", "powerpc", "sparc" ]
+    goodOs   <- anyTargetOs [ "mingw32", "cygwin32", "linux", "darwin", "solaris2"
+                            , "freebsd", "dragonfly", "netbsd", "openbsd" ]
+    return $ not broken && not ghcUnreg && goodArch && goodOs
diff --git a/src/Oracles/ModuleFiles.hs b/src/Oracles/ModuleFiles.hs
new file mode 100644 (file)
index 0000000..c7175db
--- /dev/null
@@ -0,0 +1,160 @@
+{-# LANGUAGE TypeFamilies #-}
+module Oracles.ModuleFiles (
+    decodeModule, encodeModule, findGenerator, hsSources, hsObjects, moduleFilesOracle
+    ) where
+
+import qualified Data.HashMap.Strict as Map
+
+import Base
+import Builder
+import Context
+import GHC
+import Oracles.PackageData
+
+newtype ModuleFiles = ModuleFiles (Stage, Package)
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult ModuleFiles = [Maybe FilePath]
+
+newtype Generator = Generator (Stage, Package, FilePath)
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult Generator = Maybe FilePath
+
+-- | We scan for the following Haskell source extensions when looking for module
+-- files. Note, we do not list "*.(l)hs-boot" files here, as they can never
+-- appear by themselves and always have accompanying "*.(l)hs" master files.
+haskellExtensions :: [String]
+haskellExtensions = [".hs", ".lhs"]
+
+-- | Non-Haskell source extensions and corresponding builders.
+otherExtensions :: [(String, Builder)]
+otherExtensions = [ (".x"  , Alex  )
+                  , (".y"  , Happy )
+                  , (".ly" , Happy )
+                  , (".hsc", Hsc2Hs) ]
+
+-- | We match the following file patterns when looking for module files.
+moduleFilePatterns :: [FilePattern]
+moduleFilePatterns = map ("*" ++) $ haskellExtensions ++ map fst otherExtensions
+
+-- | Given a FilePath determine the corresponding builder.
+determineBuilder :: FilePath -> Maybe Builder
+determineBuilder file = lookup (takeExtension file) otherExtensions
+
+-- | Given a module name extract the directory and file name, e.g.:
+--
+-- > decodeModule "Data.Functor.Identity" == ("Data/Functor", "Identity")
+-- > decodeModule "Prelude"               == ("", "Prelude")
+decodeModule :: String -> (FilePath, String)
+decodeModule modName = (intercalate "/" (init xs), last xs)
+  where
+    xs = words $ replaceEq '.' ' ' modName
+
+-- | Given the directory and file name find the corresponding module name, e.g.:
+--
+-- > encodeModule "Data/Functor" "Identity.hs" == "Data.Functor.Identity"
+-- > encodeModule "" "Prelude"                 == "Prelude"
+-- > uncurry encodeModule (decodeModule name)  == name
+encodeModule :: FilePath -> String -> String
+encodeModule dir file
+    | dir == "" =                                takeBaseName file
+    | otherwise = replaceEq '/' '.' dir ++ '.' : takeBaseName file
+
+-- | Find the generator for a given 'Context' and a source file. For example:
+-- findGenerator (Context Stage1 compiler vanilla)
+--               "_build/stage1/compiler/build/Lexer.hs"
+-- == Just ("compiler/parser/Lexer.x", Alex)
+-- findGenerator (Context Stage1 base vanilla)
+--               "_build/stage1/base/build/Prelude.hs"
+-- == Nothing
+findGenerator :: Context -> FilePath -> Action (Maybe (FilePath, Builder))
+findGenerator Context {..} file = do
+    maybeSource <- askOracle $ Generator (stage, package, file)
+    return $ do
+        source  <- maybeSource
+        builder <- determineBuilder source
+        return (source, builder)
+
+-- | Find all Haskell source files for a given 'Context'.
+hsSources :: Context -> Action [FilePath]
+hsSources context = do
+    let modFile (m, Nothing   ) = generatedFile context m
+        modFile (m, Just file )
+            | takeExtension file `elem` haskellExtensions = return file
+            | otherwise = generatedFile context m
+    mapM modFile =<< contextFiles context
+
+-- | Find all Haskell object files for a given 'Context'. Note: this is a much
+-- simpler function compared to 'hsSources', because all object files live in
+-- the build directory regardless of whether they are generated or not.
+hsObjects :: Context -> Action [FilePath]
+hsObjects context = do
+    path    <- buildPath context
+    modules <- pkgDataList (Modules path)
+    -- GHC.Prim module is only for documentation, we do not actually build it.
+    mapM (objectPath context . moduleSource) (filter (/= "GHC.Prim") modules)
+
+-- | Generated module files live in the 'Context' specific build directory.
+generatedFile :: Context -> String -> Action FilePath
+generatedFile context moduleName = do
+    path <- buildPath context
+    return $ path -/- moduleSource moduleName
+
+moduleSource :: String -> FilePath
+moduleSource moduleName = replaceEq '.' '/' moduleName <.> "hs"
+
+-- | Module files for a given 'Context'.
+contextFiles :: Context -> Action [(String, Maybe FilePath)]
+contextFiles context@Context {..} = do
+    path    <- buildPath context
+    modules <- fmap sort . pkgDataList $ Modules path
+    zip modules <$> askOracle (ModuleFiles (stage, package))
+
+-- | This is an important oracle whose role is to find and cache module source
+-- files. It takes a 'Stage' and a 'Package', looks up corresponding source
+-- directories @dirs@ and a sorted list of module names @modules@, and for each
+-- module, e.g. @A.B.C@, returns a 'FilePath' of the form @dir/A/B/C.extension@,
+-- such that @dir@ belongs to @dirs@, and file @dir/A/B/C.extension@ exists, or
+-- 'Nothing' if there is no such file. If more than one matching file is found
+-- an error is raised. For example, for 'Stage1' and 'compiler', @dirs@ will
+-- contain ["compiler/codeGen", "compiler/parser"], and @modules@ will contain
+-- ["CodeGen.Platform.ARM", "Config", "Lexer"]; the oracle will produce a list
+-- containing [Just "compiler/codeGen/CodeGen/Platform/ARM.hs", Nothing,
+-- Just "compiler/parser/Lexer.x"]. The oracle ignores @.(l)hs-boot@ files.
+moduleFilesOracle :: Rules ()
+moduleFilesOracle = void $ do
+    void . addOracle $ \(ModuleFiles (stage, package)) -> do
+        let context = vanillaContext stage package
+        path    <- buildPath context
+        srcDirs <-             pkgDataList $ SrcDirs path
+        modules <- fmap sort . pkgDataList $ Modules path
+        autogen <- autogenPath context
+        let dirs = autogen : map (pkgPath package -/-) srcDirs
+            modDirFiles = groupSort $ map decodeModule modules
+        result <- concatForM dirs $ \dir -> do
+            todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
+            forM todo $ \(mDir, mFiles) -> do
+                let fullDir = unifyPath $ dir -/- mDir
+                files <- getDirectoryFiles fullDir moduleFilePatterns
+                let cmp f = compare (dropExtension f)
+                    found = intersectOrd cmp files mFiles
+                return (map (fullDir -/-) found, mDir)
+        let pairs = sort [ (encodeModule d f, f) | (fs, d) <- result, f <- fs ]
+            multi = [ (m, f1, f2) | (m, f1):(n, f2):_ <- tails pairs, m == n ]
+        unless (null multi) $ do
+            let (m, f1, f2) = head multi
+            error $ "Module " ++ m ++ " has more than one source file: "
+                ++ f1 ++ " and " ++ f2 ++ "."
+        return $ lookupAll modules pairs
+
+    -- Optimisation: we discard Haskell files here, because they are never used
+    -- as generators, and hence would be discarded in 'findGenerator' anyway.
+    generators <- newCache $ \(stage, package) -> do
+        let context = vanillaContext stage package
+        files <- contextFiles context
+        list  <- sequence [ (,src) <$> generatedFile context modName
+                          | (modName, Just src) <- files
+                          , takeExtension src `notElem` haskellExtensions ]
+        return $ Map.fromList list
+
+    addOracle $ \(Generator (stage, package, file)) ->
+        Map.lookup file <$> generators (stage, package)
diff --git a/src/Oracles/PackageData.hs b/src/Oracles/PackageData.hs
new file mode 100644 (file)
index 0000000..cdfe9bf
--- /dev/null
@@ -0,0 +1,66 @@
+module Oracles.PackageData (
+    PackageData (..), PackageDataList (..), pkgData, pkgDataList
+    ) where
+
+import Hadrian.Oracles.TextFile
+
+import Base
+
+newtype PackageData = BuildGhciLib FilePath
+
+data PackageDataList = AsmSrcs        FilePath
+                     | CcArgs         FilePath
+                     | CSrcs          FilePath
+                     | CmmSrcs        FilePath
+                     | CppArgs        FilePath
+                     | DepCcArgs      FilePath
+                     | DepExtraLibs   FilePath
+                     | DepIds         FilePath
+                     | DepIncludeDirs FilePath
+                     | DepLdArgs      FilePath
+                     | DepLibDirs     FilePath
+                     | DepNames       FilePath
+                     | Deps           FilePath
+                     | HiddenModules  FilePath
+                     | HsArgs         FilePath
+                     | IncludeDirs    FilePath
+                     | LdArgs         FilePath
+                     | Modules        FilePath
+                     | SrcDirs        FilePath
+
+askPackageData :: FilePath -> String -> Action String
+askPackageData path = lookupValueOrEmpty (path -/- "package-data.mk")
+
+-- | 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".
+pkgData :: PackageData -> Action String
+pkgData packageData = case packageData of
+    BuildGhciLib path -> askPackageData path "BUILD_GHCI_LIB"
+
+-- | @PackageDataList path@ is used for multiple string options separated by
+-- spaces, such as @path_MODULES = Data.Array Data.Array.Base ...@.
+-- @pkgListData Modules@ therefore returns ["Data.Array", "Data.Array.Base", ...]
+pkgDataList :: PackageDataList -> Action [String]
+pkgDataList packageData = fmap (map unquote . words) $ case packageData of
+    AsmSrcs        path -> askPackageData path "S_SRCS"
+    CcArgs         path -> askPackageData path "CC_OPTS"
+    CSrcs          path -> askPackageData path "C_SRCS"
+    CmmSrcs        path -> askPackageData path "CMM_SRCS"
+    CppArgs        path -> askPackageData path "CPP_OPTS"
+    DepCcArgs      path -> askPackageData path "DEP_CC_OPTS"
+    DepExtraLibs   path -> askPackageData path "DEP_EXTRA_LIBS"
+    DepIds         path -> askPackageData path "DEP_IPIDS"
+    DepIncludeDirs path -> askPackageData path "DEP_INCLUDE_DIRS_SINGLE_QUOTED"
+    DepLibDirs     path -> askPackageData path "DEP_LIB_DIRS_SINGLE_QUOTED"
+    DepLdArgs      path -> askPackageData path "DEP_LD_OPTS"
+    DepNames       path -> askPackageData path "DEP_NAMES"
+    Deps           path -> askPackageData path "DEPS"
+    HiddenModules  path -> askPackageData path "HIDDEN_MODULES"
+    HsArgs         path -> askPackageData path "HC_OPTS"
+    IncludeDirs    path -> askPackageData path "INCLUDE_DIRS"
+    LdArgs         path -> askPackageData path "LD_OPTS"
+    Modules        path -> askPackageData path "MODULES"
+    SrcDirs        path -> askPackageData path "HS_SRC_DIRS"
+  where
+    unquote = dropWhile (== '\'') . dropWhileEnd (== '\'')
diff --git a/src/Oracles/Setting.hs b/src/Oracles/Setting.hs
new file mode 100644 (file)
index 0000000..aa49011
--- /dev/null
@@ -0,0 +1,236 @@
+module Oracles.Setting (
+    configFile, Setting (..), SettingList (..), setting, settingList, getSetting,
+    getSettingList,  anyTargetPlatform, anyTargetOs, anyTargetArch, anyHostOs,
+    ghcWithInterpreter, ghcEnableTablesNextToCode, useLibFFIForAdjustors,
+    ghcCanonVersion, cmdLineLengthLimit, iosHost, osxHost, windowsHost,
+    topDirectory, relocatableBuild, installDocDir, installGhcLibDir, libsuf
+    ) where
+
+import Hadrian.Expression
+import Hadrian.Oracles.TextFile
+import Hadrian.Oracles.Path
+
+import Base
+
+-- TODO: Reduce the variety of similar flags (e.g. CPP and non-CPP versions).
+-- | Each 'Setting' comes from @system.config@ file, e.g. 'target-os = mingw32'.
+-- @setting TargetOs@ looks up the config file and returns "mingw32".
+-- 'SettingList' is used for multiple string values separated by spaces, such
+-- as @gmp-include-dirs = a b@.
+-- @settingList GmpIncludeDirs@ therefore returns a list of strings ["a", "b"].
+data Setting = BuildArch
+             | BuildOs
+             | BuildPlatform
+             | BuildVendor
+             | CcClangBackend
+             | CcLlvmBackend
+             | DynamicExtension
+             | GhcMajorVersion
+             | GhcMinorVersion
+             | GhcPatchLevel
+             | GhcVersion
+             | GhcSourcePath
+             | HostArch
+             | HostOs
+             | HostPlatform
+             | HostVendor
+             | ProjectGitCommitId
+             | ProjectName
+             | ProjectVersion
+             | ProjectVersionInt
+             | ProjectPatchLevel
+             | ProjectPatchLevel1
+             | ProjectPatchLevel2
+             | TargetArch
+             | TargetOs
+             | TargetPlatform
+             | TargetPlatformFull
+             | TargetVendor
+             | LlvmTarget
+             | FfiIncludeDir
+             | FfiLibDir
+             | GmpIncludeDir
+             | GmpLibDir
+             | IconvIncludeDir
+             | IconvLibDir
+             | CursesLibDir
+             -- Paths to where GHC is installed (ref: mk/install.mk)
+             | InstallPrefix
+             | InstallBinDir
+             | InstallLibDir
+             | InstallDataRootDir
+             -- Command lines for invoking the @install@ utility
+             | Install
+             | InstallData
+             | InstallProgram
+             | InstallScript
+             | InstallDir
+             -- Command line for creating a symbolic link
+             | LnS
+
+data SettingList = ConfCcArgs Stage
+                 | ConfCppArgs Stage
+                 | ConfGccLinkerArgs Stage
+                 | ConfLdLinkerArgs Stage
+                 | HsCppArgs
+
+-- | Maps 'Setting's to names in @cfg/system.config.in@.
+setting :: Setting -> Action String
+setting key = lookupValueOrError configFile $ case key of
+    BuildArch          -> "build-arch"
+    BuildOs            -> "build-os"
+    BuildPlatform      -> "build-platform"
+    BuildVendor        -> "build-vendor"
+    CcClangBackend     -> "cc-clang-backend"
+    CcLlvmBackend      -> "cc-llvm-backend"
+    DynamicExtension   -> "dynamic-extension"
+    GhcMajorVersion    -> "ghc-major-version"
+    GhcMinorVersion    -> "ghc-minor-version"
+    GhcPatchLevel      -> "ghc-patch-level"
+    GhcVersion         -> "ghc-version"
+    GhcSourcePath      -> "ghc-source-path"
+    HostArch           -> "host-arch"
+    HostOs             -> "host-os"
+    HostPlatform       -> "host-platform"
+    HostVendor         -> "host-vendor"
+    ProjectGitCommitId -> "project-git-commit-id"
+    ProjectName        -> "project-name"
+    ProjectVersion     -> "project-version"
+    ProjectVersionInt  -> "project-version-int"
+    ProjectPatchLevel  -> "project-patch-level"
+    ProjectPatchLevel1 -> "project-patch-level1"
+    ProjectPatchLevel2 -> "project-patch-level2"
+    TargetArch         -> "target-arch"
+    TargetOs           -> "target-os"
+    TargetPlatform     -> "target-platform"
+    TargetPlatformFull -> "target-platform-full"
+    TargetVendor       -> "target-vendor"
+    LlvmTarget         -> "llvm-target"
+    FfiIncludeDir      -> "ffi-include-dir"
+    FfiLibDir          -> "ffi-lib-dir"
+    GmpIncludeDir      -> "gmp-include-dir"
+    GmpLibDir          -> "gmp-lib-dir"
+    IconvIncludeDir    -> "iconv-include-dir"
+    IconvLibDir        -> "iconv-lib-dir"
+    CursesLibDir       -> "curses-lib-dir"
+    InstallPrefix      -> "install-prefix"
+    InstallBinDir      -> "install-bindir"
+    InstallLibDir      -> "install-libdir"
+    InstallDataRootDir -> "install-datarootdir"
+    Install            -> "install"
+    InstallDir         -> "install-dir"
+    InstallProgram     -> "install-program"
+    InstallScript      -> "install-script"
+    InstallData        -> "install-data"
+    LnS                -> "ln-s"
+
+settingList :: SettingList -> Action [String]
+settingList key = fmap words $ lookupValueOrError configFile $ 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
+    ConfLdLinkerArgs  stage -> "conf-ld-linker-args-"  ++ stageString stage
+    HsCppArgs               -> "hs-cpp-args"
+
+-- | Get a configuration setting.
+getSetting :: Setting -> Expr c b String
+getSetting = expr . setting
+
+-- | Get a list of configuration settings.
+getSettingList :: SettingList -> Args c b
+getSettingList = expr . settingList
+
+matchSetting :: Setting -> [String] -> Action Bool
+matchSetting key values = (`elem` values) <$> setting key
+
+anyTargetPlatform :: [String] -> Action Bool
+anyTargetPlatform = matchSetting TargetPlatformFull
+
+anyTargetOs :: [String] -> Action Bool
+anyTargetOs = matchSetting TargetOs
+
+anyTargetArch :: [String] -> Action Bool
+anyTargetArch = matchSetting TargetArch
+
+anyHostOs :: [String] -> Action Bool
+anyHostOs = matchSetting HostOs
+
+iosHost :: Action Bool
+iosHost = anyHostOs ["ios"]
+
+osxHost :: Action Bool
+osxHost = anyHostOs ["darwin"]
+
+windowsHost :: Action Bool
+windowsHost = anyHostOs ["mingw32", "cygwin32"]
+
+ghcWithInterpreter :: Action Bool
+ghcWithInterpreter = do
+    goodOs <- anyTargetOs [ "mingw32", "cygwin32", "linux", "solaris2"
+                          , "freebsd", "dragonfly", "netbsd", "openbsd"
+                          , "darwin", "kfreebsdgnu" ]
+    goodArch <- anyTargetArch [ "i386", "x86_64", "powerpc", "sparc"
+                              , "sparc64", "arm" ]
+    return $ goodOs && goodArch
+
+ghcEnableTablesNextToCode :: Action Bool
+ghcEnableTablesNextToCode = notM $ anyTargetArch ["ia64", "powerpc64", "powerpc64le"]
+
+useLibFFIForAdjustors :: Action Bool
+useLibFFIForAdjustors = notM $ anyTargetArch ["i386", "x86_64"]
+
+-- | Canonicalised GHC version number, used for integer version comparisons. We
+-- expand GhcMinorVersion to two digits by adding a leading zero if necessary.
+ghcCanonVersion :: Action String
+ghcCanonVersion = do
+    ghcMajorVersion <- setting GhcMajorVersion
+    ghcMinorVersion <- setting GhcMinorVersion
+    let leadingZero = [ '0' | length ghcMinorVersion == 1 ]
+    return $ ghcMajorVersion ++ leadingZero ++ ghcMinorVersion
+
+-- ref: https://ghc.haskell.org/trac/ghc/wiki/Building/Installing#HowGHCfindsitsfiles
+-- | On Windows we normally build a relocatable installation, which assumes that
+-- the library directory @libdir@ is in a fixed location relative to the GHC
+-- binary, namely @../lib@.
+relocatableBuild :: Action Bool
+relocatableBuild = windowsHost
+
+installDocDir :: Action String
+installDocDir = do
+    version <- setting ProjectVersion
+    dataDir <- setting InstallDataRootDir
+    return $ dataDir -/- ("doc/ghc-" ++ version)
+
+-- | Path to the GHC source tree.
+topDirectory :: Action FilePath
+topDirectory = fixAbsolutePathOnWindows =<< setting GhcSourcePath
+
+-- ref: mk/install.mk:101
+-- TODO: CroosCompilePrefix
+-- | Unix: override @libdir@ and @datadir@ to put GHC-specific files in a
+-- subdirectory with the version number included.
+installGhcLibDir :: Action String
+installGhcLibDir = do
+    rBuild <- relocatableBuild
+    libdir <- setting InstallLibDir
+    if rBuild then return libdir
+         else do
+             version <- setting ProjectVersion
+             return $ libdir -/- ("ghc-" ++ version)
+
+-- TODO: find out why we need version number in the dynamic suffix
+-- The current theory: dynamic libraries are eventually placed in a single
+-- giant directory in the load path of the dynamic linker, and hence we must
+-- distinguish different versions of GHC. In contrast static libraries live
+-- in their own per-package directory and hence do not need a unique filename.
+-- We also need to respect the system's dynamic extension, e.g. .dll or .so.
+libsuf :: Way -> Action String
+libsuf way =
+    if not (wayUnit Dynamic way)
+    then return $ waySuffix way ++ ".a" -- e.g., _p.a
+    else do
+        extension <- setting DynamicExtension  -- e.g., .dll or .so
+        version   <- setting ProjectVersion    -- e.g., 7.11.20141222
+        let prefix = wayPrefix $ removeWayUnit Dynamic way
+        -- e.g., p_ghc7.11.20141222.dll (the result)
+        return $ prefix ++ "-ghc" ++ version ++ extension
diff --git a/src/Rules.hs b/src/Rules.hs
new file mode 100644 (file)
index 0000000..d5c26e8
--- /dev/null
@@ -0,0 +1,123 @@
+module Rules (buildRules, oracleRules, packageTargets, topLevelTargets) where
+
+import qualified Hadrian.Oracles.ArgsHash
+import qualified Hadrian.Oracles.DirectoryContents
+import qualified Hadrian.Oracles.Path
+import qualified Hadrian.Oracles.TextFile
+
+import Expression
+import qualified Oracles.ModuleFiles
+import qualified Rules.Compile
+import qualified Rules.PackageData
+import qualified Rules.Dependencies
+import qualified Rules.Documentation
+import qualified Rules.Generate
+import qualified Rules.Configure
+import qualified Rules.Gmp
+import qualified Rules.Libffi
+import qualified Rules.Library
+import qualified Rules.Program
+import qualified Rules.Register
+import Settings
+import Target
+import UserSettings
+import Utilities
+
+allStages :: [Stage]
+allStages = [minBound ..]
+
+-- | This rule calls 'need' on all top-level build targets, respecting the
+-- 'Stage1Only' flag.
+topLevelTargets :: Rules ()
+topLevelTargets = action $ do
+    let libraryPackages = filter isLibrary (knownPackages \\ [libffi])
+    need =<< if stage1Only
+             then do
+                 libs <- concatForM [Stage0, Stage1] $ \stage ->
+                     concatForM libraryPackages $ packageTargets False stage
+                 prgs <- concatForM programsStage1Only $ packageTargets False Stage0
+                 return $ libs ++ prgs ++ inplaceLibCopyTargets
+             else do
+                 targets <- concatForM allStages $ \stage ->
+                     concatForM (knownPackages \\ [libffi]) $
+                        packageTargets False stage
+                 return $ targets ++ inplaceLibCopyTargets
+
+-- TODO: Get rid of the @includeGhciLib@ hack.
+-- | Return the list of targets associated with a given 'Stage' and 'Package'.
+-- By setting the Boolean parameter to False it is possible to exclude the GHCi
+-- library from the targets, and avoid running @ghc-cabal@ to determine wether
+-- GHCi library needs to be built for this package. We typically want to set
+-- this parameter to True, however it is important to set it to False when
+-- computing 'topLevelTargets', as otherwise the whole build gets sequentialised
+-- because we need to run @ghc-cabal@ in the order respecting package dependencies.
+packageTargets :: Bool -> Stage -> Package -> Action [FilePath]
+packageTargets includeGhciLib stage pkg = do
+    let context = vanillaContext stage pkg
+    activePackages <- stagePackages stage
+    if pkg `notElem` activePackages
+    then return [] -- Skip inactive packages.
+    else if isLibrary pkg
+        then do -- Collect all targets of a library package.
+            let pkgWays = if pkg == rts then getRtsWays else getLibraryWays
+            ways    <- interpretInContext context pkgWays
+            libs    <- mapM (pkgLibraryFile . Context stage pkg) ways
+            more    <- libraryTargets includeGhciLib context
+            setup   <- pkgSetupConfigFile context
+            return $ [ setup | not (nonCabalContext context) ] ++ libs ++ more
+        else do -- The only target of a program package is the executable.
+            prgContext <- programContext stage pkg
+            prgPath    <- programPath prgContext
+            return [prgPath]
+
+packageRules :: Rules ()
+packageRules = do
+    -- We cannot register multiple GHC packages in parallel. Also we cannot run
+    -- GHC when the package database is being mutated by "ghc-pkg". This is a
+    -- classic concurrent read exclusive write (CREW) conflict.
+    let maxConcurrentReaders = 1000
+    packageDb <- newResource "package-db" maxConcurrentReaders
+    let readPackageDb  = [(packageDb, 1)]
+        writePackageDb = [(packageDb, maxConcurrentReaders)]
+
+    let contexts        = liftM3 Context        allStages knownPackages allWays
+        vanillaContexts = liftM2 vanillaContext allStages knownPackages
+
+    forM_ contexts $ mconcat
+        [ Rules.Compile.compilePackage readPackageDb
+        , Rules.Library.buildPackageLibrary ]
+
+    let dynamicContexts = liftM3 Context [Stage1 ..] knownPackages [dynamic]
+    forM_ dynamicContexts Rules.Library.buildDynamicLib
+
+    forM_ (filter isProgram knownPackages) $
+        Rules.Program.buildProgram readPackageDb
+
+    forM_ vanillaContexts $ mconcat
+        [ Rules.PackageData.buildPackageData
+        , Rules.Dependencies.buildPackageDependencies readPackageDb
+        , Rules.Documentation.buildPackageDocumentation
+        , Rules.Library.buildPackageGhciLibrary
+        , Rules.Generate.generatePackageCode
+        , Rules.Register.registerPackage writePackageDb ]
+
+buildRules :: Rules ()
+buildRules = do
+    Rules.Configure.configureRules
+    Rules.Generate.copyRules
+    Rules.Generate.generateRules
+    Rules.Gmp.gmpRules
+    Rules.Libffi.libffiRules
+    packageRules
+
+oracleRules :: Rules ()
+oracleRules = do
+    Hadrian.Oracles.ArgsHash.argsHashOracle trackArgument getArgs
+    Hadrian.Oracles.DirectoryContents.directoryContentsOracle
+    Hadrian.Oracles.Path.pathOracle
+    Hadrian.Oracles.TextFile.textFileOracle
+    Oracles.ModuleFiles.moduleFilesOracle
+
+programsStage1Only :: [Package]
+programsStage1Only = [ deriveConstants, genapply, genprimopcode, ghc, ghcCabal
+                     , ghcPkg, hp2ps, hpc, hsc2hs, runGhc ]
diff --git a/src/Rules/Clean.hs b/src/Rules/Clean.hs
new file mode 100644 (file)
index 0000000..d11cbf5
--- /dev/null
@@ -0,0 +1,23 @@
+module Rules.Clean (clean, cleanSourceTree, cleanRules) where
+
+import Base
+
+clean :: Action ()
+clean = do
+    cleanSourceTree
+    putBuild "| Remove Hadrian files..."
+    path <- buildRoot
+    removeDirectory $ path -/- generatedDir
+    removeFilesAfter path ["//*"]
+    putSuccess "| Done. "
+
+cleanSourceTree :: Action ()
+cleanSourceTree = do
+    path <- buildRoot
+    forM_ [Stage0 ..] $ removeDirectory . (path -/-) . stageString
+    removeDirectory inplaceBinPath
+    removeDirectory inplaceLibPath
+    removeDirectory "sdistprep"
+
+cleanRules :: Rules ()
+cleanRules = "clean" ~> clean
diff --git a/src/Rules/Compile.hs b/src/Rules/Compile.hs
new file mode 100644 (file)
index 0000000..a4b1278
--- /dev/null
@@ -0,0 +1,83 @@
+module Rules.Compile (compilePackage) where
+
+import Hadrian.Oracles.TextFile
+
+import Base
+import Context
+import Expression
+import Rules.Generate
+import Target
+import Utilities
+
+compilePackage :: [(Resource, Int)] -> Context -> Rules ()
+compilePackage rs context@Context {..} = do
+    let dir             = "//" ++ contextDir context
+        nonHs extension = dir -/- extension <//> "*" <.> osuf way
+        compile compiler obj2src obj = do
+            src <- obj2src context obj
+            need [src]
+            needDependencies context src $ obj <.> "d"
+            buildWithResources rs $ target context (compiler stage) [src] [obj]
+        compileHs = \[obj, _hi] -> do
+            path <- buildPath context
+            (src, deps) <- lookupDependencies (path -/- ".dependencies") obj
+            need $ src : deps
+            when (isLibrary package) $ need =<< return <$> pkgConfFile context
+            needLibrary =<< contextDependencies context
+            buildWithResources rs $ target context (Ghc CompileHs stage) [src] [obj]
+
+    priority 2.0 $ do
+        nonHs "c"   %> compile (Ghc CompileCWithGhc) (obj2src "c"   isGeneratedCFile  )
+        nonHs "cmm" %> compile (Ghc CompileHs)       (obj2src "cmm" isGeneratedCmmFile)
+        nonHs "s"   %> compile (Ghc CompileHs)       (obj2src "S"   $ const False     )
+
+    -- TODO: Add dependencies for #include of .h and .hs-incl files (gcc -MM?).
+    [ dir <//> "*" <.> suf way | suf <- [    osuf,     hisuf] ] &%> compileHs
+    [ dir <//> "*" <.> suf way | suf <- [obootsuf, hibootsuf] ] &%> compileHs
+
+-- | Discover dependencies of a given source file by iteratively calling @gcc@
+-- in the @-MM -MG@ mode and building generated dependencies if they are missing
+-- until reaching a fixed point.
+needDependencies :: Context -> FilePath -> FilePath -> Action ()
+needDependencies context@Context {..} src depFile = discover
+  where
+    discover = do
+        build $ target 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.
+        let notFound = filter (\file -> file == takeFileName file) deps
+        -- We find the full paths to generated dependencies, so we can request
+        -- to build them by calling 'need'.
+        todo <- catMaybes <$> mapM (fullPathIfGenerated context) notFound
+
+        if null todo
+        then need deps -- The list of dependencies is final, need all
+        else do
+            need todo  -- Build newly discovered generated dependencies
+            discover   -- Continue the discovery process
+
+    parseFile :: FilePath -> Action [String]
+    parseFile file = do
+        input <- liftIO $ readFile file
+        case parseMakefile input of
+            [(_file, deps)] -> return deps
+            _               -> return []
+
+-- | Find a given 'FilePath' in the list of generated files in the given
+-- 'Context' and return its full path.
+fullPathIfGenerated :: Context -> FilePath -> Action (Maybe FilePath)
+fullPathIfGenerated context file = interpretInContext context $ do
+    generated <- generatedDependencies
+    return $ find ((== file) . takeFileName) generated
+
+obj2src :: String -> (FilePath -> Bool) -> Context -> FilePath -> Action FilePath
+obj2src extension isGenerated context@Context {..} obj
+    | isGenerated src = return src
+    | otherwise       = (pkgPath package ++) <$> suffix
+  where
+    src    = obj -<.> extension
+    suffix = do
+        path <- buildPath context
+        return $ fromMaybe ("Cannot determine source for " ++ obj)
+               $ stripPrefix (path -/- extension) src
diff --git a/src/Rules/Configure.hs b/src/Rules/Configure.hs
new file mode 100644 (file)
index 0000000..dd016c1
--- /dev/null
@@ -0,0 +1,42 @@
+module Rules.Configure (configureRules) where
+
+import qualified System.Info.Extra as System
+
+import Base
+import Builder
+import CommandLine
+import Context
+import GHC
+import Target
+import Utilities
+
+configureRules :: Rules ()
+configureRules = do
+    [configFile, "settings", configH] &%> \outs -> do
+        skip <- cmdSkipConfigure
+        if skip
+        then unlessM (doesFileExist configFile) $
+            error $ "Configuration file " ++ configFile ++ " is missing."
+                ++ "\nRun the configure script manually or do not use the "
+                ++ "--skip-configure flag."
+        else do
+            -- We cannot use windowsHost here due to a cyclic dependency.
+            when System.isWindows $ do
+                putBuild "| Checking for Windows tarballs..."
+                quietly $ cmd ["bash", "mk/get-win32-tarballs.sh", "download", System.arch]
+            let srcs    = map (<.> "in") outs
+                context = vanillaContext Stage0 compiler
+            need srcs
+            build $ target context (Configure ".") srcs outs
+
+    ["configure", configH <.> "in"] &%> \_ -> do
+        skip <- cmdSkipConfigure
+        if skip
+        then unlessM (doesFileExist "configure") $
+            error $ "The configure script is missing.\nRun the boot script"
+                ++ " manually or do not use the --skip-configure flag."
+        else do
+            need ["configure.ac"]
+            putBuild "| Running boot..."
+            verbosity <- getVerbosity
+            quietly $ cmd [EchoStdout (verbosity >= Loud)] "python3 boot"
diff --git a/src/Rules/Dependencies.hs b/src/Rules/Dependencies.hs
new file mode 100644 (file)
index 0000000..f27ef0d
--- /dev/null
@@ -0,0 +1,33 @@
+module Rules.Dependencies (buildPackageDependencies) where
+
+import Data.Bifunctor
+import Data.Function
+
+import Base
+import Context
+import Expression
+import Oracles.ModuleFiles
+import Rules.Generate
+import Target
+import Utilities
+
+buildPackageDependencies :: [(Resource, Int)] -> Context -> Rules ()
+buildPackageDependencies rs context@Context {..} =
+    "//" ++ contextDir context -/- ".dependencies" %> \deps -> do
+        srcs <- hsSources context
+        need srcs
+        orderOnly =<< interpretInContext context generatedDependencies
+        let mk = deps <.> "mk"
+        if null srcs
+        then writeFileChanged mk ""
+        else buildWithResources rs $
+            target context (Ghc FindHsDependencies stage) srcs [mk]
+        removeFile $ mk <.> "bak"
+        mkDeps <- readFile' mk
+        writeFileChanged deps . unlines
+                              . map (\(src, deps) -> unwords $ src : deps)
+                              . map (bimap unifyPath (map unifyPath))
+                              . map (bimap head concat . unzip)
+                              . groupBy ((==) `on` fst)
+                              . sortBy (compare `on` fst)
+                              $ parseMakefile mkDeps
diff --git a/src/Rules/Documentation.hs b/src/Rules/Documentation.hs
new file mode 100644 (file)
index 0000000..5a5698c
--- /dev/null
@@ -0,0 +1,197 @@
+module Rules.Documentation (
+    -- * Rules
+    buildPackageDocumentation, documentationRules,
+
+    -- * Utilities
+    haddockDependencies
+    ) where
+
+import Base
+import Context
+import Flavour
+import GHC
+import Oracles.ModuleFiles
+import Oracles.PackageData
+import Settings
+import Target
+import Utilities
+
+-- | Build all documentation
+documentationRules :: Rules ()
+documentationRules = do
+    buildHtmlDocumentation
+    buildPdfDocumentation
+    buildDocumentationArchives
+    buildManPage
+    "//docs//gen_contents_index" %> copyFile "libraries/gen_contents_index"
+    "//docs//prologue.txt" %> copyFile "libraries/prologue.txt"
+    "docs" ~> do
+        root <- buildRoot
+        let html = htmlRoot -/- "index.html"
+            archives = map pathArchive docPaths
+            pdfs = map pathPdf $ docPaths \\ [ "libraries" ]
+        need $ map (root -/-) $ [html] ++ archives ++ pdfs
+        need [ root -/- htmlRoot -/- "libraries" -/- "gen_contents_index" ]
+        need [ root -/- htmlRoot -/- "libraries" -/- "prologue.txt" ]
+        need [manPagePath]
+
+manPagePath :: FilePath
+manPagePath = "_build/docs/users_guide/build-man/ghc.1"
+
+-- TODO: Add support for Documentation Packages so we can
+-- run the builders without this hack.
+docPackage :: Package
+docPackage = hsLibrary "Documentation" "docs"
+
+docPaths :: [FilePath]
+docPaths = [ "libraries", "users_guide", "Haddock" ]
+
+docRoot :: FilePath
+docRoot = "docs"
+
+htmlRoot :: FilePath
+htmlRoot = docRoot -/- "html"
+
+pdfRoot :: FilePath
+pdfRoot = docRoot -/- "pdfs"
+
+archiveRoot :: FilePath
+archiveRoot = docRoot -/- "archives"
+
+pathPdf :: FilePath -> FilePath
+pathPdf path = pdfRoot -/- path <.> ".pdf"
+
+pathIndex :: FilePath -> FilePath
+pathIndex path = htmlRoot -/- path -/- "index.html"
+
+pathArchive :: FilePath -> FilePath
+pathArchive path = archiveRoot -/- path <.> "html.tar.xz"
+
+-- TODO: Replace this with pkgPath when support is added
+-- for Documentation Packages.
+pathPath :: FilePath -> FilePath
+pathPath "users_guide" = "docs/users_guide"
+pathPath "Haddock" = "utils/haddock/doc"
+pathPath _ = ""
+
+----------------------------------------------------------------------
+-- HTML
+
+-- | Build all HTML documentation
+buildHtmlDocumentation :: Rules ()
+buildHtmlDocumentation = do
+    mapM_ buildSphinxHtml $ docPaths \\ [ "libraries" ]
+    buildLibraryDocumentation
+    "//" ++ htmlRoot -/- "index.html" %> \file -> do
+        root <- buildRoot
+        need $ map ((root -/-) . pathIndex) docPaths
+        copyFileUntracked "docs/index.html" file
+
+-----------------------------
+-- Sphinx
+
+-- | Compile a Sphinx ReStructured Text package to HTML
+buildSphinxHtml :: FilePath -> Rules ()
+buildSphinxHtml path = do
+    "//" ++ htmlRoot -/- path -/- "index.html" %> \file -> do
+        let dest = takeDirectory file
+            context = vanillaContext Stage0 docPackage
+        build $ target context (Sphinx Html) [pathPath path] [dest]
+
+-----------------------------
+-- Haddock
+
+-- | Build the haddocks for GHC's libraries
+buildLibraryDocumentation :: Rules ()
+buildLibraryDocumentation = do
+    "//" ++ htmlRoot -/- "libraries/index.html" %> \file -> do
+        haddocks <- allHaddocks
+        need haddocks
+        let libDocs = filter (\x -> takeFileName x /= "ghc.haddock") haddocks
+            context = vanillaContext Stage2 docPackage
+        build $ target context (Haddock BuildIndex) libDocs [file]
+
+allHaddocks :: Action [FilePath]
+allHaddocks = do
+    pkgs <- stagePackages Stage1
+    sequence [ pkgHaddockFile $ vanillaContext Stage1 pkg
+             | pkg <- pkgs, isLibrary pkg, isHsPackage pkg ]
+
+haddockHtmlLib :: FilePath
+haddockHtmlLib = "inplace/lib/html/haddock-util.js"
+
+-- | Find the haddock files for the dependencies of the current library
+haddockDependencies :: Context -> Action [FilePath]
+haddockDependencies context = do
+    path     <- buildPath context
+    depNames <- pkgDataList $ DepNames path
+    sequence [ pkgHaddockFile $ vanillaContext Stage1 depPkg
+             | Just depPkg <- map findPackageByName depNames, depPkg /= rts ]
+
+-- Note: this build rule creates plenty of files, not just the .haddock one.
+-- All of them go into the 'doc' subdirectory. Pedantically tracking all built
+-- files in the Shake database seems fragile and unnecessary.
+buildPackageDocumentation :: Context -> Rules ()
+buildPackageDocumentation context@Context {..} = when (stage == Stage1) $ do
+
+    -- Js and Css files for haddock output
+    when (package == haddock) $ haddockHtmlLib %> \_ -> do
+        let dir = takeDirectory haddockHtmlLib
+        liftIO $ removeFiles dir ["//*"]
+        copyDirectory "utils/haddock/haddock-api/resources/html" dir
+
+    -- Per-package haddocks
+    "//" ++ pkgName package <.> "haddock" %> \file -> do
+        haddocks <- haddockDependencies context
+        srcs <- hsSources context
+        need $ srcs ++ haddocks ++ [haddockHtmlLib]
+
+        -- Build Haddock documentation
+        -- TODO: pass the correct way from Rules via Context
+        dynamicPrograms <- dynamicGhcPrograms <$> flavour
+        let haddockWay = if dynamicPrograms then dynamic else vanilla
+        build $ target (context {way = haddockWay}) (Haddock BuildPackage)
+                       srcs [file]
+
+----------------------------------------------------------------------
+-- PDF
+
+-- | Build all PDF documentation
+buildPdfDocumentation :: Rules ()
+buildPdfDocumentation = mapM_ buildSphinxPdf docPaths
+
+-- | Compile a Sphinx ReStructured Text package to LaTeX
+buildSphinxPdf :: FilePath -> Rules ()
+buildSphinxPdf path = do
+    "//" ++ path <.> "pdf" %> \file -> do
+        let context = vanillaContext Stage0 docPackage
+        withTempDir $ \dir -> do
+            build $ target context (Sphinx Latex) [pathPath path] [dir]
+            build $ target context Xelatex [path <.> "tex"] [dir]
+            copyFileUntracked (dir -/- path <.> "pdf") file
+
+----------------------------------------------------------------------
+-- Archive
+
+-- | Build archives of documentation
+buildDocumentationArchives :: Rules ()
+buildDocumentationArchives = mapM_ buildArchive docPaths
+
+buildArchive :: FilePath -> Rules ()
+buildArchive path = do
+    "//" ++ pathArchive path %> \file -> do
+        root <- buildRoot
+        let context = vanillaContext Stage0 docPackage
+            src = root -/- pathIndex path
+        need [src]
+        build $ target context (Tar Create) [takeDirectory src] [file]
+
+-- | build man page
+buildManPage :: Rules ()
+buildManPage = do
+    manPagePath %> \file -> do
+        need ["docs/users_guide/ghc.rst"]
+        let context = vanillaContext Stage0 docPackage
+        withTempDir $ \dir -> do
+            build $ target context (Sphinx Man) ["docs/users_guide"] [dir]
+            copyFileUntracked (dir -/- "ghc.1") file
diff --git a/src/Rules/Generate.hs b/src/Rules/Generate.hs
new file mode 100644 (file)
index 0000000..8e2b65d
--- /dev/null
@@ -0,0 +1,482 @@
+module Rules.Generate (
+    isGeneratedCFile, isGeneratedCmmFile, generatePackageCode, generateRules,
+    copyRules, includesDependencies, generatedDependencies
+    ) where
+
+import Base
+import Expression
+import Flavour
+import Oracles.Flag
+import Oracles.ModuleFiles
+import Oracles.Setting
+import Rules.Gmp
+import Rules.Libffi
+import Target
+import Settings
+import Settings.Packages.Rts
+import Utilities
+
+-- | Track this file to rebuild generated files whenever it changes.
+trackGenerateHs :: Expr ()
+trackGenerateHs = expr $ need [sourcePath -/- "Rules/Generate.hs"]
+
+primopsSource :: FilePath
+primopsSource = "compiler/prelude/primops.txt.pp"
+
+primopsTxt :: Stage -> FilePath
+primopsTxt stage = contextDir (vanillaContext stage compiler) -/- "primops.txt"
+
+platformH :: Stage -> FilePath
+platformH stage = contextDir (vanillaContext stage compiler) -/- "ghc_boot_platform.h"
+
+isGeneratedCFile :: FilePath -> Bool
+isGeneratedCFile file = takeBaseName file `elem` ["Evac_thr", "Scav_thr"]
+
+isGeneratedCmmFile :: FilePath -> Bool
+isGeneratedCmmFile file = takeBaseName file == "AutoApply"
+
+includesDependencies :: [FilePath]
+includesDependencies = fmap (generatedDir -/-)
+    [ "ghcautoconf.h"
+    , "ghcplatform.h"
+    , "ghcversion.h" ]
+
+ghcPrimDependencies :: Expr [FilePath]
+ghcPrimDependencies = do
+    stage <- getStage
+    path  <- expr $ buildPath (vanillaContext stage ghcPrim)
+    return [path -/- "GHC/Prim.hs", path -/- "GHC/PrimopWrappers.hs"]
+
+derivedConstantsDependencies :: [FilePath]
+derivedConstantsDependencies = fmap (generatedDir -/-)
+    [ "DerivedConstants.h"
+    , "GHCConstantsHaskellExports.hs"
+    , "GHCConstantsHaskellType.hs"
+    , "GHCConstantsHaskellWrappers.hs" ]
+
+compilerDependencies :: Expr [FilePath]
+compilerDependencies = do
+    root    <- getBuildRoot
+    stage   <- getStage
+    isGmp   <- (== integerGmp) <$> getIntegerPackage
+    ghcPath <- expr $ buildPath (vanillaContext stage compiler)
+    gmpPath <- expr gmpBuildPath
+    rtsPath <- expr rtsBuildPath
+    mconcat [ return [root -/- platformH stage]
+            , return ((root -/-) <$> includesDependencies)
+            , return ((root -/-) <$> derivedConstantsDependencies)
+            , notStage0 ? isGmp ? return [gmpPath -/- gmpLibraryH]
+            , notStage0 ? return ((rtsPath -/-) <$> libffiDependencies)
+            , return $ fmap (ghcPath -/-)
+                  [ "primop-can-fail.hs-incl"
+                  , "primop-code-size.hs-incl"
+                  , "primop-commutable.hs-incl"
+                  , "primop-data-decl.hs-incl"
+                  , "primop-fixity.hs-incl"
+                  , "primop-has-side-effects.hs-incl"
+                  , "primop-list.hs-incl"
+                  , "primop-out-of-line.hs-incl"
+                  , "primop-primop-info.hs-incl"
+                  , "primop-strictness.hs-incl"
+                  , "primop-tag.hs-incl"
+                  , "primop-vector-tycons.hs-incl"
+                  , "primop-vector-tys-exports.hs-incl"
+                  , "primop-vector-tys.hs-incl"
+                  , "primop-vector-uniques.hs-incl" ] ]
+
+generatedDependencies :: Expr [FilePath]
+generatedDependencies = do
+    root    <- getBuildRoot
+    rtsPath <- expr rtsBuildPath
+    mconcat [ package compiler ? compilerDependencies
+            , package ghcPrim  ? ghcPrimDependencies
+            , package rts      ? return (fmap (rtsPath -/-) libffiDependencies
+                ++ fmap (root -/-) includesDependencies
+                ++ fmap (root -/-) derivedConstantsDependencies)
+            , stage0 ? return (fmap (root -/-) includesDependencies) ]
+
+generate :: FilePath -> Context -> Expr String -> Action ()
+generate file context expr = do
+    contents <- interpretInContext context expr
+    writeFileChanged file contents
+    putSuccess $ "| Successfully generated " ++ file ++ "."
+
+generatePackageCode :: Context -> Rules ()
+generatePackageCode context@(Context stage pkg _) =
+    let dir         = contextDir context
+        generated f = ("//" ++ dir ++ "//*.hs") ?== f && not ("//autogen/*" ?== f)
+        go gen file = generate file context gen
+    in do
+        generated ?> \file -> do
+            let unpack = fromMaybe . error $ "No generator for " ++ file ++ "."
+            (src, builder) <- unpack <$> findGenerator context file
+            need [src]
+            build $ target context builder [src] [file]
+            let boot = src -<.> "hs-boot"
+            whenM (doesFileExist boot) . copyFile boot $ file -<.> "hs-boot"
+
+        priority 2.0 $ do
+            when (pkg == compiler) $ "//" -/- dir -/- "Config.hs" %> go generateConfigHs
+            when (pkg == ghcPkg) $ "//" -/- dir -/- "Version.hs" %> go generateVersionHs
+
+        -- TODO: needing platformH is ugly and fragile
+        when (pkg == compiler) $ do
+            "//" ++ primopsTxt stage %> \file -> do
+                root <- buildRoot
+                need $ [root -/- platformH stage, primopsSource]
+                    ++ fmap (root -/-) includesDependencies
+                build $ target context HsCpp [primopsSource] [file]
+
+            "//" ++ platformH stage %> go generateGhcBootPlatformH
+
+        -- TODO: why different folders for generated files?
+        priority 2.0 $ fmap (("//" ++ dir) -/-)
+            [ "GHC/Prim.hs"
+            , "GHC/PrimopWrappers.hs"
+            , "*.hs-incl" ] |%> \file -> do
+                root <- buildRoot
+                need [root -/- primopsTxt stage]
+                build $ target context GenPrimopCode [root -/- primopsTxt stage] [file]
+
+        when (pkg == rts) $ "//" ++ dir -/- "cmm/AutoApply.cmm" %> \file ->
+            build $ target context GenApply [] [file]
+
+copyRules :: Rules ()
+copyRules = do
+    (inplaceLibPath -/- "ghc-usage.txt")     <~ return "driver"
+    (inplaceLibPath -/- "ghci-usage.txt"  )  <~ return "driver"
+    (inplaceLibPath -/- "llvm-targets")      <~ return "."
+    (inplaceLibPath -/- "platformConstants") <~ (buildRoot <&> (-/- generatedDir))
+    (inplaceLibPath -/- "settings")          <~ return "."
+    (inplaceLibPath -/- "template-hsc.h")    <~ return (pkgPath hsc2hs)
+    "//c/sm/Evac_thr.c" %> copyFile (pkgPath rts -/- "sm/Evac.c")
+    "//c/sm/Scav_thr.c" %> copyFile (pkgPath rts -/- "sm/Scav.c")
+  where
+    pattern <~ mdir = pattern %> \file -> do
+        dir <- mdir
+        copyFile (dir -/- takeFileName file) file
+
+generateRules :: Rules ()
+generateRules = do
+    priority 2.0 $ ("//" ++ generatedDir -/- "ghcautoconf.h") <~ generateGhcAutoconfH
+    priority 2.0 $ ("//" ++ generatedDir -/- "ghcplatform.h") <~ generateGhcPlatformH
+    priority 2.0 $ ("//" ++ generatedDir -/-  "ghcversion.h") <~ generateGhcVersionH
+
+    ghcSplitPath %> \_ -> do
+        generate ghcSplitPath emptyTarget generateGhcSplit
+        makeExecutable ghcSplitPath
+
+    -- TODO: simplify, get rid of fake rts context
+    "//" ++ generatedDir ++ "//*" %> \file -> do
+        withTempDir $ \dir -> build $
+            target rtsContext DeriveConstants [] [file, dir]
+  where
+    file <~ gen = file %> \out -> generate out emptyTarget gen
+
+-- TODO: Use the Types, Luke! (drop partial function)
+-- We sometimes need to evaluate expressions that do not require knowing all
+-- information about the context. In this case, we don't want to know anything.
+emptyTarget :: Context
+emptyTarget = vanillaContext (error "Rules.Generate.emptyTarget: unknown stage")
+                             (error "Rules.Generate.emptyTarget: unknown package")
+
+-- Generators
+
+-- | Given a 'String' replace charaters '.' and '-' by underscores ('_') so that
+-- the resulting 'String' is a valid C preprocessor identifier.
+cppify :: String -> String
+cppify = replaceEq '-' '_' . replaceEq '.' '_'
+
+ghcSplitSource :: FilePath
+ghcSplitSource = "driver/split/ghc-split.pl"
+
+-- ref: rules/build-perl.mk
+-- | Generate the @ghc-split@ Perl script.
+generateGhcSplit :: Expr String
+generateGhcSplit = do
+    trackGenerateHs
+    targetPlatform <- getSetting TargetPlatform
+    ghcEnableTNC   <- expr $ yesNo <$> ghcEnableTablesNextToCode
+    perlPath       <- getBuilderPath Perl
+    contents       <- expr $ readFileLines ghcSplitSource
+    return . unlines $
+        [ "#!" ++ perlPath
+        , "my $TARGETPLATFORM = " ++ show targetPlatform ++ ";"
+        -- I don't see where the ghc-split tool uses TNC, but
+        -- it's in the build-perl macro.
+        , "my $TABLES_NEXT_TO_CODE = " ++ show ghcEnableTNC ++ ";"
+        ] ++ contents
+
+-- | Generate @ghcplatform.h@ header.
+generateGhcPlatformH :: Expr String
+generateGhcPlatformH = do
+    trackGenerateHs
+    hostPlatform   <- getSetting HostPlatform
+    hostArch       <- getSetting HostArch
+    hostOs         <- getSetting HostOs
+    hostVendor     <- getSetting HostVendor
+    targetPlatform <- getSetting TargetPlatform
+    targetArch     <- getSetting TargetArch
+    targetOs       <- getSetting TargetOs
+    targetVendor   <- getSetting TargetVendor
+    ghcUnreg       <- expr $ flag GhcUnregisterised
+    return . unlines $
+        [ "#ifndef __GHCPLATFORM_H__"
+        , "#define __GHCPLATFORM_H__"
+        , ""
+        , "#define BuildPlatform_TYPE  " ++ cppify hostPlatform
+        , "#define HostPlatform_TYPE   " ++ cppify targetPlatform
+        , ""
+        , "#define " ++ cppify hostPlatform   ++ "_BUILD 1"
+        , "#define " ++ cppify targetPlatform ++ "_HOST 1"
+        , ""
+        , "#define " ++ hostArch   ++ "_BUILD_ARCH 1"
+        , "#define " ++ targetArch ++ "_HOST_ARCH 1"
+        , "#define BUILD_ARCH " ++ show hostArch
+        , "#define HOST_ARCH "  ++ show targetArch
+        , ""
+        , "#define " ++ hostOs   ++ "_BUILD_OS 1"
+        , "#define " ++ targetOs ++ "_HOST_OS 1"
+        , "#define BUILD_OS " ++ show hostOs
+        , "#define HOST_OS "  ++ show targetOs
+        , ""
+        , "#define " ++ hostVendor   ++ "_BUILD_VENDOR 1"
+        , "#define " ++ targetVendor ++ "_HOST_VENDOR 1"
+        , "#define BUILD_VENDOR " ++ show hostVendor
+        , "#define HOST_VENDOR "  ++ show targetVendor
+        , ""
+        , "/* These TARGET macros are for backwards compatibility... DO NOT USE! */"
+        , "#define TargetPlatform_TYPE " ++ cppify targetPlatform
+        , "#define " ++ cppify targetPlatform ++ "_TARGET 1"
+        , "#define " ++ targetArch ++ "_TARGET_ARCH 1"
+        , "#define TARGET_ARCH " ++ show targetArch
+        , "#define " ++ targetOs ++ "_TARGET_OS 1"
+        , "#define TARGET_OS " ++ show targetOs
+        , "#define " ++ targetVendor ++ "_TARGET_VENDOR 1" ]
+        ++
+        [ "#define UnregisterisedCompiler 1" | ghcUnreg ]
+        ++
+        [ "\n#endif /* __GHCPLATFORM_H__ */" ]
+
+-- | Generate @Config.hs@ files.
+generateConfigHs :: Expr String
+generateConfigHs = do
+    trackGenerateHs
+    cProjectName        <- getSetting ProjectName
+    cProjectGitCommitId <- getSetting ProjectGitCommitId
+    cProjectVersion     <- getSetting ProjectVersion
+    cProjectVersionInt  <- getSetting ProjectVersionInt
+    cProjectPatchLevel  <- getSetting ProjectPatchLevel
+    cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
+    cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
+    cBooterVersion      <- getSetting GhcVersion
+    intLib              <- getIntegerPackage
+    debugged            <- ghcDebugged    <$> expr flavour
+    let cIntegerLibraryType
+            | intLib == integerGmp    = "IntegerGMP"
+            | intLib == integerSimple = "IntegerSimple"
+            | otherwise = error $ "Unknown integer library: " ++ pkgName intLib
+    cSupportsSplitObjs         <- expr $ yesNo <$> supportsSplitObjects
+    cGhcWithInterpreter        <- expr $ yesNo <$> ghcWithInterpreter
+    cGhcWithNativeCodeGen      <- expr $ yesNo <$> ghcWithNativeCodeGen
+    cGhcWithSMP                <- expr $ yesNo <$> ghcWithSMP
+    cGhcEnableTablesNextToCode <- expr $ yesNo <$> ghcEnableTablesNextToCode
+    cLeadingUnderscore         <- expr $ yesNo <$> flag LeadingUnderscore
+    cGHC_UNLIT_PGM             <- fmap takeFileName $ getBuilderPath Unlit
+    cLibFFI                    <- expr useLibFFIForAdjustors
+    rtsWays                    <- getRtsWays
+    cGhcRtsWithLibdw           <- expr $ flag WithLibdw
+    let cGhcRTSWays = unwords $ map show rtsWays
+    return $ unlines
+        [ "{-# LANGUAGE CPP #-}"
+        , "module Config where"
+        , ""
+        , "import GhcPrelude"
+        , ""
+        , "#include \"ghc_boot_platform.h\""
+        , ""
+        , "data IntegerLibrary = IntegerGMP"
+        , "                    | IntegerSimple"
+        , "                    deriving Eq"
+        , ""
+        , "cBuildPlatformString :: String"
+        , "cBuildPlatformString = BuildPlatform_NAME"
+        , "cHostPlatformString :: String"
+        , "cHostPlatformString = HostPlatform_NAME"
+        , "cTargetPlatformString :: String"
+        , "cTargetPlatformString = TargetPlatform_NAME"
+        , ""
+        , "cProjectName          :: String"
+        , "cProjectName          = " ++ show cProjectName
+        , "cProjectGitCommitId   :: String"
+        , "cProjectGitCommitId   = " ++ show cProjectGitCommitId
+        , "cProjectVersion       :: String"
+        , "cProjectVersion       = " ++ show cProjectVersion
+        , "cProjectVersionInt    :: String"
+        , "cProjectVersionInt    = " ++ show cProjectVersionInt
+        , "cProjectPatchLevel    :: String"
+        , "cProjectPatchLevel    = " ++ show cProjectPatchLevel
+        , "cProjectPatchLevel1   :: String"
+        , "cProjectPatchLevel1   = " ++ show cProjectPatchLevel1
+        , "cProjectPatchLevel2   :: String"
+        , "cProjectPatchLevel2   = " ++ show cProjectPatchLevel2
+        , "cBooterVersion        :: String"
+        , "cBooterVersion        = " ++ show cBooterVersion
+        , "cStage                :: String"
+        , "cStage                = show (STAGE :: Int)"
+        , "cIntegerLibrary       :: String"
+        , "cIntegerLibrary       = " ++ show (pkgName intLib)
+        , "cIntegerLibraryType   :: IntegerLibrary"
+        , "cIntegerLibraryType   = " ++ cIntegerLibraryType
+        , "cSupportsSplitObjs    :: String"
+        , "cSupportsSplitObjs    = " ++ show cSupportsSplitObjs
+        , "cGhcWithInterpreter   :: String"
+        , "cGhcWithInterpreter   = " ++ show cGhcWithInterpreter
+        , "cGhcWithNativeCodeGen :: String"
+        , "cGhcWithNativeCodeGen = " ++ show cGhcWithNativeCodeGen
+        , "cGhcWithSMP           :: String"
+        , "cGhcWithSMP           = " ++ show cGhcWithSMP
+        , "cGhcRTSWays           :: String"
+        , "cGhcRTSWays           = " ++ show cGhcRTSWays
+        , "cGhcEnableTablesNextToCode :: String"
+        , "cGhcEnableTablesNextToCode = " ++ show cGhcEnableTablesNextToCode
+        , "cLeadingUnderscore    :: String"
+        , "cLeadingUnderscore    = " ++ show cLeadingUnderscore
+        , "cGHC_UNLIT_PGM        :: String"
+        , "cGHC_UNLIT_PGM        = " ++ show cGHC_UNLIT_PGM
+        , "cGHC_SPLIT_PGM        :: String"
+        , "cGHC_SPLIT_PGM        = " ++ show "ghc-split"
+        , "cLibFFI               :: Bool"
+        , "cLibFFI               = " ++ show cLibFFI
+        , "cGhcThreaded :: Bool"
+        , "cGhcThreaded = " ++ show (threaded `elem` rtsWays)
+        , "cGhcDebugged :: Bool"
+        , "cGhcDebugged = " ++ show debugged
+        , "cGhcRtsWithLibdw :: Bool"
+        , "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]
+
+-- | Generate @ghcautoconf.h@ header.
+generateGhcAutoconfH :: Expr String
+generateGhcAutoconfH = do
+    trackGenerateHs
+    configHContents  <- expr $ map undefinePackage <$> readFileLines configH
+    tablesNextToCode <- expr ghcEnableTablesNextToCode
+    ghcUnreg         <- expr $ flag GhcUnregisterised
+    ccLlvmBackend    <- getSetting CcLlvmBackend
+    ccClangBackend   <- getSetting CcClangBackend
+    return . unlines $
+        [ "#ifndef __GHCAUTOCONF_H__"
+        , "#define __GHCAUTOCONF_H__" ]
+        ++ configHContents ++
+        [ "\n#define TABLES_NEXT_TO_CODE 1" | tablesNextToCode && not ghcUnreg ]
+        ++
+        [ "\n#define llvm_CC_FLAVOR 1"      | ccLlvmBackend == "1" ]
+        ++
+        [ "\n#define clang_CC_FLAVOR 1"     | ccClangBackend == "1" ]
+        ++
+        [ "#endif /* __GHCAUTOCONF_H__ */" ]
+  where
+    undefinePackage s
+        | "#define PACKAGE_" `isPrefixOf` s
+            = "/* #undef " ++ takeWhile (/=' ') (drop 8 s) ++ " */"
+        | otherwise = s
+
+-- | Generate @ghc_boot_platform.h@ headers.
+generateGhcBootPlatformH :: Expr String
+generateGhcBootPlatformH = do
+    trackGenerateHs
+    stage <- getStage
+    let chooseSetting x y = getSetting $ if stage == Stage0 then x else y
+    buildPlatform  <- chooseSetting BuildPlatform HostPlatform
+    buildArch      <- chooseSetting BuildArch     HostArch
+    buildOs        <- chooseSetting BuildOs       HostOs
+    buildVendor    <- chooseSetting BuildVendor   HostVendor
+    hostPlatform   <- chooseSetting HostPlatform  TargetPlatform
+    hostArch       <- chooseSetting HostArch      TargetArch
+    hostOs         <- chooseSetting HostOs        TargetOs
+    hostVendor     <- chooseSetting HostVendor    TargetVendor
+    targetPlatform <- getSetting TargetPlatform
+    targetArch     <- getSetting TargetArch
+    llvmTarget     <- getSetting LlvmTarget
+    targetOs       <- getSetting TargetOs
+    targetVendor   <- getSetting TargetVendor
+    return $ unlines
+        [ "#ifndef __PLATFORM_H__"
+        , "#define __PLATFORM_H__"
+        , ""
+        , "#define BuildPlatform_NAME  " ++ show buildPlatform
+        , "#define HostPlatform_NAME   " ++ show hostPlatform
+        , "#define TargetPlatform_NAME " ++ show targetPlatform
+        , ""
+        , "#define " ++ cppify buildPlatform  ++ "_BUILD 1"
+        , "#define " ++ cppify hostPlatform   ++ "_HOST 1"
+        , "#define " ++ cppify targetPlatform ++ "_TARGET 1"
+        , ""
+        , "#define " ++ buildArch  ++ "_BUILD_ARCH 1"
+        , "#define " ++ hostArch   ++ "_HOST_ARCH 1"
+        , "#define " ++ targetArch ++ "_TARGET_ARCH 1"
+        , "#define BUILD_ARCH "  ++ show buildArch
+        , "#define HOST_ARCH "   ++ show hostArch
+        , "#define TARGET_ARCH " ++ show targetArch
+        , "#define LLVM_TARGET " ++ show llvmTarget
+        , ""
+        , "#define " ++ buildOs  ++ "_BUILD_OS 1"
+        , "#define " ++ hostOs   ++ "_HOST_OS 1"
+        , "#define " ++ targetOs ++ "_TARGET_OS 1"
+        , "#define BUILD_OS "  ++ show buildOs
+        , "#define HOST_OS "   ++ show hostOs
+        , "#define TARGET_OS " ++ show targetOs
+        , ""
+        , "#define " ++ buildVendor  ++ "_BUILD_VENDOR 1"
+        , "#define " ++ hostVendor   ++ "_HOST_VENDOR 1"
+        , "#define " ++ targetVendor ++ "_TARGET_VENDOR  1"
+        , "#define BUILD_VENDOR "  ++ show buildVendor
+        , "#define HOST_VENDOR "   ++ show hostVendor
+        , "#define TARGET_VENDOR " ++ show targetVendor
+        , ""
+        , "#endif /* __PLATFORM_H__ */" ]
+
+-- | Generate @ghcversion.h@ header.
+generateGhcVersionH :: Expr String
+generateGhcVersionH = do
+    trackGenerateHs
+    version     <- getSetting ProjectVersionInt
+    patchLevel1 <- getSetting ProjectPatchLevel1
+    patchLevel2 <- getSetting ProjectPatchLevel2
+    return . unlines $
+        [ "#ifndef __GHCVERSION_H__"
+        , "#define __GHCVERSION_H__"
+        , ""
+        , "#ifndef __GLASGOW_HASKELL__"
+        , "# define __GLASGOW_HASKELL__ " ++ version
+        , "#endif"
+        , ""]
+        ++
+        [ "#define __GLASGOW_HASKELL_PATCHLEVEL1__ " ++ patchLevel1 | patchLevel1 /= "" ]
+        ++
+        [ "#define __GLASGOW_HASKELL_PATCHLEVEL2__ " ++ patchLevel2 | patchLevel2 /= "" ]
+        ++
+        [ ""
+        , "#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\\"
+        , "   ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \\"
+        , "   ((ma)*100+(mi)) == __GLASGOW_HASKELL__    \\"
+        , "          && (pl1) <  __GLASGOW_HASKELL_PATCHLEVEL1__ || \\"
+        , "   ((ma)*100+(mi)) == __GLASGOW_HASKELL__    \\"
+        , "          && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__ \\"
+        , "          && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ )"
+        , ""
+        , "#endif /* __GHCVERSION_H__ */" ]
+
+-- | Generate @Version.hs@ files.
+generateVersionHs :: Expr String
+generateVersionHs = do
+    trackGenerateHs
+    projectVersion <- getSetting ProjectVersion
+    targetOs       <- getSetting TargetOs
+    targetArch     <- getSetting TargetArch
+    return $ unlines
+        [ "module Version where"
+        , "version, targetOS, targetARCH :: String"
+        , "version    = " ++ show projectVersion
+        , "targetOS   = " ++ show targetOs
+        , "targetARCH = " ++ show targetArch ]
diff --git a/src/Rules/Gmp.hs b/src/Rules/Gmp.hs
new file mode 100644 (file)
index 0000000..46fad8a
--- /dev/null
@@ -0,0 +1,119 @@
+module Rules.Gmp (
+    gmpRules, gmpBuildPath, gmpObjectsDir, gmpLibraryH, gmpBuildInfoPath
+    ) where
+
+import Base
+import Context
+import GHC
+import Oracles.Setting
+import Target
+import Utilities
+
+gmpBase :: FilePath
+gmpBase = pkgPath integerGmp -/- "gmp"
+
+gmpLibraryInTreeH :: FilePath
+gmpLibraryInTreeH = "include/gmp.h"
+
+gmpLibrary :: FilePath
+gmpLibrary = ".libs/libgmp.a"
+
+-- | GMP is considered a Stage1 package. This determines GMP build directory.
+gmpContext :: Context
+gmpContext = vanillaContext Stage1 integerGmp
+
+-- | Build directory for in-tree GMP library.
+gmpBuildPath :: Action FilePath
+gmpBuildPath = buildRoot <&> (-/- stageString (stage gmpContext) -/- "gmp")
+
+-- | GMP library header, relative to 'gmpBuildPath'.
+gmpLibraryH :: FilePath
+gmpLibraryH = "include/ghc-gmp.h"
+
+-- | Directory for GMP library object files, relative to 'gmpBuildPath'.
+gmpObjectsDir :: FilePath
+gmpObjectsDir = "objs"
+
+-- | Path to the GMP library buildinfo file.
+gmpBuildInfoPath :: FilePath
+gmpBuildInfoPath = pkgPath integerGmp -/- "integer-gmp.buildinfo"
+
+configureEnvironment :: Action [CmdOption]
+configureEnvironment = sequence [ builderEnvironment "CC" $ Cc CompileC Stage1
+                                , builderEnvironment "AR" (Ar Unpack Stage1)
+                                , builderEnvironment "NM" Nm ]
+
+gmpRules :: Rules ()
+gmpRules = do
+    -- Copy appropriate GMP header and object files
+    "//" ++ gmpLibraryH %> \header -> do
+        windows  <- windowsHost
+        configMk <- readFile' $ gmpBase -/- "config.mk"
+        if not windows && -- TODO: We don't use system GMP on Windows. Fix?
+           any (`isInfixOf` configMk) [ "HaveFrameworkGMP = YES", "HaveLibGmp = YES" ]
+        then do
+            putBuild "| GMP library/framework detected and will be used"
+            copyFile (gmpBase -/- "ghc-gmp.h") header
+        else do
+            putBuild "| No GMP library/framework detected; in tree GMP will be built"
+            gmpPath <- gmpBuildPath
+            need [gmpPath -/- gmpLibrary]
+            createDirectory (gmpPath -/- gmpObjectsDir)
+            top <- topDirectory
+            build $ target gmpContext (Ar Unpack Stage1)
+                [top -/- gmpPath -/- gmpLibrary] [gmpPath -/- gmpObjectsDir]
+            copyFile (gmpPath -/- "gmp.h") header
+            copyFile (gmpPath -/- "gmp.h") (gmpPath -/- gmpLibraryInTreeH)
+
+    -- Build in-tree GMP library
+    "//" ++ gmpLibrary %> \lib -> do
+        gmpPath <- gmpBuildPath
+        build $ target gmpContext (Make gmpPath) [gmpPath -/- "Makefile"] [lib]
+        putSuccess "| Successfully built custom library 'gmp'"
+
+    -- In-tree GMP header is built by the gmpLibraryH rule
+    "//" ++ gmpLibraryInTreeH %> \_ -> do
+        gmpPath <- gmpBuildPath
+        need [gmpPath -/- gmpLibraryH]
+
+    -- This causes integerGmp package to be configured, hence creating the files
+    [gmpBase -/- "config.mk", gmpBuildInfoPath] &%> \_ -> do
+        dataFile <- pkgDataFile gmpContext
+        need [dataFile]
+
+    -- Run GMP's configure script
+    -- TODO: Get rid of hard-coded @gmp@.
+    "//gmp/Makefile" %> \mk -> do
+        env     <- configureEnvironment
+        gmpPath <- gmpBuildPath
+        need [mk <.> "in"]
+        buildWithCmdOptions env $
+            target gmpContext (Configure gmpPath) [mk <.> "in"] [mk]
+
+    -- Extract in-tree GMP sources and apply patches
+    "//gmp/Makefile.in" %> \_ -> do
+        gmpPath <- gmpBuildPath
+        removeDirectory gmpPath
+        -- Note: We use a tarball like gmp-4.2.4-nodoc.tar.bz2, which is
+        -- gmp-4.2.4.tar.bz2 repacked without the doc/ directory contents.
+        -- That's because the doc/ directory contents are under the GFDL,
+        -- which causes problems for Debian.
+        tarball <- unifyPath . fromSingleton "Exactly one GMP tarball is expected"
+               <$> getDirectoryFiles "" [gmpBase -/- "gmp-tarballs/gmp*.tar.bz2"]
+
+        withTempDir $ \dir -> do
+            let tmp = unifyPath dir
+            need [tarball]
+            build $ target gmpContext (Tar Extract) [tarball] [tmp]
+
+            let patch     = gmpBase -/- "gmpsrc.patch"
+                patchName = takeFileName patch
+            copyFile patch $ tmp -/- patchName
+            applyPatch tmp patchName
+
+            let name    = dropExtension . dropExtension $ takeFileName tarball
+                unpack  = fromMaybe . error $ "gmpRules: expected suffix "
+                    ++ "-nodoc (found: " ++ name ++ ")."
+                libName = unpack $ stripSuffix "-nodoc" name
+
+            moveDirectory (tmp -/- libName) gmpPath
diff --git a/src/Rules/Install.hs b/src/Rules/Install.hs
new file mode 100644 (file)
index 0000000..bcdbf33
--- /dev/null
@@ -0,0 +1,336 @@
+module Rules.Install (installRules) where
+
+import Hadrian.Oracles.DirectoryContents
+import qualified System.Directory as IO
+
+import Base
+import Expression
+import Oracles.Setting
+import Rules
+import Rules.Generate
+import Rules.Libffi
+import Rules.Wrappers
+import Settings
+import Settings.Packages.Rts
+import Target
+import Utilities
+
+{- | Install the built binaries etc. to the @destDir ++ prefix@.
+
+The installation prefix is usually @/usr/local@ on a Unix system.
+The resulting tree structure is organized under @destDir ++ prefix@ as follows:
+
+* @bin@: executable wrapper scripts, installed by 'installBins', e.g. @ghc@.
+
+* @lib/ghc-<version>/bin@: executable binaries/scripts,
+  installed by 'installLibExecs' and 'installLibExecScripts'.
+
+* @lib/ghc-<version>/include@: headers etc., installed by 'installIncludes'.
+
+* @lib/ghc-<version>/<pkg-name>@: built packages, e.g. @base@, installed
+  by 'installPackages'.
+
+* @lib/ghc-<version>/settings@ etc.: other files in @lib@ directory,
+  installed by 'installCommonLibs'.
+
+XXX (izgzhen): Do we need @INSTALL_OPTS@ in the make scripts?
+-}
+installRules :: Rules ()
+installRules =
+    "install" ~> do
+        installIncludes
+        installPackageConf
+        installCommonLibs
+        installLibExecs
+        installLibExecScripts
+        installBins
+        installPackages
+        installDocs
+
+-- TODO: Get rid of hard-coded list.
+-- | Binaries to install.
+installBinPkgs :: [Package]
+installBinPkgs = [ghc, ghcPkg, ghcSplit, hp2ps, hpc, hsc2hs, runGhc, unlit]
+
+getLibExecDir :: Action FilePath
+getLibExecDir = (-/- "bin") <$> installGhcLibDir
+
+-- ref: ghc.mk
+-- | Install executable scripts to @prefix/lib/bin@.
+installLibExecScripts :: Action ()
+installLibExecScripts = do
+    libExecDir <- getLibExecDir
+    destDir <- getDestDir
+    installDirectory (destDir ++ libExecDir)
+    forM_ libExecScripts $ \script -> installScript script (destDir ++ libExecDir)
+  where
+    libExecScripts :: [FilePath]
+    libExecScripts = [ghcSplitPath]
+
+-- ref: ghc.mk
+-- | Install executable binaries to @prefix/lib/bin@.
+installLibExecs :: Action ()
+installLibExecs = do
+    libExecDir <- getLibExecDir
+    destDir <- getDestDir
+    installDirectory (destDir ++ libExecDir)
+    forM_ installBinPkgs $ \pkg ->
+        withInstallStage pkg $ \stage -> do
+            context <- programContext stage pkg
+            let bin = inplaceLibBinPath -/- programName context <.> exe
+            installProgram bin (destDir ++ libExecDir)
+            when (pkg == ghc) $
+                moveFile (destDir ++ libExecDir -/- programName context <.> exe)
+                         (destDir ++ libExecDir -/- "ghc" <.> exe)
+
+-- ref: ghc.mk
+-- | Install executable wrapper scripts to @prefix/bin@.
+installBins :: Action ()
+installBins = do
+    binDir <- setting InstallBinDir
+    libDir <- installGhcLibDir
+    destDir <- getDestDir
+    installDirectory (destDir ++ binDir)
+    win <- windowsHost
+    when win $
+        copyDirectoryContents matchAll (destDir ++ libDir -/- "bin") (destDir ++ binDir)
+    unless win $ forM_ installBinPkgs $ \pkg ->
+        withInstallStage pkg $ \stage -> do
+            context <- programContext stage pkg
+            version <- setting ProjectVersion
+            -- Name of the binary file
+            let binName | pkg == ghc = "ghc-" ++ version <.> exe
+                        | otherwise  = programName context ++ "-" ++ version <.> exe
+            -- Name of the symbolic link
+            let symName | pkg == ghc = "ghc" <.> exe
+                        | otherwise  = programName context <.> exe
+            case lookup context installWrappers of
+                Nothing -> return ()
+                Just wrapper -> do
+                    contents <- interpretInContext context $
+                        wrapper (WrappedBinary (destDir ++ libDir) symName)
+                    let wrapperPath = destDir ++ binDir -/- binName
+                    writeFileChanged wrapperPath contents
+                    makeExecutable wrapperPath
+                    unlessM windowsHost $
+                        linkSymbolic (destDir ++ binDir -/- binName)
+                                     (destDir ++ binDir -/- symName)
+
+-- | Perform an action depending on the install stage or do nothing if the
+-- package is not installed.
+withInstallStage :: Package -> (Stage -> Action ()) -> Action ()
+withInstallStage pkg m = do
+    maybeStage <- installStage pkg
+    case maybeStage of { Just stage -> m stage; Nothing -> return () }
+
+pkgConfInstallPath :: Action FilePath
+pkgConfInstallPath = buildPath (vanillaContext Stage0 rts) <&> (-/- "package.conf.install")
+
+-- ref: rules/manual-package-conf.mk
+-- TODO: Should we use a temporary file instead of pkgConfInstallPath?
+-- | Install @package.conf.install@ for each package. Note that it will be
+-- recreated each time.
+installPackageConf :: Action ()
+installPackageConf = do
+    let context = vanillaContext Stage0 rts
+    confPath <- pkgConfInstallPath
+    liftIO $ IO.createDirectoryIfMissing True (takeDirectory confPath)
+    build $ target context HsCpp [ pkgPath rts -/- "package.conf.in" ]
+                                 [ confPath <.> "raw" ]
+    Stdout content <- cmd "grep" [ "-v", "^#pragma GCC"
+                                 , confPath <.> "raw" ]
+    withTempFile $ \tmp -> do
+        liftIO $ writeFile tmp content
+        Stdout result <- cmd "sed" [ "-e", "s/\"\"//g", "-e", "s/:[   ]*,/: /g", tmp ]
+        liftIO $ writeFile confPath result
+
+-- ref: ghc.mk
+-- | Install packages to @prefix/lib@.
+installPackages :: Action ()
+installPackages = do
+    confPath <- pkgConfInstallPath
+    need [confPath]
+
+    ghcLibDir <- installGhcLibDir
+    binDir    <- setting InstallBinDir
+    destDir   <- getDestDir
+
+    -- Install package.conf
+    let installedPackageConf = destDir ++ ghcLibDir -/- "package.conf.d"
+    installDirectory (destDir ++ ghcLibDir)
+    removeDirectory installedPackageConf
+    installDirectory installedPackageConf
+
+    -- Install RTS
+    let rtsDir = destDir ++ ghcLibDir -/- "rts"
+    installDirectory rtsDir
+    ways    <- interpretInContext (vanillaContext Stage1 rts) getRtsWays
+    rtsLibs <- mapM (pkgLibraryFile . Context Stage1 rts) ways
+    ffiLibs <- mapM rtsLibffiLibrary ways
+
+    -- TODO: Add dynamic libraries.
+    forM_ (rtsLibs ++ ffiLibs) $ \lib -> installData [lib] rtsDir
+
+    -- TODO: Remove this hack required for @ghc-cabal copy@.
+    -- See https://github.com/snowleopard/hadrian/issues/327.
+    ghcBootPlatformHeader <-
+        buildPath (vanillaContext Stage1 compiler) <&> (-/- "ghc_boot_platform.h")
+    copyFile ghcBootPlatformHeader (pkgPath compiler -/- "ghc_boot_platform.h")
+
+    installPackages <- filterM ((isJust <$>) . installStage)
+                               (knownPackages \\ [rts, libffi])
+
+    installLibPkgs <- topsortPackages (filter isLibrary installPackages)
+
+    -- TODO: Figure out what is the root cause of the missing ghc-gmp.h error.
+    copyFile (pkgPath integerGmp -/- "gmp/ghc-gmp.h") (pkgPath integerGmp -/- "ghc-gmp.h")
+
+    forM_ installLibPkgs $ \pkg ->
+        case pkgCabalFile pkg of
+            Nothing -> error $ "Non-Haskell project in installLibPkgs" ++ show pkg
+            Just cabalFile -> withInstallStage pkg $ \stage -> do
+                let context = vanillaContext stage pkg
+                top <- topDirectory
+                installDistDir <- buildPath context
+                let absInstallDistDir = top -/- installDistDir
+
+                need =<< packageTargets True stage pkg
+                docDir <- installDocDir
+                ghclibDir <- installGhcLibDir
+
+                -- Copy over packages
+                strip <- stripCmdPath
+                ways  <- interpretInContext context getLibraryWays
+                -- TODO: Remove hard-coded @ghc-cabal@ path.
+                let ghcCabalInplace = inplaceBinPath -/- "ghc-cabal" <.> exe
+                need [ghcCabalInplace]
+
+                pkgConf <- pkgConfFile context
+                need [cabalFile, pkgConf] -- TODO: Check if we need 'pkgConf'.
+
+                -- TODO: Drop redundant copies required by @ghc-cabal@.
+                -- See https://github.com/snowleopard/hadrian/issues/318.
+                quietly $ copyDirectoryContentsUntracked (Not excluded)
+                    installDistDir (installDistDir -/- "build")
+
+                pref <- setting InstallPrefix
+                unit $ cmd ghcCabalInplace [ "copy"
+                                           , pkgPath pkg
+                                           , absInstallDistDir
+                                           , strip
+                                           , destDir
+                                           , pref
+                                           , ghclibDir
+                                           , docDir -/- "html/libraries"
+                                           , unwords (map show ways) ]
+
+    -- Register packages
+    let installedGhcPkgReal = destDir ++ binDir -/- "ghc-pkg" <.> exe
+        installedGhcReal    = destDir ++ binDir -/- "ghc"     <.> exe
+    -- TODO: Extend GhcPkg builder args to support --global-package-db
+    unit $ cmd installedGhcPkgReal [ "--force", "--global-package-db"
+                                   , installedPackageConf, "update"
+                                   , confPath ]
+
+    forM_ installLibPkgs $ \pkg ->
+        withInstallStage pkg $ \stage -> do
+            let context = vanillaContext stage pkg
+            top <- topDirectory
+            installDistDir <- (top -/-) <$> buildPath context
+            -- TODO: better reference to the built inplace binary path
+            let ghcCabalInplace = inplaceBinPath -/- "ghc-cabal"
+            pref   <- setting InstallPrefix
+            docDir <- installDocDir
+            r      <- relocatableBuild
+            unit $ cmd ghcCabalInplace
+                [ "register"
+                , pkgPath pkg
+                , installDistDir
+                , installedGhcReal
+                , installedGhcPkgReal
+                , destDir ++ ghcLibDir
+                , destDir
+                , destDir ++ pref
+                , destDir ++ ghcLibDir
+                , destDir ++ docDir -/- "html/libraries"
+                , if r then "YES" else "NO" ]
+
+    confs <- getDirectoryContents installedPackageConf
+    forM_ confs (\f -> createData $ installedPackageConf -/- f)
+    unit $ cmd installedGhcPkgReal [ "--force", "--global-package-db"
+                                   , installedPackageConf, "recache" ]
+  where
+    createData f = unit $ cmd "chmod" [ "644", f ]
+    excluded = Or [ Test "//haddock-prologue.txt"
+                  , Test "//package-data.mk"
+                  , Test "//setup-config"
+                  , Test "//inplace-pkg-config"
+                  , Test "//build" ]
+
+-- ref: ghc.mk
+-- | Install settings etc. files to @prefix/lib@.
+installCommonLibs :: Action ()
+installCommonLibs = do
+    ghcLibDir <- installGhcLibDir
+    destDir   <- getDestDir
+    installLibsTo inplaceLibCopyTargets (destDir ++ ghcLibDir)
+
+-- ref: ghc.mk
+-- | Install library files to some path.
+installLibsTo :: [FilePath] -> FilePath -> Action ()
+installLibsTo libs dir = do
+    installDirectory dir
+    forM_ libs $ \lib -> case takeExtension lib of
+        ".a" -> do
+            let out = dir -/- takeFileName lib
+            installData [out] dir
+            runBuilder Ranlib [out] [out] [out]
+        _ -> installData [lib] dir
+
+-- ref: includes/ghc.mk
+-- | All header files are in includes/{one of these subdirectories}.
+includeHSubdirs :: [FilePath]
+includeHSubdirs = [".", "rts", "rts/prof", "rts/storage", "stg"]
+
+-- ref: includes/ghc.mk
+-- | Install header files to @prefix/lib/ghc-<version>/include@.
+installIncludes :: Action ()
+installIncludes = do
+    ghclibDir <- installGhcLibDir
+    destDir   <- getDestDir
+    let ghcheaderDir = ghclibDir -/- "include"
+    installDirectory (destDir ++ ghcheaderDir)
+    forM_ includeHSubdirs $ \dir -> do
+        installDirectory (destDir ++ ghcheaderDir -/- dir)
+        headers <- getDirectoryFiles ("includes" -/- dir) ["*.h"]
+        installHeader (map (("includes" -/- dir) -/-) headers)
+                      (destDir ++ ghcheaderDir -/- dir ++ "/")
+    root    <- buildRoot
+    rtsPath <- rtsBuildPath
+    installHeader (fmap (root -/-) includesDependencies ++
+                   [root -/- generatedDir -/- "DerivedConstants.h"] ++
+                   fmap (rtsPath -/-) libffiDependencies)
+                  (destDir ++ ghcheaderDir ++ "/")
+  where
+    installHeader = installData -- they share same arguments
+
+-- ref: ghc.mk
+-- | Install documentation to @prefix/share/doc/ghc-<version>@.
+installDocs :: Action ()
+installDocs = do
+    destDir <- getDestDir
+    docDir  <- installDocDir
+    root    <- buildRoot
+    installDirectory (destDir ++ docDir)
+
+    let usersGuide = root -/- "docs/pdfs/users_guide.pdf"
+    whenM (doesFileExist usersGuide) $
+        installData [usersGuide] (destDir ++ docDir)
+
+    let htmlDocDir = destDir ++ docDir -/- "html"
+    installDirectory htmlDocDir
+    installData ["docs/index.html"] htmlDocDir
+
+    forM_ ["Haddock", "libraries", "users_guide"] $ \dirname -> do
+        let dir = root -/- "docs/html" -/- dirname
+        whenM (doesDirectoryExist dir) $ copyDirectory dir htmlDocDir
diff --git a/src/Rules/Libffi.hs b/src/Rules/Libffi.hs
new file mode 100644 (file)
index 0000000..73f481d
--- /dev/null
@@ -0,0 +1,108 @@
+module Rules.Libffi (libffiRules, libffiBuildPath, libffiDependencies) where
+
+import Hadrian.Utilities
+
+import Settings.Builders.Common
+import Settings.Packages.Rts
+import Target
+import Utilities
+
+-- | Libffi is considered a Stage1 package. This determines its build directory.
+libffiContext :: Context
+libffiContext = vanillaContext Stage1 libffi
+
+-- | Build directory for in-tree Libffi library.
+libffiBuildPath :: Action FilePath
+libffiBuildPath = buildPath libffiContext
+
+libffiDependencies :: [FilePath]
+libffiDependencies = ["ffi.h", "ffitarget.h"]
+
+libffiLibrary :: FilePath
+libffiLibrary = "inst/lib/libffi.a"
+
+fixLibffiMakefile :: FilePath -> String -> String
+fixLibffiMakefile top =
+      replace "-MD" "-MMD"
+    . replace "@toolexeclibdir@" "$(libdir)"
+    . replace "@INSTALL@" ("$(subst ../install-sh," ++ top ++ "/install-sh,@INSTALL@)")
+
+-- TODO: remove code duplication (see Settings/Builders/GhcCabal.hs)
+-- TODO: check code duplication w.r.t. ConfCcArgs
+configureEnvironment :: Action [CmdOption]
+configureEnvironment = do
+    cFlags  <- interpretInContext libffiContext $ mconcat
+               [ cArgs
+               , getStagedSettingList ConfCcArgs ]
+    ldFlags <- interpretInContext libffiContext ldArgs
+    sequence [ builderEnvironment "CC" $ Cc CompileC Stage1
+             , builderEnvironment "CXX" $ Cc CompileC Stage1
+             , builderEnvironment "LD" Ld
+             , builderEnvironment "AR" (Ar Unpack Stage1)
+             , builderEnvironment "NM" Nm
+             , builderEnvironment "RANLIB" Ranlib
+             , return . AddEnv  "CFLAGS" $ unwords  cFlags ++ " -w"
+             , return . AddEnv "LDFLAGS" $ unwords ldFlags ++ " -w" ]
+
+libffiRules :: Rules ()
+libffiRules = do
+    fmap ("//rts" -/-) libffiDependencies &%> \_ -> do
+        libffiPath <- libffiBuildPath
+        need [libffiPath -/- libffiLibrary]
+
+    "//" ++ libffiLibrary %> \_ -> do
+        useSystemFfi <- flag UseSystemFfi
+        rtsPath      <- rtsBuildPath
+        if useSystemFfi
+        then do
+            ffiIncludeDir <- setting FfiIncludeDir
+            putBuild "| System supplied FFI library will be used"
+            forM_ ["ffi.h", "ffitarget.h"] $ \file ->
+                copyFile (ffiIncludeDir -/- file) (rtsPath -/- file)
+            putSuccess "| Successfully copied system FFI library header files"
+        else do
+            libffiPath <- libffiBuildPath
+            build $ target libffiContext (Make libffiPath) [] []
+
+            hs <- getDirectoryFiles "" [libffiPath -/- "inst/include/*"]
+            forM_ hs $ \header ->
+                copyFile header (rtsPath -/- takeFileName header)
+
+            ways <- interpretInContext libffiContext (getLibraryWays <> getRtsWays)
+            forM_ (nubOrd ways) $ \way -> do
+                rtsLib <- rtsLibffiLibrary way
+                copyFileUntracked (libffiPath -/- libffiLibrary) rtsLib
+
+            putSuccess "| Successfully built custom library 'libffi'"
+
+    "//libffi/Makefile.in" %> \mkIn -> do
+        libffiPath <- libffiBuildPath
+        removeDirectory libffiPath
+        tarball <- unifyPath . fromSingleton "Exactly one LibFFI tarball is expected"
+               <$> getDirectoryFiles "" ["libffi-tarballs/libffi*.tar.gz"]
+
+        need [tarball]
+        -- Go from 'libffi-3.99999+git20171002+77e130c.tar.gz' to 'libffi-3.99999'
+        let libname = takeWhile (/= '+') $ takeFileName tarball
+
+        root <- buildRoot
+        removeDirectory (root -/- libname)
+        -- TODO: Simplify.
+        actionFinally (do
+            build $ target libffiContext (Tar Extract) [tarball] [root]
+            moveDirectory (root -/- libname) libffiPath) $
+                removeFiles root [libname <//> "*"]
+
+        top <- topDirectory
+        fixFile mkIn (fixLibffiMakefile top)
+
+    -- TODO: Get rid of hard-coded @libffi@.
+    "//libffi/Makefile" %> \mk -> do
+        need [mk <.> "in"]
+        libffiPath <- libffiBuildPath
+        forM_ ["config.guess", "config.sub"] $ \file ->
+            copyFile file (libffiPath -/- file)
+
+        env <- configureEnvironment
+        buildWithCmdOptions env $
+            target libffiContext (Configure libffiPath) [mk <.> "in"] [mk]
diff --git a/src/Rules/Library.hs b/src/Rules/Library.hs
new file mode 100644 (file)
index 0000000..e6e5b16
--- /dev/null
@@ -0,0 +1,103 @@
+module Rules.Library (
+    buildPackageLibrary, buildPackageGhciLibrary, buildDynamicLib
+    ) where
+
+import Hadrian.Haskell.Cabal
+import qualified System.Directory as IO
+
+import Base
+import Context
+import Expression hiding (way, package)
+import Flavour
+import Oracles.ModuleFiles
+import Oracles.PackageData
+import Oracles.Setting
+import Rules.Gmp
+import Settings
+import Target
+import Utilities
+
+libraryObjects :: Context -> Action [FilePath]
+libraryObjects context@Context{..} = do
+    hsObjs   <- hsObjects    context
+    noHsObjs <- nonHsObjects context
+
+    -- This will create split objects if required (we don't track them
+    -- explicitly as this would needlessly bloat the Shake database).
+    need $ noHsObjs ++ hsObjs
+
+    split <- interpretInContext context =<< splitObjects <$> flavour
+    let getSplitObjs = concatForM hsObjs $ \obj -> do
+            let dir = dropExtension obj ++ "_" ++ osuf way ++ "_split"
+            contents <- liftIO $ IO.getDirectoryContents dir
+            return . map (dir -/-) $ filter (not . all (== '.')) contents
+
+    (noHsObjs ++) <$> if split then getSplitObjs else return hsObjs
+
+buildDynamicLib :: Context -> Rules ()
+buildDynamicLib context@Context{..} = do
+    let libPrefix = "//" ++ contextDir context -/- "libHS" ++ pkgName package
+    -- OS X
+    libPrefix ++ "*.dylib" %> buildDynamicLibUnix
+    -- Linux
+    libPrefix ++ "*.so"    %> buildDynamicLibUnix
+    -- TODO: Windows
+  where
+    buildDynamicLibUnix lib = do
+        deps <- contextDependencies context
+        need =<< mapM pkgLibraryFile deps
+        objs <- libraryObjects context
+        build $ target context (Ghc LinkHs stage) objs [lib]
+
+buildPackageLibrary :: Context -> Rules ()
+buildPackageLibrary context@Context {..} = do
+    let libPrefix = "//" ++ contextDir context -/- "libHS" ++ pkgName package
+    libPrefix ++ "*" ++ (waySuffix way <.> "a") %%> \a -> do
+        objs <- libraryObjects context
+        asuf <- libsuf way
+        let isLib0 = ("//*-0" ++ asuf) ?== a
+        removeFile a
+        if isLib0 then build $ target context (Ar Pack stage) []   [a] -- TODO: Scan for dlls
+                  else build $ target context (Ar Pack stage) objs [a]
+
+        synopsis <- traverse pkgSynopsis (pkgCabalFile package)
+        unless isLib0 . putSuccess $ renderLibrary
+            (quote (pkgName package) ++ " (" ++ show stage ++ ", way "
+            ++ show way ++ ").") a synopsis
+
+buildPackageGhciLibrary :: Context -> Rules ()
+buildPackageGhciLibrary context@Context {..} = priority 2 $ do
+    let libPrefix = "//" ++ contextDir context -/- "HS" ++ pkgName package
+    libPrefix ++ "*" ++ (waySuffix way <.> "o") %> \obj -> do
+        objs <- allObjects context
+        need objs
+        build $ target context Ld objs [obj]
+
+allObjects :: Context -> Action [FilePath]
+allObjects context = (++) <$> nonHsObjects context <*> hsObjects context
+
+nonHsObjects :: Context -> Action [FilePath]
+nonHsObjects context = do
+    path    <- buildPath context
+    cObjs   <- cObjects context
+    cmmSrcs <- pkgDataList (CmmSrcs path)
+    cmmObjs <- mapM (objectPath context) cmmSrcs
+    eObjs   <- extraObjects context
+    return $ cObjs ++ cmmObjs ++ eObjs
+
+cObjects :: Context -> Action [FilePath]
+cObjects context = do
+    path <- buildPath context
+    srcs <- pkgDataList (CSrcs path)
+    objs <- mapM (objectPath context) srcs
+    return $ if way context == threaded
+        then objs
+        else filter ((`notElem` ["Evac_thr", "Scav_thr"]) . takeBaseName) objs
+
+extraObjects :: Context -> Action [FilePath]
+extraObjects context
+    | package context == integerGmp = do
+        gmpPath <- gmpBuildPath
+        need [gmpPath -/- gmpLibraryH]
+        map unifyPath <$> getDirectoryFiles "" [gmpPath -/- gmpObjectsDir -/- "*.o"]
+    | otherwise         = return []
diff --git a/src/Rules/PackageData.hs b/src/Rules/PackageData.hs
new file mode 100644 (file)
index 0000000..2442b03
--- /dev/null
@@ -0,0 +1,119 @@
+module Rules.PackageData (buildPackageData) where
+
+import Base
+import Context
+import Expression
+import Oracles.Setting
+import Rules.Generate
+import Settings.Packages.Rts
+import Target
+import Utilities
+
+-- | Build @package-data.mk@ by using ghc-cabal utility to process .cabal files.
+buildPackageData :: Context -> Rules ()
+buildPackageData context@Context {..} = do
+    let dir       = "//" ++ contextDir context
+        cabalFile = unsafePkgCabalFile package -- TODO: improve
+        configure = pkgPath package -/- "configure"
+    -- TODO: Get rid of hardcoded file paths.
+    [dir -/- "package-data.mk", dir -/- "setup-config"] &%> \[mk, setupConfig] -> do
+        -- Make sure all generated dependencies are in place before proceeding.
+        orderOnly =<< interpretInContext context generatedDependencies
+
+        -- GhcCabal may run the configure script, so we depend on it.
+        whenM (doesFileExist $ configure <.> "ac") $ need [configure]
+
+        -- Before we configure a package its dependencies need to be registered.
+        need =<< mapM pkgConfFile =<< contextDependencies context
+
+        need [cabalFile]
+        build $ target context GhcCabal [cabalFile] [mk, setupConfig]
+        postProcessPackageData context mk
+
+    -- TODO: Get rid of hardcoded file paths.
+    dir -/- "inplace-pkg-config" %> \conf -> do
+        path     <- buildPath context
+        dataFile <- pkgDataFile context
+        need [dataFile] -- ghc-cabal builds inplace package configuration file
+        if package == rts
+        then do
+            genPath <- buildRoot <&> (-/- generatedDir)
+            rtsPath <- rtsBuildPath
+            need [rtsConfIn]
+            build $ target context HsCpp [rtsConfIn] [conf]
+            fixFile conf $ unlines
+                         . map
+                         ( replace "\"\"" ""
+                         . replace "rts/dist/build" rtsPath
+                         . replace "includes/dist-derivedconstants/header" genPath )
+                         . lines
+        else
+            fixFile conf $ unlines . map (replace (path </> "build") path) . lines
+
+    priority 2.0 $ when (nonCabalContext context) $ dir -/- "package-data.mk" %>
+        generatePackageData context
+
+generatePackageData :: Context -> FilePath -> Action ()
+generatePackageData context@Context {..} file = do
+    orderOnly =<< interpretInContext context generatedDependencies
+    asmSrcs <- packageAsmSources package
+    cSrcs   <- packageCSources   package
+    cmmSrcs <- packageCmmSources package
+    genPath <- buildRoot <&> (-/- generatedDir)
+    writeFileChanged file . unlines $
+        [ "S_SRCS = "   ++ unwords asmSrcs                                  ] ++
+        [ "C_SRCS = "   ++ unwords cSrcs                                    ] ++
+        [ "CMM_SRCS = " ++ unwords cmmSrcs                                  ] ++
+        [ "DEP_EXTRA_LIBS = m"                 | package == hp2ps           ] ++
+        [ "CC_OPTS = -I" ++ genPath            | package `elem` [hp2ps, rts]] ++
+        [ "MODULES = Main"                     | package == ghcCabal        ] ++
+        [ "HS_SRC_DIRS = ."                    | package == ghcCabal        ]
+    putSuccess $ "| Successfully generated " ++ file
+
+packageCSources :: Package -> Action [FilePath]
+packageCSources pkg
+    | pkg /= rts = getDirectoryFiles (pkgPath pkg) ["*.c"]
+    | otherwise  = do
+        windows <- windowsHost
+        rtsPath <- rtsBuildPath
+        sources <- fmap (map unifyPath) . getDirectoryFiles (pkgPath pkg) .
+            map (-/- "*.c") $ [ ".", "hooks", "sm", "eventlog", "linker" ] ++
+                              [ if windows then "win32" else "posix"     ]
+        return $ sources ++ [ rtsPath -/- "c/sm/Evac_thr.c" ]
+                         ++ [ rtsPath -/- "c/sm/Scav_thr.c" ]
+
+packageAsmSources :: Package -> Action [FilePath]
+packageAsmSources pkg
+    | pkg /= rts = return []
+    | otherwise  = do
+        buildAdjustor   <- anyTargetArch ["i386", "powerpc", "powerpc64"]
+        buildStgCRunAsm <- anyTargetArch ["powerpc64le"]
+        return $ [ "AdjustorAsm.S" | buildAdjustor   ]
+              ++ [ "StgCRunAsm.S"  | buildStgCRunAsm ]
+
+packageCmmSources :: Package -> Action [FilePath]
+packageCmmSources pkg
+    | pkg /= rts = return []
+    | otherwise  = do
+        rtsPath <- rtsBuildPath
+        sources <- getDirectoryFiles (pkgPath pkg) ["*.cmm"]
+        return $ sources ++ [ rtsPath -/- "cmm/AutoApply.cmm" ]
+
+-- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile:
+-- 1) Drop lines containing '$'. For example, get rid of
+-- @libraries/Win32_dist-install_CMM_SRCS  := $(addprefix cbits/,$(notdir ...@
+-- and replace it with a tracked call to getDirectoryFiles.
+-- 2) Drop path prefixes to individual settings.
+-- For example, @libraries/deepseq/dist-install_VERSION = 1.4.0.0@
+-- is replaced by @VERSION = 1.4.0.0@.
+-- Reason: Shake's built-in makefile parser doesn't recognise slashes
+-- TODO (izgzhen): should fix DEP_LIB_REL_DIRS_SEARCHPATH
+postProcessPackageData :: Context -> FilePath -> Action ()
+postProcessPackageData context@Context {..} file = do
+    top     <- topDirectory
+    cmmSrcs <- getDirectoryFiles (pkgPath package) ["cbits/*.cmm"]
+    path    <- buildPath context
+    let len = length (pkgPath package) + length (top -/- path) + 2
+    fixFile file $ unlines
+                 . (++ ["CMM_SRCS = " ++ unwords (map unifyPath cmmSrcs) ])
+                 . map (drop len) . filter ('$' `notElem`) . lines
diff --git a/src/Rules/Program.hs b/src/Rules/Program.hs
new file mode 100644 (file)
index 0000000..ba4dab0
--- /dev/null
@@ -0,0 +1,116 @@
+module Rules.Program (buildProgram) where
+
+import Hadrian.Haskell.Cabal
+
+import Base
+import Context
+import Expression hiding (stage, way)
+import Oracles.ModuleFiles
+import Oracles.PackageData
+import Oracles.Setting
+import Rules.Wrappers
+import Settings
+import Settings.Packages.Rts
+import Target
+import Utilities
+
+-- | TODO: Drop code duplication
+buildProgram :: [(Resource, Int)] -> Package -> Rules ()
+buildProgram rs package = do
+    forM_ [Stage0 ..] $ \stage -> do
+        let context = vanillaContext stage package
+
+        -- Rules for programs built in 'buildRoot'
+        "//" ++ contextDir context -/- programName context <.> exe %> \bin ->
+            buildBinaryAndWrapper rs bin =<< programContext stage package
+
+        -- Rules for the GHC package, which is built 'inplace'
+        when (package == ghc) $ do
+            inplaceBinPath -/- programName context <.> exe %> \bin ->
+                buildBinaryAndWrapper rs bin =<< programContext stage package
+
+            inplaceLibBinPath -/- programName context <.> exe %> \bin ->
+                buildBinary rs bin =<< programContext stage package
+
+            inplaceLibBinPath -/- programName context <.> "bin" %> \bin ->
+                buildBinary rs bin =<< programContext stage package
+
+    -- Rules for other programs built in inplace directories
+    when (package /= ghc) $ do
+        let context0 = vanillaContext Stage0 package -- TODO: get rid of context0
+        inplaceBinPath -/- programName context0 <.> exe %> \bin -> do
+            stage <- installStage package -- TODO: get rid of fromJust
+            buildBinaryAndWrapper rs bin =<< programContext (fromJust stage) package
+
+        inplaceLibBinPath -/- programName context0 <.> exe %> \bin -> do
+            stage   <- installStage package -- TODO: get rid of fromJust
+            context <- programContext (fromJust stage) package
+            if package /= iservBin then
+                -- We *normally* build only unwrapped binaries in inplace/lib/bin
+                buildBinary rs bin context
+            else
+                -- Build both binary and wrapper in inplace/lib/bin for iservBin
+                buildBinaryAndWrapperLib rs bin context
+
+        inplaceLibBinPath -/- programName context0 <.> "bin" %> \bin -> do
+            stage <- installStage package -- TODO: get rid of fromJust
+            buildBinary rs bin =<< programContext (fromJust stage) package
+
+buildBinaryAndWrapperLib :: [(Resource, Int)] -> FilePath -> Context -> Action ()
+buildBinaryAndWrapperLib rs bin context = do
+    windows <- windowsHost
+    if windows
+    then buildBinary rs bin context -- We don't build wrappers on Windows
+    else case lookup context inplaceWrappers of
+        Nothing      -> buildBinary rs bin context -- No wrapper found
+        Just wrapper -> do
+            top <- topDirectory
+            let libdir = top -/- inplaceLibPath
+            let wrappedBin = inplaceLibBinPath -/- programName context <.> "bin"
+            need [wrappedBin]
+            buildWrapper context wrapper bin (WrappedBinary libdir (takeFileName wrappedBin))
+
+buildBinaryAndWrapper :: [(Resource, Int)] -> FilePath -> Context -> Action ()
+buildBinaryAndWrapper rs bin context = do
+    windows <- windowsHost
+    if windows
+    then buildBinary rs bin context -- We don't build wrappers on Windows
+    else case lookup context inplaceWrappers of
+        Nothing      -> buildBinary rs bin context -- No wrapper found
+        Just wrapper -> do
+            top <- topDirectory
+            let libPath    = top -/- inplaceLibPath
+                wrappedBin = inplaceLibBinPath -/- takeFileName bin
+            need [wrappedBin]
+            buildWrapper context wrapper bin (WrappedBinary libPath (takeFileName bin))
+
+buildWrapper :: Context -> Wrapper -> FilePath -> WrappedBinary -> Action ()
+buildWrapper context@Context {..} wrapper wrapperPath wrapped = do
+    contents <- interpretInContext context $ wrapper wrapped
+    writeFileChanged wrapperPath contents
+    makeExecutable wrapperPath
+    putSuccess $ "| Successfully created wrapper for " ++
+        quote (pkgName package) ++ " (" ++ show stage ++ ")."
+
+-- TODO: Get rid of the Paths_hsc2hs.o hack.
+buildBinary :: [(Resource, Int)] -> FilePath -> Context -> Action ()
+buildBinary rs bin context@Context {..} = do
+    binDeps <- if stage == Stage0 && package == ghcCabal
+        then hsSources context
+        else do
+            needLibrary =<< contextDependencies context
+            when (stage > Stage0) $ do
+                ways <- interpretInContext context (getLibraryWays <> getRtsWays)
+                needLibrary [ rtsContext { way = w } | w <- ways ]
+            path   <- buildPath context
+            cSrcs  <- pkgDataList (CSrcs path)
+            cObjs  <- mapM (objectPath context) cSrcs
+            hsObjs <- hsObjects context
+            return $ cObjs ++ hsObjs
+                  ++ [ path -/- "Paths_hsc2hs.o"  | package == hsc2hs  ]
+                  ++ [ path -/- "Paths_haddock.o" | package == haddock ]
+    need binDeps
+    buildWithResources rs $ target context (Ghc LinkHs stage) binDeps [bin]
+    synopsis <- traverse pkgSynopsis (pkgCabalFile package)
+    putSuccess $ renderProgram
+        (quote (pkgName package) ++ " (" ++ show stage ++ ").") bin synopsis
diff --git a/src/Rules/Register.hs b/src/Rules/Register.hs
new file mode 100644 (file)
index 0000000..7c0a3e0
--- /dev/null
@@ -0,0 +1,44 @@
+module Rules.Register (registerPackage) where
+
+import Base
+import Context
+import GHC
+import Target
+import Utilities
+
+-- TODO: Simplify.
+-- | Build rules for registering packages and initialising package databases
+-- by running the @ghc-pkg@ utility.
+registerPackage :: [(Resource, Int)] -> Context -> Rules ()
+registerPackage rs context@Context {..} = do
+    when (stage == Stage0) $ do
+        -- Packages @ghc-boot@ and @ghc-boot-th@ both match the @ghc-boot*@
+        -- pattern, therefore we need to use priorities to match the right rule.
+        -- TODO: Get rid of this hack.
+        "//" ++ stage0PackageDbDir -/- pkgName package ++ "*.conf" %%>
+            buildConf rs context
+
+        when (package == ghc) $ "//" ++ stage0PackageDbDir -/- packageDbStamp %>
+            buildStamp rs context
+
+    when (stage == Stage1) $ do
+        inplacePackageDbPath -/- pkgName package ++ "*.conf" %%>
+            buildConf rs context
+
+        when (package == ghc) $ inplacePackageDbPath -/- packageDbStamp %>
+            buildStamp rs context
+
+buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
+buildConf rs context@Context {..} conf = do
+    confIn <- pkgInplaceConfig context
+    need [confIn]
+    buildWithResources rs $ target context (GhcPkg Update stage) [confIn] [conf]
+
+buildStamp :: [(Resource, Int)] -> Context -> FilePath -> Action ()
+buildStamp rs Context {..} stamp = do
+    let path = takeDirectory stamp
+    removeDirectory path
+    buildWithResources rs $
+        target (vanillaContext stage ghc) (GhcPkg Init stage) [] [path]
+    writeFileLines stamp []
+    putSuccess $ "| Successfully initialised " ++ path
diff --git a/src/Rules/Selftest.hs b/src/Rules/Selftest.hs
new file mode 100644 (file)
index 0000000..d1ffaac
--- /dev/null
@@ -0,0 +1,92 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Rules.Selftest (selftestRules) where
+
+import Test.QuickCheck
+
+import Base
+import GHC
+import Oracles.ModuleFiles
+import Oracles.Setting
+import Settings
+import Target
+
+instance Arbitrary Way where
+    arbitrary = wayFromUnits <$> arbitrary
+
+instance Arbitrary WayUnit where
+    arbitrary = arbitraryBoundedEnum
+
+test :: Testable a => a -> Action ()
+test = liftIO . quickCheck
+
+selftestRules :: Rules ()
+selftestRules =
+    "selftest" ~> do
+        testBuilder
+        testChunksOfSize
+        testLookupAll
+        testModuleName
+        testPackages
+        testWay
+
+testBuilder :: Action ()
+testBuilder = do
+    putBuild "==== trackArgument"
+    let make = target undefined (Make undefined) undefined undefined
+    test $ forAll (elements ["-j", "MAKEFLAGS=-j", "THREADS="])
+         $ \prefix (NonNegative n) ->
+            not (trackArgument make prefix) &&
+            not (trackArgument make ("-j" ++ show (n :: Int)))
+
+testChunksOfSize :: Action ()
+testChunksOfSize = do
+    putBuild "==== chunksOfSize"
+    test $ chunksOfSize 3 [  "a", "b", "c" ,  "defg" ,  "hi" ,  "jk"  ]
+                       == [ ["a", "b", "c"], ["defg"], ["hi"], ["jk"] ]
+    test $ \n xs ->
+        let res = chunksOfSize n xs
+        in concat res == xs && all (\r -> length r == 1 || length (concat r) <= n) res
+
+testLookupAll :: Action ()
+testLookupAll = do
+    putBuild "==== lookupAll"
+    test $ lookupAll ["b"    , "c"            ] [("a", 1), ("c", 3), ("d", 4)]
+                  == [Nothing, Just (3 :: Int)]
+    test $ forAll dicts $ \dict -> forAll extras $ \extra ->
+        let items = sort $ map fst dict ++ extra
+        in lookupAll items (sort dict) == map (`lookup` dict) items
+  where
+    dicts :: Gen [(Int, Int)]
+    dicts = nubBy (\x y -> fst x == fst y) <$> vector 20
+    extras :: Gen [Int]
+    extras = vector 20
+
+testModuleName :: Action ()
+testModuleName = do
+    putBuild "==== Encode/decode module name"
+    test $ encodeModule "Data/Functor" "Identity.hs" == "Data.Functor.Identity"
+    test $ encodeModule "" "Prelude"                 == "Prelude"
+
+    test $ decodeModule "Data.Functor.Identity" == ("Data/Functor", "Identity")
+    test $ decodeModule "Prelude"               == ("", "Prelude")
+
+    test $ forAll names $ \n -> uncurry encodeModule (decodeModule n) == n
+  where
+    names = intercalate "." <$> listOf1 (listOf1 $ elements "abcABC123_'")
+
+testPackages :: Action ()
+testPackages = do
+    putBuild "==== Check system configuration"
+    win <- windowsHost -- This depends on the @boot@ and @configure@ scripts.
+    putBuild "==== Packages, interpretInContext, configuration flags"
+    forM_ [Stage0 ..] $ \stage -> do
+        pkgs <- stagePackages stage
+        when (win32 `elem` pkgs) . test $ win
+        when (unix  `elem` pkgs) . test $ not win
+        test $ pkgs == nubOrd pkgs
+
+testWay :: Action ()
+testWay = do
+    putBuild "==== Read Way, Show Way"
+    test $ \(x :: Way) -> read (show x) == x
+
diff --git a/src/Rules/SourceDist.hs b/src/Rules/SourceDist.hs
new file mode 100644 (file)
index 0000000..3143c4b
--- /dev/null
@@ -0,0 +1,113 @@
+module Rules.SourceDist (sourceDistRules) where
+
+import Hadrian.Oracles.DirectoryContents
+
+import Base
+import Builder
+import Oracles.Setting
+import Rules.Clean
+
+sourceDistRules :: Rules ()
+sourceDistRules = do
+    "sdist-ghc" ~> do
+        -- We clean the source tree first.
+        -- See https://github.com/snowleopard/hadrian/issues/384.
+        cleanSourceTree
+        version <- setting ProjectVersion
+        need ["sdistprep/ghc-" ++ version ++ "-src.tar.xz"]
+        putSuccess "| Done"
+    "sdistprep/ghc-*-src.tar.xz" %> \fname -> do
+        let tarName   = takeFileName fname
+            dropTarXz = dropExtension . dropExtension
+            treePath  = "sdistprep/ghc" -/- dropTarXz tarName
+        prepareTree treePath
+        runBuilderWithCmdOptions [Cwd "sdistprep/ghc"] (Tar Create)
+            ["cJf", ".." -/- tarName,  dropTarXz tarName]
+            ["cJf", ".." -/- tarName] [dropTarXz tarName]
+    "GIT_COMMIT_ID" %> \fname ->
+        writeFileChanged fname =<< setting ProjectGitCommitId
+    "VERSION" %> \fname ->
+        writeFileChanged fname =<< setting ProjectVersion
+
+prepareTree :: FilePath -> Action ()
+prepareTree dest = do
+    mapM_ cpDir  srcDirs
+    mapM_ cpFile srcFiles
+  where
+    cpFile a = copyFile a (dest -/- a)
+    cpDir  a = copyDirectoryContents (Not excluded) a (dest -/- a)
+    excluded = Or
+        [ Test "//.*"
+        , Test "//#*"
+        , Test "//*-SAVE"
+        , Test "//*.orig"
+        , Test "//*.rej"
+        , Test "//*~"
+        , Test "//autom4te*"
+        , Test "//dist"
+        , Test "//dist-install"
+        , Test "//log"
+        , Test "//stage0"
+        , Test "//stage1"
+        , Test "//stage2"
+        , Test "//stage3"
+        , Test "hadrian/.cabal-sandbox"
+        , Test "hadrian/.stack-work"
+        , Test "hadrian/UserSettings.hs"
+        , Test "hadrian/cabal.sandbox.config"
+        , Test "hadrian/cfg/system.config"
+        , Test "hadrian/bin"
+        , Test "hadrian/dist"
+        , Test "hadrian/dist-newstyle"
+        , Test "libraries//*.buildinfo"
+        , Test "libraries//GNUmakefile"
+        , Test "libraries//config.log"
+        , Test "libraries//config.status"
+        , Test "libraries//configure"
+        , Test "libraries//ghc.mk"
+        , Test "libraries//include/Hs*Config.h"
+        , Test "libraries/dph"
+        , Test "libraries/parallel"
+        , Test "libraries/primitive"
+        , Test "libraries/random"
+        , Test "libraries/stm"
+        , Test "libraries/vector"
+        , Test "mk/build.mk" ]
+    srcDirs =
+        [ "bindisttest"
+        , "compiler"
+        , "distrib"
+        , "docs"
+        , "docs"
+        , "driver"
+        , "ghc"
+        , "hadrian"
+        , "includes"
+        , "iserv"
+        , "libffi"
+        , "libffi-tarballs"
+        , "libraries"
+        , "mk"
+        , "rts"
+        , "rules"
+        , "utils" ]
+    srcFiles =
+        [ "ANNOUNCE"
+        , "GIT_COMMIT_ID"
+        , "HACKING.md"
+        , "INSTALL.md"
+        , "LICENSE"
+        , "MAKEHELP.md"
+        , "Makefile"
+        , "README.md"
+        , "VERSION"
+        , "aclocal.m4"
+        , "boot"
+        , "config.guess"
+        , "config.sub"
+        , "configure"
+        , "configure.ac"
+        , "ghc.mk"
+        , "install-sh"
+        , "packages"
+        , "settings.in" ]
diff --git a/src/Rules/Test.hs b/src/Rules/Test.hs
new file mode 100644 (file)
index 0000000..ae37343
--- /dev/null
@@ -0,0 +1,72 @@
+module Rules.Test (testRules) where
+
+import Base
+import Expression
+import Flavour
+import Oracles.Flag
+import Oracles.Setting
+import Settings
+import Target
+import Utilities
+
+-- TODO: clean up after testing
+testRules :: Rules ()
+testRules = do
+    "validate" ~> do
+        need inplaceLibCopyTargets
+        needBuilder $ Ghc CompileHs Stage2
+        needBuilder $ GhcPkg Update Stage1
+        needBuilder Hpc
+        -- TODO: Figure out why @needBuilder Hsc2Hs@ doesn't work.
+        -- TODO: Eliminate explicit filepaths.
+        -- See https://github.com/snowleopard/hadrian/issues/376.
+        need ["inplace/bin/hp2ps", "inplace/bin/hsc2hs"]
+        build $ target (vanillaContext Stage2 compiler) (Make "testsuite/tests") [] []
+
+    "test" ~> do
+        pkgs     <- stagePackages Stage1
+        tests    <- filterM doesDirectoryExist $ concat
+                    [ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ]
+                    | pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ]
+        windows  <- windowsHost
+        top      <- topDirectory
+        compiler <- builderPath $ Ghc CompileHs Stage2
+        ghcPkg   <- builderPath $ GhcPkg Update Stage1
+        haddock  <- builderPath (Haddock BuildPackage)
+        threads  <- shakeThreads <$> getShakeOptions
+        debugged <- ghcDebugged <$> flavour
+        ghcWithNativeCodeGenInt <- fromEnum <$> ghcWithNativeCodeGen
+        ghcWithInterpreterInt   <- fromEnum <$> ghcWithInterpreter
+        ghcUnregisterisedInt    <- fromEnum <$> flag GhcUnregisterised
+        quietly . cmd "python2" $
+            [ "testsuite/driver/runtests.py" ]
+            ++ map ("--rootdir="++) tests ++
+            [ "-e", "windows=" ++ show windows
+            , "-e", "config.speed=2"
+            , "-e", "ghc_compiler_always_flags=" ++ show "-fforce-recomp -dcore-lint -dcmm-lint -dno-debug-output -no-user-package-db -rtsopts"
+            , "-e", "ghc_with_native_codegen=" ++ show ghcWithNativeCodeGenInt
+            , "-e", "ghc_debugged=" ++ show (yesNo debugged)
+            , "-e", "ghc_with_vanilla=1" -- TODO: do we always build vanilla?
+            , "-e", "ghc_with_dynamic=0" -- TODO: support dynamic
+            , "-e", "ghc_with_profiling=0" -- TODO: support profiling
+            , "-e", "ghc_with_interpreter=" ++ show ghcWithInterpreterInt
+            , "-e", "ghc_unregisterised=" ++ show ghcUnregisterisedInt
+            , "-e", "ghc_with_threaded_rts=0" -- TODO: support threaded
+            , "-e", "ghc_with_dynamic_rts=0" -- TODO: support dynamic
+            , "-e", "ghc_dynamic_by_default=False" -- TODO: support dynamic
+            , "-e", "ghc_dynamic=0" -- TODO: support dynamic
+            , "-e", "ghc_with_llvm=0" -- TODO: support LLVM
+            , "-e", "in_tree_compiler=True" -- TODO: when is it equal to False?
+            , "-e", "clean_only=False" -- TODO: do we need to support True?
+            , "--configfile=testsuite/config/ghc"
+            , "--config", "compiler=" ++ show (top -/- compiler)
+            , "--config", "ghc_pkg="  ++ show (top -/- ghcPkg)
+            , "--config", "haddock="  ++ show (top -/- haddock)
+            , "--summary-file", "testsuite_summary.txt"
+            , "--threads=" ++ show threads
+            ]
+
+            -- , "--config", "hp2ps="    ++ quote ("hp2ps")
+            -- , "--config", "hpc="      ++ quote ("hpc")
+            -- , "--config", "gs=$(call quote_path,$(GS))"
+            -- , "--config", "timeout_prog=$(call quote_path,$(TIMEOUT_PROGRAM))"
diff --git a/src/Rules/Wrappers.hs b/src/Rules/Wrappers.hs
new file mode 100644 (file)
index 0000000..20763a7
--- /dev/null
@@ -0,0 +1,162 @@
+module Rules.Wrappers (
+    WrappedBinary(..), Wrapper, inplaceWrappers, installWrappers
+    ) where
+
+import Hadrian.Oracles.Path
+
+import Base
+import Expression
+import Oracles.Setting
+import Settings
+
+-- | Wrapper is an expression depending on (i) the 'FilePath' to the library and
+-- (ii) the name of the wrapped binary.
+data WrappedBinary = WrappedBinary
+    { binaryLibPath :: FilePath
+    , binaryName    :: String }
+
+type Wrapper = WrappedBinary -> Expr String
+
+ghcWrapper :: WrappedBinary -> Expr String
+ghcWrapper WrappedBinary{..} = do
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    bash <- expr bashPath
+    return $ unlines
+        [ "#!"++bash
+        , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
+          ++ " -B" ++ binaryLibPath ++ " ${1+\"$@\"}" ]
+
+inplaceRunGhcWrapper :: WrappedBinary -> Expr String
+inplaceRunGhcWrapper WrappedBinary{..} = do
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    bash <- expr bashPath
+    return $ unlines
+        [ "#!"++bash
+        , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
+          ++ " -f" ++ (binaryLibPath -/- "bin/ghc-stage2") -- TODO: use ProgramName
+          ++ " -B" ++ binaryLibPath ++ " ${1+\"$@\"}" ]
+
+installRunGhcWrapper :: WrappedBinary -> Expr String
+installRunGhcWrapper WrappedBinary{..} = do
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    bash <- expr bashPath
+    return $ unlines
+        [ "#!"++bash
+        , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
+          ++ " -f" ++ (binaryLibPath -/- "bin/ghc") -- TODO: use ProgramName
+          ++ " -B" ++ binaryLibPath ++ " ${1+\"$@\"}" ]
+
+inplaceGhcPkgWrapper :: WrappedBinary -> Expr String
+inplaceGhcPkgWrapper WrappedBinary{..} = do
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    top <- expr topDirectory
+    -- The wrapper is generated in StageN, but used in StageN+1. Therefore, we
+    -- always use the inplace package database, located at 'inplacePackageDbPath',
+    -- which is used in Stage1 and later.
+    bash <- expr bashPath
+    return $ unlines
+        [ "#!" ++ bash
+        , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) ++
+          " --global-package-db " ++ top -/- inplacePackageDbPath ++ " ${1+\"$@\"}" ]
+
+installGhcPkgWrapper :: WrappedBinary -> Expr String
+installGhcPkgWrapper WrappedBinary{..} = do
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    stage <- getStage
+    top   <- expr topDirectory
+    -- Use the package configuration for the next stage in the wrapper.
+    -- The wrapper is generated in StageN, but used in StageN+1.
+    packageDb <- expr $ installPackageDbPath binaryLibPath top (succ stage)
+    bash <- expr bashPath
+    return $ unlines
+        [ "#!"++bash
+        , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
+          ++ " --global-package-db " ++ packageDb ++ " ${1+\"$@\"}" ]
+
+hp2psWrapper :: WrappedBinary -> Expr String
+hp2psWrapper WrappedBinary{..} = do
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    bash <- expr bashPath
+    return $ unlines
+        [ "#!"++bash
+        , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) ++ " ${1+\"$@\"}" ]
+
+hpcWrapper :: WrappedBinary -> Expr String
+hpcWrapper WrappedBinary{..} = do
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    bash <- expr bashPath
+    return $ unlines
+        [ "#!"++bash
+        , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) ++ " ${1+\"$@\"}" ]
+
+hsc2hsWrapper :: WrappedBinary -> Expr String
+hsc2hsWrapper WrappedBinary{..} = do
+    top <- expr topDirectory
+    expr $ need [ sourcePath -/- "Rules/Wrappers.hs" ]
+    contents <- expr $ readFile' $ top -/- "utils/hsc2hs/hsc2hs.wrapper"
+    let executableName = binaryLibPath -/- "bin" -/- binaryName
+    confCcArgs <- expr $ settingList (ConfCcArgs Stage1)
+    confGccLinkerArgs <- expr $ settingList (ConfGccLinkerArgs Stage1)
+    let hsc2hsExtra = unwords (map ("-cflags=" ++) confCcArgs) ++ " " ++
+                      unwords (map ("-lflags=" ++) confGccLinkerArgs)
+    bash <- expr bashPath
+    return $ unlines
+        [ "#!"++bash
+        , "executablename=\"" ++ executableName ++ "\""
+        , "HSC2HS_EXTRA=\"" ++ hsc2hsExtra ++ "\""
+        , contents ]
+
+haddockWrapper :: WrappedBinary -> Expr String
+haddockWrapper WrappedBinary{..} = do
+  expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+  return $ unlines
+    [ "#!/bin/bash"
+    , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName)
+      ++ " -B" ++ binaryLibPath ++ " -l" ++ binaryLibPath ++ " ${1+\"$@\"}" ]
+
+iservBinWrapper :: WrappedBinary -> Expr String
+iservBinWrapper WrappedBinary{..} = do
+    expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
+    stage <- getStage
+    stageLibraries <- expr $ filter isLibrary <$> stagePackages stage
+    -- TODO: Figure our the reason of this hardcoded exclusion
+    let pkgs = stageLibraries \\ [ cabal, process, haskeline
+                                 , terminfo, ghcCompact, hpc, compiler ]
+    contexts <- expr $ concatForM pkgs $ \p -> do
+        maybeStage <- installStage p
+        return [ vanillaContext s p | s <- maybeToList maybeStage ]
+    buildPaths <- expr $ mapM buildPath contexts
+    return $ unlines
+        [ "#!/bin/bash"
+        , "export DYLD_LIBRARY_PATH=\"" ++ intercalate ":" buildPaths ++
+          "${DYLD_LIBRARY_PATH:+:$DYLD_LIBRARY_PATH}\""
+       , "exec " ++ (binaryLibPath -/- "bin" -/- binaryName) ++ " ${1+\"$@\"}" ]
+
+wrappersCommon :: [(Context, Wrapper)]
+wrappersCommon = [ (vanillaContext Stage0 ghc   , ghcWrapper)
+                 , (vanillaContext Stage1 ghc   , ghcWrapper)
+                 , (vanillaContext Stage1 hp2ps , hp2psWrapper)
+                 , (vanillaContext Stage1 hpc   , hpcWrapper)
+                 , (vanillaContext Stage1 hsc2hs, hsc2hsWrapper)
+                 , (vanillaContext Stage2 haddock, haddockWrapper)
+                 , (vanillaContext Stage1 iservBin, iservBinWrapper) ]
+
+-- | List of wrappers for inplace artefacts
+inplaceWrappers :: [(Context, Wrapper)]
+inplaceWrappers = wrappersCommon ++
+                  [ (vanillaContext Stage0 ghcPkg, inplaceGhcPkgWrapper)
+                  , (vanillaContext Stage1 runGhc, inplaceRunGhcWrapper) ]
+
+-- | List of wrappers for installation
+installWrappers :: [(Context, Wrapper)]
+installWrappers = wrappersCommon ++
+                  [ (vanillaContext Stage0 ghcPkg, installGhcPkgWrapper)
+                  , (vanillaContext Stage1 runGhc, installRunGhcWrapper) ]
+
+-- | In the final installation path specified by @DEST@, there is another
+-- @package.conf.d@ different from 'inplacePackageDbPath' defined in "Base".
+installPackageDbPath :: FilePath -> FilePath -> Stage -> Action FilePath
+installPackageDbPath _ top Stage0 = do
+    path <- buildRoot
+    return $ top -/- path -/- "stage0/bootstrapping.conf"
+installPackageDbPath libdir _ _ = return $ libdir -/- "package.conf.d"
diff --git a/src/Settings.hs b/src/Settings.hs
new file mode 100644 (file)
index 0000000..091efc1
--- /dev/null
@@ -0,0 +1,68 @@
+module Settings (
+    getArgs, getLibraryWays, getRtsWays, flavour, knownPackages,
+    findPackageByName, getPkgData, getPkgDataList, isLibrary, stagePackages,
+    programContext, getIntegerPackage, getDestDir
+    ) where
+
+import CommandLine
+import Expression
+import Flavour
+import {-# SOURCE #-} Settings.Default
+import Settings.Flavours.Development
+import Settings.Flavours.Performance
+import Settings.Flavours.Profiled
+import Settings.Flavours.Quick
+import Settings.Flavours.Quickest
+import Settings.Flavours.QuickCross
+import UserSettings
+
+getArgs :: Args
+getArgs = expr flavour >>= args
+
+getLibraryWays :: Ways
+getLibraryWays = expr flavour >>= libraryWays
+
+getRtsWays :: Ways
+getRtsWays = expr flavour >>= rtsWays
+
+stagePackages :: Stage -> Action [Package]
+stagePackages stage = do
+    f <- flavour
+    packages f stage
+
+hadrianFlavours :: [Flavour]
+hadrianFlavours =
+    [ defaultFlavour, developmentFlavour Stage1, developmentFlavour Stage2
+    , performanceFlavour, profiledFlavour, quickFlavour, quickestFlavour
+    , quickCrossFlavour ]
+
+flavour :: Action Flavour
+flavour = do
+    flavourName <- fromMaybe "default" <$> cmdFlavour
+    let unknownFlavour = error $ "Unknown build flavour: " ++ flavourName
+        flavours       = hadrianFlavours ++ userFlavours
+    return $ fromMaybe unknownFlavour $ find ((== flavourName) . name) flavours
+
+getIntegerPackage :: Expr Package
+getIntegerPackage = expr (integerLibrary =<< flavour)
+
+programContext :: Stage -> Package -> Action Context
+programContext stage pkg = do
+    profiled <- ghcProfiled <$> flavour
+    return $ if pkg == ghc && profiled && stage > Stage0
+             then Context stage pkg profiling
+             else vanillaContext stage pkg
+
+-- TODO: switch to Set Package as the order of packages should not matter?
+-- Otherwise we have to keep remembering to sort packages from time to time.
+knownPackages :: [Package]
+knownPackages = sort $ ghcPackages ++ userPackages
+
+-- TODO: Speed up? Switch to Set?
+-- Note: this is slow but we keep it simple as there are just ~50 packages
+findPackageByName :: PackageName -> Maybe Package
+findPackageByName name = find (\pkg -> pkgName pkg == name) knownPackages
+
+-- | Install's DESTDIR setting.
+getDestDir :: Action FilePath
+getDestDir = fromMaybe "" <$> cmdInstallDestDir
diff --git a/src/Settings/Builders/Alex.hs b/src/Settings/Builders/Alex.hs
new file mode 100644 (file)
index 0000000..e0ef136
--- /dev/null
@@ -0,0 +1,8 @@
+module Settings.Builders.Alex (alexBuilderArgs) where
+
+import Settings.Builders.Common
+
+alexBuilderArgs :: Args
+alexBuilderArgs = builder Alex ? mconcat [ arg "-g"
+                                         , arg =<< getInput
+                                         , arg "-o", arg =<< getOutput ]
diff --git a/src/Settings/Builders/Cc.hs b/src/Settings/Builders/Cc.hs
new file mode 100644 (file)
index 0000000..70d043f
--- /dev/null
@@ -0,0 +1,26 @@
+module Settings.Builders.Cc (ccBuilderArgs) where
+
+import Settings.Builders.Common
+
+ccBuilderArgs :: Args
+ccBuilderArgs = do
+    way <- getWay
+    builder Cc ? mconcat
+        [ getPkgDataList CcArgs
+        , getStagedSettingList ConfCcArgs
+        , cIncludeArgs
+
+        , builder (Cc CompileC) ? mconcat
+            [ pure ["-Wall", "-Werror"]
+            , Dynamic `wayUnit` way ? pure [ "-fPIC", "-DDYNAMIC" ]
+            , arg "-c", arg =<< getInput
+            , arg "-o", arg =<< getOutput ]
+
+        , builder (Cc FindCDependencies) ? do
+            output <- getOutput
+            mconcat [ arg "-E"
+                    , arg "-MM", arg "-MG"
+                    , arg "-MF", arg output
+                    , arg "-MT", arg $ dropExtension output -<.> "o"
+                    , arg "-x", arg "c"
+                    , arg =<< getInput ] ]
diff --git a/src/Settings/Builders/Common.hs b/src/Settings/Builders/Common.hs
new file mode 100644 (file)
index 0000000..5ca594e
--- /dev/null
@@ -0,0 +1,59 @@
+module Settings.Builders.Common (
+    module Base,
+    module Expression,
+    module Oracles.Flag,
+    module Oracles.PackageData,
+    module Oracles.Setting,
+    module Settings,
+    module UserSettings,
+    cIncludeArgs, ldArgs, cArgs, cWarnings, bootPackageDatabaseArgs
+    ) where
+
+import Base
+import Expression
+import Oracles.Flag
+import Oracles.PackageData
+import Oracles.Setting
+import Settings
+import UserSettings
+
+cIncludeArgs :: Args
+cIncludeArgs = do
+    pkg     <- getPackage
+    root    <- getBuildRoot
+    path    <- getBuildPath
+    incDirs <- getPkgDataList IncludeDirs
+    depDirs <- getPkgDataList DepIncludeDirs
+    cross   <- expr crossCompiling
+    compilerOrGhc <- package compiler ||^ package ghc
+    mconcat [ not (cross && compilerOrGhc) ? arg "-Iincludes"
+            , arg $ "-I" ++ root -/- generatedDir
+            , arg $ "-I" ++ path
+            , pure [ "-I" ++ pkgPath pkg -/- dir | dir <- incDirs ]
+            , pure [ "-I" ++       unifyPath dir | dir <- depDirs ] ]
+
+ldArgs :: Args
+ldArgs = mempty
+
+cArgs :: Args
+cArgs = mempty
+
+-- TODO: should be in a different file
+cWarnings :: Args
+cWarnings = do
+    let gccGe46 = notM (flag GccIsClang ||^ flag GccLt46)
+    mconcat [ arg "-Wall"
+            , flag GccIsClang ? arg "-Wno-unknown-pragmas"
+            , gccGe46 ? notM windowsHost ? arg "-Werror=unused-but-set-variable"
+            , gccGe46 ? arg "-Wno-error=inline" ]
+
+bootPackageDatabaseArgs :: Args
+bootPackageDatabaseArgs = do
+    stage  <- getStage
+    dbPath <- expr $ packageDbPath stage
+    expr $ need [dbPath -/- packageDbStamp]
+    stage0 ? do
+        top    <- expr topDirectory
+        root   <- getBuildRoot
+        prefix <- ifM (builder Ghc) (return "-package-db ") (return "--package-db=")
+        arg $ prefix ++ top -/- root -/- stage0PackageDbDir
diff --git a/src/Settings/Builders/Configure.hs b/src/Settings/Builders/Configure.hs
new file mode 100644 (file)
index 0000000..93225b5
--- /dev/null
@@ -0,0 +1,25 @@
+module Settings.Builders.Configure (configureBuilderArgs) where
+
+import Rules.Gmp
+import Rules.Libffi
+import Settings.Builders.Common
+
+configureBuilderArgs :: Args
+configureBuilderArgs = do
+    gmpPath    <- expr gmpBuildPath
+    libffiPath <- expr libffiBuildPath
+    mconcat [ builder (Configure gmpPath) ? do
+                hostPlatform  <- getSetting HostPlatform
+                buildPlatform <- getSetting BuildPlatform
+                pure [ "--enable-shared=no"
+                     , "--host=" ++ hostPlatform
+                     , "--build=" ++ buildPlatform ]
+
+            , builder (Configure libffiPath) ? do
+                top            <- expr topDirectory
+                targetPlatform <- getSetting TargetPlatform
+                pure [ "--prefix=" ++ top -/- libffiPath -/- "inst"
+                     , "--libdir=" ++ top -/- libffiPath -/- "inst/lib"
+                     , "--enable-static=yes"
+                     , "--enable-shared=no" -- TODO: add support for yes
+                     , "--host=" ++ targetPlatform ] ]
diff --git a/src/Settings/Builders/DeriveConstants.hs b/src/Settings/Builders/DeriveConstants.hs
new file mode 100644 (file)
index 0000000..7a6e863
--- /dev/null
@@ -0,0 +1,39 @@
+module Settings.Builders.DeriveConstants (deriveConstantsBuilderArgs) where
+
+import Settings.Builders.Common
+
+-- TODO: do we need to support `includes_CC_OPTS += -DDYNAMIC_BY_DEFAULT`?
+deriveConstantsBuilderArgs :: Args
+deriveConstantsBuilderArgs = builder DeriveConstants ? do
+    cFlags <- includeCcArgs
+    outs   <- getOutputs
+    let (outputFile, tempDir) = case outs of
+            [a, b] -> (a, b)
+            _      -> error $ "DeriveConstants: expected two outputs, got " ++ show outs
+    mconcat
+        [ output "//DerivedConstants.h"             ? arg "--gen-header"
+        , output "//GHCConstantsHaskellType.hs"     ? arg "--gen-haskell-type"
+        , output "//platformConstants"              ? arg "--gen-haskell-value"
+        , output "//GHCConstantsHaskellWrappers.hs" ? arg "--gen-haskell-wrappers"
+        , output "//GHCConstantsHaskellExports.hs"  ? arg "--gen-haskell-exports"
+        , arg "-o", arg outputFile
+        , arg "--tmpdir", arg tempDir
+        , arg "--gcc-program", arg =<< getBuilderPath (Cc CompileC Stage1)
+        , pure $ concatMap (\a -> ["--gcc-flag", a]) cFlags
+        , arg "--nm-program", arg =<< getBuilderPath Nm
+        , isSpecified Objdump ? mconcat [ arg "--objdump-program"
+                                        , arg =<< getBuilderPath Objdump ]
+        , arg "--target-os", arg =<< getSetting TargetOs ]
+
+includeCcArgs :: Args
+includeCcArgs = do
+    root <- getBuildRoot
+    mconcat [ cArgs
+            , cWarnings
+            , getSettingList $ ConfCcArgs Stage1
+            , flag GhcUnregisterised ? arg "-DUSE_MINIINTERPRETER"
+            , arg "-Irts"
+            , arg "-Iincludes"
+            , arg $ "-I" ++ root -/- generatedDir
+            , notM ghcWithSMP ? arg "-DNOSMP"
+            , arg "-fcommon" ]
diff --git a/src/Settings/Builders/GenPrimopCode.hs b/src/Settings/Builders/GenPrimopCode.hs
new file mode 100644 (file)
index 0000000..e616ed3
--- /dev/null
@@ -0,0 +1,24 @@
+module Settings.Builders.GenPrimopCode (genPrimopCodeBuilderArgs) where
+
+import Settings.Builders.Common
+
+genPrimopCodeBuilderArgs :: Args
+genPrimopCodeBuilderArgs = builder GenPrimopCode ? mconcat
+    [ output "//PrimopWrappers.hs"                 ? arg "--make-haskell-wrappers"
+    , output "//Prim.hs"                           ? arg "--make-haskell-source"
+    , output "//primop-data-decl.hs-incl"          ? arg "--data-decl"
+    , output "//primop-tag.hs-incl"                ? arg "--primop-tag"
+    , output "//primop-list.hs-incl"               ? arg "--primop-list"
+    , output "//primop-has-side-effects.hs-incl"   ? arg "--has-side-effects"
+    , output "//primop-out-of-line.hs-incl"        ? arg "--out-of-line"
+    , output "//primop-commutable.hs-incl"         ? arg "--commutable"
+    , output "//primop-code-size.hs-incl"          ? arg "--code-size"
+    , output "//primop-can-fail.hs-incl"           ? arg "--can-fail"
+    , output "//primop-strictness.hs-incl"         ? arg "--strictness"
+    , output "//primop-fixity.hs-incl"             ? arg "--fixity"
+    , output "//primop-primop-info.hs-incl"        ? arg "--primop-primop-info"
+    , output "//primop-vector-uniques.hs-incl"     ? arg "--primop-vector-uniques"
+    , output "//primop-vector-tys.hs-incl"         ? arg "--primop-vector-tys"
+    , output "//primop-vector-tys-exports.hs-incl" ? arg "--primop-vector-tys-exports"
+    , output "//primop-vector-tycons.hs-incl"      ? arg "--primop-vector-tycons"
+    , output "//primop-usage.hs-incl"              ? arg "--usage" ]
diff --git a/src/Settings/Builders/Ghc.hs b/src/Settings/Builders/Ghc.hs
new file mode 100644 (file)
index 0000000..a975e7e
--- /dev/null
@@ -0,0 +1,149 @@
+module Settings.Builders.Ghc (ghcBuilderArgs, haddockGhcArgs) where
+
+import Hadrian.Haskell.Cabal
+
+import Flavour
+import Rules.Gmp
+import Settings.Builders.Common
+import Settings.Warnings
+
+ghcBuilderArgs :: Args
+ghcBuilderArgs = mconcat [compileAndLinkHs, compileC, findHsDependencies]
+
+compileAndLinkHs :: Args
+compileAndLinkHs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do
+    needTouchy
+    mconcat [ arg "-Wall"
+            , commonGhcArgs
+            , splitObjectsArgs
+            , ghcLinkArgs
+            , defaultGhcWarningsArgs
+            , builder (Ghc CompileHs) ? arg "-c"
+            , getInputs
+            , arg "-o", arg =<< getOutput ]
+
+needTouchy :: Expr ()
+needTouchy = notStage0 ? windowsHost ? do
+    touchyPath <- expr $ programPath (vanillaContext Stage0 touchy)
+    expr $ need [touchyPath]
+
+compileC :: Args
+compileC = builder (Ghc CompileCWithGhc) ? do
+    way <- getWay
+    let ccArgs = [ getPkgDataList CcArgs
+                 , getStagedSettingList ConfCcArgs
+                 , cIncludeArgs
+                 , Dynamic `wayUnit` way ? pure [ "-fPIC", "-DDYNAMIC" ] ]
+    mconcat [ arg "-Wall"
+            , ghcLinkArgs
+            , commonGhcArgs
+            , mconcat (map (map ("-optc" ++) <$>) ccArgs)
+            , defaultGhcWarningsArgs
+            , arg "-c"
+            , getInputs
+            , arg "-o"
+            , arg =<< getOutput ]
+
+ghcLinkArgs :: Args
+ghcLinkArgs = builder (Ghc LinkHs) ? do
+    stage   <- getStage
+    way     <- getWay
+    pkg     <- getPackage
+    libs    <- getPkgDataList DepExtraLibs
+    libDirs <- getPkgDataList DepLibDirs
+    intLib  <- getIntegerPackage
+    gmpLibs <- if stage > Stage0 && intLib == integerGmp
+               then do -- TODO: get this data more gracefully
+                   let strip = fromMaybe "" . stripPrefix "extra-libraries: "
+                   buildInfo <- expr $ readFileLines gmpBuildInfoPath
+                   return $ concatMap (words . strip) buildInfo
+               else return []
+    mconcat [ (Dynamic `wayUnit` way) ?
+              pure [ "-shared", "-dynamic", "-dynload", "deploy" ]
+            , arg "-no-auto-link-packages"
+            ,      nonHsMainPackage pkg  ? arg "-no-hs-main"
+            , not (nonHsMainPackage pkg) ? arg "-rtsopts"
+            , pure [ "-optl-l" ++           lib | lib <- libs ++ gmpLibs ]
+            , pure [ "-optl-L" ++ unifyPath dir | dir <- libDirs ] ]
+
+splitObjectsArgs :: Args
+splitObjectsArgs = splitObjects <$> flavour ? do
+    expr $ need [ghcSplitPath]
+    arg "-split-objs"
+
+findHsDependencies :: Args
+findHsDependencies = builder (Ghc FindHsDependencies) ? do
+    ways <- getLibraryWays
+    mconcat [ arg "-M"
+            , commonGhcArgs
+            , arg "-include-pkg-deps"
+            , arg "-dep-makefile", arg =<< getOutput
+            , pure $ concat [ ["-dep-suffix", wayPrefix w] | w <- ways ]
+            , getInputs ]
+
+haddockGhcArgs :: Args
+haddockGhcArgs = mconcat [ commonGhcArgs, getPkgDataList HsArgs ]
+
+-- Used in ghcBuilderArgs, ghcCBuilderArgs, ghcMBuilderArgs and haddockGhcArgs.
+commonGhcArgs :: Args
+commonGhcArgs = do
+    way     <- getWay
+    path    <- getBuildPath
+    pkg     <- getPackage
+    when (isLibrary pkg) $ do
+        context <- getContext
+        conf <- expr $ pkgConfFile context
+        expr $ need [conf]
+    mconcat [ arg "-hisuf", arg $ hisuf way
+            , arg "-osuf" , arg $  osuf way
+            , arg "-hcsuf", arg $ hcsuf way
+            , wayGhcArgs
+            , packageGhcArgs
+            , includeGhcArgs
+            , map ("-optc" ++) <$> getStagedSettingList ConfCcArgs
+            , map ("-optP" ++) <$> getStagedSettingList ConfCppArgs
+            , map ("-optP" ++) <$> getPkgDataList CppArgs
+            , arg "-odir"    , arg path
+            , arg "-hidir"   , arg path
+            , arg "-stubdir" , arg path ]
+
+-- TODO: Do '-ticky' in all debug ways?
+wayGhcArgs :: Args
+wayGhcArgs = do
+    way <- getWay
+    mconcat [ if (Dynamic `wayUnit` way)
+              then pure ["-fPIC", "-dynamic"]
+              else arg "-static"
+            , (Threaded  `wayUnit` way) ? arg "-optc-DTHREADED_RTS"
+            , (Debug     `wayUnit` way) ? arg "-optc-DDEBUG"
+            , (Profiling `wayUnit` way) ? arg "-prof"
+            , (Logging   `wayUnit` way) ? arg "-eventlog"
+            , (way == debug || way == debugDynamic) ?
+              pure ["-ticky", "-DTICKY_TICKY"] ]
+
+packageGhcArgs :: Args
+packageGhcArgs = withHsPackage $ \cabalFile -> do
+    pkgId <- expr $ pkgIdentifier cabalFile
+    mconcat [ arg "-hide-all-packages"
+            , arg "-no-user-package-db"
+            , bootPackageDatabaseArgs
+            , libraryPackage ? arg ("-this-unit-id " ++ pkgId)
+            , map ("-package-id " ++) <$> getPkgDataList DepIds ]
+
+includeGhcArgs :: Args
+includeGhcArgs = do
+    pkg     <- getPackage
+    path    <- getBuildPath
+    root    <- getBuildRoot
+    context <- getContext
+    srcDirs <- getPkgDataList SrcDirs
+    autogen <- expr $ autogenPath context
+    mconcat [ arg "-i"
+            , arg $ "-i" ++ path
+            , arg $ "-i" ++ autogen
+            , pure [ "-i" ++ pkgPath pkg -/- dir | dir <- srcDirs ]
+            , cIncludeArgs
+            , arg $      "-I" ++ root -/- generatedDir
+            , arg $ "-optc-I" ++ root -/- generatedDir
+            , (not $ nonCabalContext context) ?
+              pure [ "-optP-include", "-optP" ++ autogen -/- "cabal_macros.h" ] ]
diff --git a/src/Settings/Builders/GhcCabal.hs b/src/Settings/Builders/GhcCabal.hs
new file mode 100644 (file)
index 0000000..bfb84a7
--- /dev/null
@@ -0,0 +1,118 @@
+module Settings.Builders.GhcCabal (
+    ghcCabalBuilderArgs
+    ) where
+
+import Hadrian.Haskell.Cabal
+
+import Context
+import Flavour
+import Settings.Builders.Common
+
+ghcCabalBuilderArgs :: Args
+ghcCabalBuilderArgs = builder GhcCabal ? do
+    verbosity <- expr getVerbosity
+    top       <- expr topDirectory
+    path      <- getBuildPath
+    notStage0 ? expr (need inplaceLibCopyTargets)
+    mconcat [ arg "configure"
+            , arg =<< pkgPath <$> getPackage
+            , arg $ top -/- path
+            , withStaged $ Ghc CompileHs
+            , withStaged (GhcPkg Update)
+            , bootPackageDatabaseArgs
+            , libraryArgs
+            , configureArgs
+            , bootPackageConstraints
+            , withStaged $ Cc CompileC
+            , notStage0 ? with Ld
+            , withStaged (Ar Pack)
+            , with Alex
+            , with Happy
+            , verbosity < Chatty ? pure [ "-v0", "--configure-option=--quiet"
+                , "--configure-option=--disable-option-checking"  ] ]
+
+-- TODO: Isn't vanilla always built? If yes, some conditions are redundant.
+-- TODO: Need compiler_stage1_CONFIGURE_OPTS += --disable-library-for-ghci?
+libraryArgs :: Args
+libraryArgs = do
+    ways        <- getLibraryWays
+    withGhci    <- expr ghcWithInterpreter
+    dynPrograms <- dynamicGhcPrograms <$> expr flavour
+    pure [ if vanilla `elem` ways
+           then  "--enable-library-vanilla"
+           else "--disable-library-vanilla"
+         , if vanilla `elem` ways && withGhci && not dynPrograms
+           then  "--enable-library-for-ghci"
+           else "--disable-library-for-ghci"
+         , if profiling `elem` ways
+           then  "--enable-library-profiling"
+           else "--disable-library-profiling"
+         , if dynamic `elem` ways
+           then  "--enable-shared"
+           else "--disable-shared" ]
+
+-- TODO: LD_OPTS?
+configureArgs :: Args
+configureArgs = do
+    top  <- expr topDirectory
+    root <- getBuildRoot
+    let conf key expr = do
+            values <- unwords <$> expr
+            not (null values) ?
+                arg ("--configure-option=" ++ key ++ "=" ++ values)
+        cFlags   = mconcat [ remove ["-Werror"] cArgs
+                           , getStagedSettingList ConfCcArgs
+                           , arg $ "-I" ++ top -/- root -/- generatedDir ]
+        ldFlags  = ldArgs  <> (getStagedSettingList ConfGccLinkerArgs)
+        cppFlags = cppArgs <> (getStagedSettingList ConfCppArgs)
+    cldFlags <- unwords <$> (cFlags <> ldFlags)
+    mconcat
+        [ conf "CFLAGS"   cFlags
+        , conf "LDFLAGS"  ldFlags
+        , conf "CPPFLAGS" cppFlags
+        , not (null cldFlags) ? arg ("--gcc-options=" ++ cldFlags)
+        , conf "--with-iconv-includes"    $ arg =<< getSetting IconvIncludeDir
+        , conf "--with-iconv-libraries"   $ arg =<< getSetting IconvLibDir
+        , conf "--with-gmp-includes"      $ arg =<< getSetting GmpIncludeDir
+        , conf "--with-gmp-libraries"     $ arg =<< getSetting GmpLibDir
+        , conf "--with-curses-libraries"  $ arg =<< getSetting CursesLibDir
+        , crossCompiling ? (conf "--host" $ arg =<< getSetting TargetPlatformFull)
+        , conf "--with-cc" $ arg =<< getBuilderPath . (Cc CompileC) =<< getStage ]
+
+bootPackageConstraints :: Args
+bootPackageConstraints = stage0 ? do
+    bootPkgs <- expr $ stagePackages Stage0
+    let pkgs = filter (\p -> p /= compiler && isLibrary p) bootPkgs
+    constraints <- expr $ fmap catMaybes $ forM (sort pkgs) $ \pkg -> do
+        version <- traverse pkgVersion (pkgCabalFile pkg)
+        return $ fmap ((pkgName pkg ++ " == ") ++) version
+    pure $ concat [ ["--constraint", c] | c <- constraints ]
+
+cppArgs :: Args
+cppArgs = do
+    root <- getBuildRoot
+    arg $ "-I" ++ root -/- generatedDir
+
+withBuilderKey :: Builder -> String
+withBuilderKey b = case b of
+    Ar _ _     -> "--with-ar="
+    Ld         -> "--with-ld="
+    Cc  _ _    -> "--with-gcc="
+    Ghc _ _    -> "--with-ghc="
+    Alex       -> "--with-alex="
+    Happy      -> "--with-happy="
+    GhcPkg _ _ -> "--with-ghc-pkg="
+    _          -> error $ "withBuilderKey: not supported builder " ++ show b
+
+-- Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex.
+with :: Builder -> Args
+with b = do
+    path <- getBuilderPath b
+    if (null path) then mempty else do
+        top  <- expr topDirectory
+        expr $ needBuilder b
+        arg $ withBuilderKey b ++ unifyPath (top </> path)
+
+withStaged :: (Stage -> Builder) -> Args
+withStaged sb = with . sb =<< getStage
+
diff --git a/src/Settings/Builders/GhcPkg.hs b/src/Settings/Builders/GhcPkg.hs
new file mode 100644 (file)
index 0000000..ba705c6
--- /dev/null
@@ -0,0 +1,17 @@
+module Settings.Builders.GhcPkg (ghcPkgBuilderArgs) where
+
+import Settings.Builders.Common
+
+ghcPkgBuilderArgs :: Args
+ghcPkgBuilderArgs = mconcat
+    [ builder (GhcPkg Init) ? mconcat [ arg "init", arg =<< getOutput ]
+
+    , builder (GhcPkg Update) ? do
+        verbosity <- expr getVerbosity
+        context   <- getContext
+        config    <- expr $ pkgInplaceConfig context
+        mconcat [ arg "update"
+                , arg "--force"
+                , verbosity < Chatty ? arg "-v0"
+                , bootPackageDatabaseArgs
+                , arg config ] ]
diff --git a/src/Settings/Builders/Haddock.hs b/src/Settings/Builders/Haddock.hs
new file mode 100644 (file)
index 0000000..b381047
--- /dev/null
@@ -0,0 +1,63 @@
+module Settings.Builders.Haddock (haddockBuilderArgs) where
+
+import Hadrian.Utilities
+import Hadrian.Haskell.Cabal
+
+import Rules.Documentation
+import Settings.Builders.Common
+import Settings.Builders.Ghc
+
+-- | Given a version string such as "2.16.2" produce an integer equivalent.
+versionToInt :: String -> Int
+versionToInt s = case map read . words $ replaceEq '.' ' ' s of
+    [major, minor, patch] -> major * 1000 + minor * 10 + patch
+    _                     -> error "versionToInt: cannot parse version."
+
+haddockBuilderArgs :: Args
+haddockBuilderArgs = withHsPackage $ \cabalFile -> mconcat
+    [ builder (Haddock BuildIndex) ? do
+        output <- getOutput
+        inputs <- getInputs
+        mconcat
+            [ arg "--gen-index"
+            , arg "--gen-contents"
+            , arg "-o", arg $ takeDirectory output
+            , arg "-t", arg "Haskell Hierarchical Libraries"
+            , arg "-p", arg "libraries/prologue.txt"
+            , pure [ "--read-interface="
+                     ++ (takeFileName . takeDirectory) haddock
+                     ++ "," ++ haddock | haddock <- inputs ] ]
+
+    , builder (Haddock BuildPackage) ? do
+        output   <- getOutput
+        pkg      <- getPackage
+        path     <- getBuildPath
+        version  <- expr $ pkgVersion  cabalFile
+        synopsis <- expr $ pkgSynopsis cabalFile
+        deps     <- getPkgDataList DepNames
+        haddocks <- expr . haddockDependencies =<< getContext
+        hVersion <- expr $ pkgVersion (unsafePkgCabalFile haddock) -- TODO: improve
+        ghcOpts  <- haddockGhcArgs
+        mconcat
+            [ arg $ "--odir=" ++ takeDirectory output
+            , arg "--verbosity=0"
+            , arg "--no-tmp-comp-dir"
+            , arg $ "--dump-interface=" ++ output
+            , arg "--html"
+            , arg "--hyperlinked-source"
+            , arg "--hoogle"
+            , arg $ "--title=" ++ pkgName pkg ++ "-" ++ version
+                    ++ ": " ++ synopsis
+            , arg $ "--prologue=" ++ path -/- "haddock-prologue.txt"
+            , arg $ "--optghc=-D__HADDOCK_VERSION__="
+                    ++ show (versionToInt hVersion)
+            , map ("--hide=" ++) <$> getPkgDataList HiddenModules
+            , pure [ "--read-interface=../" ++ dep
+                     ++ ",../" ++ dep ++ "/src/%{MODULE}.html#%{NAME},"
+                     ++ haddock | (dep, haddock) <- zip deps haddocks ]
+            , pure [ "--optghc=" ++ opt | opt <- ghcOpts ]
+            , getInputs
+            , arg "+RTS"
+            , arg $ "-t" ++ path -/- "haddock.t"
+            , arg "--machine-readable"
+            , arg "-RTS" ] ]
diff --git a/src/Settings/Builders/Happy.hs b/src/Settings/Builders/Happy.hs
new file mode 100644 (file)
index 0000000..5ffb261
--- /dev/null
@@ -0,0 +1,9 @@
+module Settings.Builders.Happy (happyBuilderArgs) where
+
+import Settings.Builders.Common
+
+happyBuilderArgs :: Args
+happyBuilderArgs = builder Happy ? mconcat [ arg "-agc"
+                                           , arg "--strict"
+                                           , arg =<< getInput
+                                           , arg "-o", arg =<< getOutput ]
diff --git a/src/Settings/Builders/HsCpp.hs b/src/Settings/Builders/HsCpp.hs
new file mode 100644 (file)
index 0000000..aeb5255
--- /dev/null
@@ -0,0 +1,16 @@
+module Settings.Builders.HsCpp (hsCppBuilderArgs) where
+
+import Settings.Builders.Common
+
+hsCppBuilderArgs :: Args
+hsCppBuilderArgs = builder HsCpp ? do
+    stage   <- getStage
+    root    <- getBuildRoot
+    ghcPath <- expr $ buildPath (vanillaContext stage compiler)
+    mconcat [ getSettingList HsCppArgs
+            , arg "-P"
+            , arg "-Iincludes"
+            , arg $ "-I" ++ root -/- generatedDir
+            , arg $ "-I" ++ ghcPath
+            , arg "-x", arg "c"
+            , arg =<< getInput ]
diff --git a/src/Settings/Builders/Hsc2Hs.hs b/src/Settings/Builders/Hsc2Hs.hs
new file mode 100644 (file)
index 0000000..6185f6b
--- /dev/null
@@ -0,0 +1,56 @@
+module Settings.Builders.Hsc2Hs (hsc2hsBuilderArgs) where
+
+import Settings.Builders.Common
+
+hsc2hsBuilderArgs :: Args
+hsc2hsBuilderArgs = builder Hsc2Hs ? do
+    stage   <- getStage
+    ccPath  <- getBuilderPath $ Cc CompileC stage
+    gmpDir  <- getSetting GmpIncludeDir
+    top     <- expr topDirectory
+    hArch   <- getSetting HostArch
+    hOs     <- getSetting HostOs
+    tArch   <- getSetting TargetArch
+    tOs     <- getSetting TargetOs
+    version <- if stage == Stage0
+               then expr ghcCanonVersion
+               else getSetting ProjectVersionInt
+    mconcat [ arg $ "--cc=" ++ ccPath
+            , arg $ "--ld=" ++ ccPath
+            , notM windowsHost ? arg "--cross-safe"
+            , pure $ map ("-I" ++) (words gmpDir)
+            , map ("--cflag=" ++) <$> getCFlags
+            , map ("--lflag=" ++) <$> getLFlags
+            , notStage0 ? crossCompiling ? arg "--cross-compile"
+            , stage0    ? arg ("--cflag=-D" ++ hArch ++ "_HOST_ARCH=1")
+            , stage0    ? arg ("--cflag=-D" ++ hOs   ++ "_HOST_OS=1"  )
+            , notStage0 ? arg ("--cflag=-D" ++ tArch ++ "_HOST_ARCH=1")
+            , notStage0 ? arg ("--cflag=-D" ++ tOs   ++ "_HOST_OS=1"  )
+            , arg $ "--cflag=-D__GLASGOW_HASKELL__=" ++ version
+            , arg $ "--template=" ++ top -/- templateHscPath
+            , arg $ "-I" ++ top -/- "inplace/lib/include/"
+            , arg =<< getInput
+            , arg "-o", arg =<< getOutput ]
+
+getCFlags :: Expr [String]
+getCFlags = do
+    context <- getContext
+    autogen <- expr $ autogenPath context
+    mconcat [ remove ["-O"] (cArgs <> getStagedSettingList ConfCcArgs)
+            , getStagedSettingList ConfCppArgs
+            , cIncludeArgs
+            , getPkgDataList CppArgs
+            , getPkgDataList DepCcArgs
+            , cWarnings
+            , arg "-include", arg $ autogen -/- "cabal_macros.h" ]
+
+getLFlags :: Expr [String]
+getLFlags = do
+    libDirs   <- getPkgDataList DepLibDirs
+    extraLibs <- getPkgDataList DepExtraLibs
+    mconcat [ getStagedSettingList ConfGccLinkerArgs
+            , ldArgs
+            , getPkgDataList LdArgs
+            , pure [ "-L" ++ unifyPath dir | dir <- libDirs ]
+            , pure [ "-l" ++ unifyPath dir | dir <- extraLibs ]
+            , getPkgDataList DepLdArgs ]
diff --git a/src/Settings/Builders/Ld.hs b/src/Settings/Builders/Ld.hs
new file mode 100644 (file)
index 0000000..2715bbb
--- /dev/null
@@ -0,0 +1,9 @@
+module Settings.Builders.Ld (ldBuilderArgs) where
+
+import Settings.Builders.Common
+
+ldBuilderArgs :: Args
+ldBuilderArgs = builder Ld ? mconcat [ getStagedSettingList ConfLdLinkerArgs
+                                     , arg "-r"
+                                     , arg "-o", arg =<< getOutput
+                                     , getInputs ]
diff --git a/src/Settings/Builders/Make.hs b/src/Settings/Builders/Make.hs
new file mode 100644 (file)
index 0000000..cc350df
--- /dev/null
@@ -0,0 +1,16 @@
+module Settings.Builders.Make (makeBuilderArgs) where
+
+import Rules.Gmp
+import Rules.Libffi
+import Settings.Builders.Common
+
+makeBuilderArgs :: Args
+makeBuilderArgs = do
+    threads    <- shakeThreads <$> expr getShakeOptions
+    gmpPath    <- expr gmpBuildPath
+    libffiPath <- expr libffiBuildPath
+    let t = show $ max 4 (threads - 2) -- Don't use all Shake's threads
+    mconcat
+        [ builder (Make gmpPath          ) ? pure ["MAKEFLAGS=-j" ++ t]
+        , builder (Make libffiPath       ) ? pure ["MAKEFLAGS=-j" ++ t, "install"]
+        , builder (Make "testsuite/tests") ? pure ["THREADS=" ++ t, "fast"] ]
diff --git a/src/Settings/Builders/Xelatex.hs b/src/Settings/Builders/Xelatex.hs
new file mode 100644 (file)
index 0000000..5623284
--- /dev/null
@@ -0,0 +1,7 @@
+module Settings.Builders.Xelatex (xelatexBuilderArgs) where
+
+import Settings.Builders.Common
+
+xelatexBuilderArgs :: Args
+xelatexBuilderArgs = builder Xelatex ? mconcat [ arg "-halt-on-error"
+                                               , arg =<< getInput ]
diff --git a/src/Settings/Default.hs b/src/Settings/Default.hs
new file mode 100644 (file)
index 0000000..dc58f22
--- /dev/null
@@ -0,0 +1,173 @@
+module Settings.Default (
+    SourceArgs (..), sourceArgs, defaultBuilderArgs, defaultPackageArgs,
+    defaultArgs, defaultLibraryWays, defaultRtsWays,
+    defaultFlavour, defaultSplitObjects
+    ) where
+
+import qualified Hadrian.Builder.Ar
+import qualified Hadrian.Builder.Sphinx
+import qualified Hadrian.Builder.Tar
+
+import CommandLine
+import Expression
+import Flavour
+import Oracles.Flag
+import Oracles.PackageData
+import Settings
+import Settings.Builders.Alex
+import Settings.Builders.DeriveConstants
+import Settings.Builders.Cc
+import Settings.Builders.Configure
+import Settings.Builders.GenPrimopCode
+import Settings.Builders.Ghc
+import Settings.Builders.GhcCabal
+import Settings.Builders.GhcPkg
+import Settings.Builders.Haddock
+import Settings.Builders.Happy
+import Settings.Builders.Hsc2Hs
+import Settings.Builders.HsCpp
+import Settings.Builders.Ld
+import Settings.Builders.Make
+import Settings.Builders.Xelatex
+import Settings.Packages.Base
+import Settings.Packages.Cabal
+import Settings.Packages.Compiler
+import Settings.Packages.Ghc
+import Settings.Packages.GhcCabal
+import Settings.Packages.Ghci
+import Settings.Packages.GhcPkg
+import Settings.Packages.GhcPrim
+import Settings.Packages.Haddock
+import Settings.Packages.Haskeline
+import Settings.Packages.IntegerGmp
+import Settings.Packages.Rts
+import Settings.Packages.RunGhc
+import Settings.Warnings
+
+-- TODO: Move C source arguments here
+-- | Default and package-specific source arguments.
+data SourceArgs = SourceArgs
+    { hsDefault  :: Args
+    , hsLibrary  :: Args
+    , hsCompiler :: Args
+    , hsGhc      :: Args }
+
+-- | Concatenate source arguments in appropriate order.
+sourceArgs :: SourceArgs -> Args
+sourceArgs SourceArgs {..} = builder Ghc ? mconcat
+    [ hsDefault
+    , getPkgDataList HsArgs
+    , libraryPackage   ? hsLibrary
+    , package compiler ? hsCompiler
+    , package ghc      ? hsGhc ]
+
+-- | All default command line arguments.
+defaultArgs :: Args
+defaultArgs = mconcat
+    [ defaultBuilderArgs
+    , sourceArgs defaultSourceArgs
+    , defaultPackageArgs ]
+
+-- | Default source arguments, e.g. optimisation settings.
+defaultSourceArgs :: SourceArgs
+defaultSourceArgs = SourceArgs
+    { hsDefault  = mconcat [ stage0    ? arg "-O"
+                           , notStage0 ? arg "-O2"
+                           , arg "-H32m" ]
+    , hsLibrary  = mempty
+    , hsCompiler = mempty
+    , hsGhc      = mempty }
+
+-- | Default build ways for library packages:
+-- * We always build 'vanilla' way.
+-- * We build 'profiling' way when stage > Stage0.
+-- * We build 'dynamic' way when stage > Stage0 and the platform supports it.
+defaultLibraryWays :: Ways
+defaultLibraryWays = mconcat
+    [ pure [vanilla]
+    , notStage0 ? pure [profiling]
+    , notStage0 ? platformSupportsSharedLibs ? pure [dynamic] ]
+
+-- | Default build ways for the RTS.
+defaultRtsWays :: Ways
+defaultRtsWays = do
+    ways <- getLibraryWays
+    mconcat
+        [ pure [ logging, debug, threaded, threadedDebug, threadedLogging ]
+        , (profiling `elem` ways) ? pure [threadedProfiling]
+        , (dynamic `elem` ways) ?
+          pure [ dynamic, debugDynamic, threadedDynamic, threadedDebugDynamic
+                 , loggingDynamic, threadedLoggingDynamic ] ]
+
+-- Please update doc/flavours.md when changing the default build flavour.
+-- | Default build flavour. Other build flavours are defined in modules
+-- @Settings.Flavours.*@. Users can add new build flavours in "UserSettings".
+defaultFlavour :: Flavour
+defaultFlavour = Flavour
+    { name               = "default"
+    , args               = defaultArgs
+    , packages           = defaultPackages
+    , integerLibrary     = (\x -> if x then integerSimple else integerGmp) <$> cmdIntegerSimple
+    , libraryWays        = defaultLibraryWays
+    , rtsWays            = defaultRtsWays
+    , splitObjects       = defaultSplitObjects
+    , dynamicGhcPrograms = False
+    , ghciWithDebugger   = False
+    , ghcProfiled        = False
+    , ghcDebugged        = False }
+
+-- | Default condition for building split objects.
+defaultSplitObjects :: Predicate
+defaultSplitObjects = do
+    goodStage <- notStage0 -- We don't split bootstrap (stage 0) packages
+    pkg       <- getPackage
+    supported <- expr supportsSplitObjects
+    split     <- expr cmdSplitObjects
+    let goodPackage = isLibrary pkg && pkg /= compiler && pkg /= rts
+    return $ split && goodStage && goodPackage && supported
+
+-- | All 'Builder'-dependent command line arguments.
+defaultBuilderArgs :: Args
+defaultBuilderArgs = mconcat
+    -- GHC-specific builders:
+    [ alexBuilderArgs
+    , ccBuilderArgs
+    , configureBuilderArgs
+    , deriveConstantsBuilderArgs
+    , genPrimopCodeBuilderArgs
+    , ghcBuilderArgs
+    , ghcCabalBuilderArgs
+    , ghcPkgBuilderArgs
+    , haddockBuilderArgs
+    , happyBuilderArgs
+    , hsc2hsBuilderArgs
+    , hsCppBuilderArgs
+    , ldBuilderArgs
+    , makeBuilderArgs
+    , xelatexBuilderArgs
+    -- Generic builders from the Hadrian library:
+    , builder (Ar Pack     ) ? Hadrian.Builder.Ar.args Pack
+    , builder (Ar Unpack   ) ? Hadrian.Builder.Ar.args Unpack
+    , builder (Sphinx Html ) ? Hadrian.Builder.Sphinx.args Html
+    , builder (Sphinx Latex) ? Hadrian.Builder.Sphinx.args Latex
+    , builder (Sphinx Man  ) ? Hadrian.Builder.Sphinx.args Man
+    , builder (Tar Create  ) ? Hadrian.Builder.Tar.args Create
+    , builder (Tar Extract ) ? Hadrian.Builder.Tar.args Extract ]
+
+-- | All 'Package'-dependent command line arguments.
+defaultPackageArgs :: Args
+defaultPackageArgs = mconcat
+    [ basePackageArgs
+    , cabalPackageArgs
+    , compilerPackageArgs
+    , ghcCabalPackageArgs
+    , ghciPackageArgs
+    , ghcPackageArgs
+    , ghcPkgPackageArgs
+    , ghcPrimPackageArgs
+    , haddockPackageArgs
+    , haskelinePackageArgs
+    , integerGmpPackageArgs
+    , rtsPackageArgs
+    , runGhcPackageArgs