├── .circleci ├── config.yml └── test-packages.txt ├── .gitignore ├── .weeder.yaml ├── Readme.md ├── common-extensions.yaml ├── docker └── Dockerfile ├── docs ├── _config.yml └── index.md ├── example ├── example.cabal ├── exe │ └── Main.hs ├── pier.yaml └── src │ └── Lib.hs ├── pier-core ├── LICENSE ├── package.yaml └── src │ └── Pier │ └── Core │ ├── Artifact.hs │ ├── Download.hs │ ├── Internal │ ├── Directory.hs │ ├── HashableSet.hs │ └── Store.hs │ ├── Persistent.hs │ └── Run.hs ├── pier.yaml ├── pier ├── LICENSE ├── package.yaml └── src │ ├── Main.hs │ └── Pier │ ├── Build │ ├── CFlags.hs │ ├── Components.hs │ ├── Config.hs │ ├── ConfiguredPackage.hs │ ├── Custom.hs │ ├── Executable.hs │ ├── Module.hs │ ├── Package.hs │ ├── Stackage.hs │ └── TargetInfo.hs │ └── Orphans.hs ├── shell.nix ├── stack.yaml ├── stackage ├── build-stackage.sh ├── list-packages.hs └── pier.yaml └── test-package-config.yaml /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | 3 | references: 4 | build-base: &build-base 5 | docker: 6 | - image: judah/pier-ci:v3 7 | steps: 8 | - checkout 9 | - restore_cache: 10 | keys: 11 | - stack-cache-v5-{{ arch }}-{{ .Branch }} 12 | - stack-cache-v5-{{ arch }}-master 13 | - run: 14 | command: | 15 | echo 'export PATH=$HOME/.local/bin:$PATH' >> $BASH_ENV 16 | 17 | # Build with `stack` 18 | - run: stack --no-terminal install weeder hlint 19 | - run: stack --no-terminal build --only-dependencies --fast --no-terminal 20 | - run: stack --no-terminal build --pedantic --fast --no-terminal 21 | 22 | - run: hlint . 23 | - run: weeder . --build 24 | 25 | - save_cache: 26 | key: stack-cache-v5-{{ arch }}-{{ .Branch }}-{{ epoch }} 27 | paths: 28 | - ~/.stack 29 | - .stack-work 30 | 31 | # Run pier on some sample packages 32 | - run: 33 | command: | 34 | $(stack exec which pier) build -j4 \ 35 | --keep-going \ 36 | --pier-yaml=test-package-config.yaml \ 37 | $(cat .circleci/test-packages.txt) 38 | - run: $(stack exec which pier) build -j4 39 | - run: $(stack exec which pier) run -j4 hlint --sandbox $PWD/pier/src 40 | - run: $(stack exec which pier) run hlint pier/src 41 | - run: $(stack exec which pier) test split 42 | - run: $(stack exec which pier) test split:test:split-tests 43 | - run: 44 | command: | 45 | echo "system-ghc: true" >> example/pier.yaml 46 | - run: stack exec pier -- build --pier-yaml=example/pier.yaml text unix-compat 47 | # Test without the shared cache 48 | # TODO: add more extensive testing 49 | - run: 50 | command: | 51 | PIER="stack exec pier -- --pier-yaml=example/pier.yaml" 52 | $PIER clean-all 53 | $PIER build --no-shared-cache network split 54 | 55 | jobs: 56 | build: 57 | <<: *build-base 58 | 59 | workflows: 60 | version: 2 61 | build-and-test: 62 | jobs: 63 | - build 64 | -------------------------------------------------------------------------------- /.circleci/test-packages.txt: -------------------------------------------------------------------------------- 1 | X11-xft 2 | c2hs 3 | direct-sqlite 4 | elm-core-sources 5 | hscolour 6 | hsndfile 7 | hsx2hs 8 | lens 9 | network-multicast 10 | pandoc 11 | publicsuffix 12 | tzdata 13 | unix-time 14 | wreq 15 | xhtml 16 | yaml 17 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *.cabal 3 | _pier/ 4 | stackage/packages.txt 5 | stackage/pier.yaml 6 | -------------------------------------------------------------------------------- /.weeder.yaml: -------------------------------------------------------------------------------- 1 | - package: 2 | - name: pier-core 3 | - section: 4 | - name: library 5 | - message: 6 | - name: Weeds exported 7 | - module: 8 | - name: Pier.Core.Internal.Directory 9 | - identifier: SymbolicLink 10 | 11 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | # Pier: Yet another Haskell build system. 2 | 3 | Pier is a command-line tool for building Haskell projects. (Yes, 4 | [another one](https://xkcd.com/927).) 5 | 6 | Pier is similar in purpose to [Stack](https://www.haskellstack.org); it 7 | uses `*.cabal` files for package configuration, and uses Stackage for 8 | consistent sets of package dependencies. However, Pier attempts to 9 | address some of Stack's limitations by exploring a different approach: 10 | 11 | - Pier invokes tools such as `ghc` directly, implementing the fine-grained 12 | Haskell build logic from (nearly) scratch. In contrast, Stack relies on a 13 | separate framework to implement most of its build steps (i.e., 14 | `Cabal`/`Distribution.Simple`), giving it mostly coarse control over the build. 15 | - Pier layers its Haskell-specific logic on top of a general-purpose 16 | library for hermetic, parallel builds and dependency tracking. That library 17 | is itself implemented using [Shake](http://shakebuild.com), and motivated by 18 | tools such as [Nix](https://nixos.org/nix) and [Bazel](https://bazel.build). 19 | In contrast, Stack's build and dependency logic is more specific to 20 | Haskell projects. 21 | 22 | (Interestingly, Stack originally did depend on Shake. The project stopped using it 23 | early on, in part due to added complexity from the extra layer of Cabal build 24 | logic. For more information, see write-ups by authors of 25 | [Stack](https://groups.google.com/d/msg/haskell-stack/icN7M0tJgxw/obPPZUVeAgAJ) 26 | and 27 | [Shake](http://neilmitchell.blogspot.com/2016/07/why-did-stack-stop-using-shake.html).) 28 | 29 | For examples of project configuration, see the [sample](example/pier.yaml) 30 | project, or alternately [pier itself](pier.yaml). 31 | 32 | ## Status 33 | Pier is still experimental. It has been tested on small projects, but not yet used in anger. 34 | 35 | Pier is already able to build most the packages in Stackage (specifically, 93% of 36 | the more than 2300 packages in `lts-12.8`). There is a 37 | [list of open issues](https://github.com/judah/pier/issues?q=is%3Aissue+is%3Aopen+label%3A%22Build+All+The+Packages%22) 38 | to increase Pier's coverage. (Notably, packages with [Custom Setup.hs scripts](https://github.com/judah/pier/issues/22) 39 | are not supported.) 40 | 41 | ## Contents 42 | 43 | - [Installation](#installation) 44 | - [Project Configuration](#project-configuration) 45 | - [Using pier](#using-pier) 46 | - [Build Outputs](#build-outputs) 47 | - [Frequently Asked Questions](#frequently-asked-questions) 48 | 49 | # Installation 50 | First clone this repository, and then build and install the `pier` executable using `stack` (version 1.6 or newer): 51 | 52 | ``` 53 | git clone https://github.com/judah/pier.git 54 | cd pier 55 | stack install 56 | ``` 57 | 58 | Add `~/.local/bin` to your `$PATH` in order to start using `pier`. For example, try: 59 | 60 | ``` 61 | cd example 62 | pier build 63 | ``` 64 | 65 | # Project Configuration 66 | A `pier.yaml` file specifies the configuration of a project. For example: 67 | 68 | ``` 69 | resolver: lts-10.3 70 | packages: 71 | - '.' 72 | - 'foo' 73 | - 'path/to/bar' 74 | ``` 75 | 76 | ### resolver 77 | The `resolver` specifies a set of package versions (as well as a version of GHC), using [Stackage](https://stackage.org). It can be either an LTS or nightly version. For example: 78 | 79 | ``` 80 | resolver: lts-10.3 81 | ``` 82 | ``` 83 | resolver: nightly-2018-02-10 84 | ``` 85 | 86 | ### packages 87 | The `packages` section lists paths to local directories containing Cabal packages (i.e., `*.cabal` and associated source files). For example: 88 | 89 | ``` 90 | packages: 91 | - '.' 92 | - 'foo' 93 | - 'path/to/bar' 94 | ``` 95 | 96 | ### extra-deps 97 | An `extra-deps` section may be used to add new versions of packages from Hackage that are not in the `resolver`, or to override existing versions. For example: 98 | 99 | ``` 100 | extra-deps: 101 | - text-1.2.3.4 102 | - shake-0.15 103 | ``` 104 | 105 | ### system-ghc 106 | By default, pier downloads and installs its own, local copy of GHC from 107 | `github.com/stackage`. To override this behavior and use a GHC that's already 108 | installed on the system, set: 109 | 110 | ``` 111 | system-ghc: true 112 | ``` 113 | 114 | This setting will make `pier` look in the `$PATH` 115 | for a binary named `ghc-VERSION`, where `VERSION` is the version specified in the 116 | resolver (for example: `ghc-8.2.2`). 117 | 118 | ### ghc-options 119 | A list of command-line flags to pass to GHC when compiling packages. For example: 120 | ``` 121 | ghc-options: [-O2, -Wall] 122 | ``` 123 | or: 124 | ``` 125 | ghc-options: 126 | - -O2 127 | - -Wall 128 | ``` 129 | 130 | # Using `pier` 131 | 132 | For general comnmand-line usage, pass the `--help` flag: 133 | 134 | ``` 135 | pier --help 136 | pier build --help 137 | pier run --help 138 | # etc. 139 | ``` 140 | ## Common Options 141 | 142 | | Option | Result | Default | 143 | | --- | --- | --- | 144 | | `--pier-yaml={PATH}` | Use that file for build configuration | `pier.yaml` | 145 | | `--jobs={N}`, `-j{N}` | Run with at most this much parallelism | The number of detected CPUs | 146 | | `-V` | Increase the verbosity level. [Details](#verbosity) | | 147 | | `--shake-arg={ARG}` | Pass the argument directly to Shake | | 148 | | `--keep-going` | Keep going if there are errors | False; stop after the first error | 149 | | `--keep-temps` | Preserve temporary directories | False | 150 | | `--shared-cache-path` | Location of the shared cache | `$HOME/.pier/artifact` | 151 | | `--no-shared-cache` | Don't save build outputs to the the shared cache | False | 152 | 153 | ### `pier build` 154 | 155 | `pier build {TARGETS}` builds one or more Haskell libraries and/or binaries from the project, as well as their dependencies. There are a few different ways to specify the targets: 156 | 157 | | Command | Targets | 158 | | --- | --- | 159 | | `pier build` | All the libraries and executables for every entry in `packages`. | 160 | | `pier build {PACKAGE}` | The library and executables (if any) for the given package.
For example: `text` or `pier`. `{PACKAGE}` can be a local package,
one from the LTS, or one specified in `extra-deps`. | 161 | | `pier build {PACKAGE}:lib` | The library for the given package. | 162 | | `pier build {PACKAGE}:exe` | The executables for the given package, but not the library
(unless it is a dependency of one of them). | 163 | | `pier build {PACKAGE}:exe:{NAME}` | A specific executable in the given package. | 164 | 165 | ### `pier run` 166 | `pier run {TARGET} {ARGUMENTS}` builds the given executable target, and then runs it with the given command-line arguments. `{TARGET}` should be a specific executable; either: 167 | 168 | | Command | Result | 169 | | --- | --- | 170 | | `pier run {PACKAGE}:exe:{NAME}` | A specific executable from the given package. | 171 | | `pier run {PACKAGE}:test:{NAME}` | A specific test-suite from the given package. | 172 | | `pier run {NAME}` | Equivalent to `pier run {NAME}:exe:{NAME}`;
an executable from a package of the same name. | 173 | 174 | For example, `pier run foo` is equivalent to `pier run foo:exe:foo`. Note that 175 | this behavior differs from Stack, which is less explicit: `stack exec foo` may 176 | run a binary named `foo` from *any* previously built package. 177 | 178 | By default, the executable will run in the same directory where `pier.yaml` is located. To run in a temporary, hermetic directory, use `pier run --sandbox`. 179 | 180 | In case of ambiguity, `--` can be used to separate arguments of `pier` from arguments of the target. 181 | 182 | ### `pier test` 183 | `pier test {TARGETS}` builds and tests one or more Cabal `test-suites` from the project and/or its dependencies. There are a few different ways to specify the targets: 184 | 185 | | Command | Targets | 186 | | --- | --- | 187 | | `pier test` | All the test-suites for every entry in `packages`. | 188 | | `pier test {PACKAGE}` | All the test-suites for a specific package.
For example: `text` or `pier`. `{PACKAGE}` can be a local package,
one from the LTS, or one specified in `extra-deps`. | 189 | | `pier test {PACKAGE}:test:{NAME}` | A specific test-suite in the given package. | 190 | 191 | ### `pier which` 192 | `pier which {TARGET}` builds the given executable target and then prints its location. See the documentation of `pier run` for details on the syntax of `{TARGET}`. 193 | 194 | ### `pier clean` 195 | `pier clean` marks some metadata in the Shake database as "dirty", so that it will be recreated on the next build. This command may be required if you build a new version of `pier`, but should be unnecessary otherwise. 196 | 197 | ### `pier clean-all` 198 | `pier clean-all` completely deletes all build outputs (other than downloaded 199 | files, as described [here](#build-outputs)), so that future builds will start 200 | from scratch. Note that this command will require Pier to reinstall a local 201 | copy of GHC unless `system-ghc: true` is set. 202 | 203 | ### `pier setup` 204 | `pier setup` downloads and configures the base build prerequisites. This includes: 205 | - Downloading and preparing a local installation of GHC 206 | - Downloading and parsing the Stackage build plan 207 | - Parsing the local `pier.yaml` and `*.cabal` files. 208 | 209 | In general, it should not be necessary to run `pier setup` explicitly, since those 210 | steps are also performed automatically for other commands like `build`, `run` and `test`. 211 | 212 | ### Verbosity 213 | The `-V` command-line flag will make Pier more verbose. It may be chained to increase verbosity (for example: `-VV`, `-V -V`, `-VVV`). 214 | 215 | The verbose output includes (but is not necessarily limited to): 216 | 217 | - `-V`: Upon failure of an invocation of a command-line process (for example, 218 | `ghc`), display the full invocation of that command including all command-line 219 | flags and build inputs. 220 | - `-VV`: Display the full invocation of every command before running it. 221 | - `-VVV`: Also display internal Shake debug information. 222 | 223 | 224 | # Build Outputs 225 | 226 | `pier` saves most output files in a folder called `_pier/`, located in the 227 | same directory as `pier.yaml`. The only exception is downloaded files (for 228 | example, package tarballs for dependencies), which are saved under 229 | `$HOME/.pier` so that they may be reused between different projects on the same 230 | machine. 231 | 232 | Each build command (for example, a single invocation of `ghc` or 233 | `ghc-pkg`) runs separately in a temporary directory with a limited, explicit 234 | set of input files. This approach is inspired by the `Bazel` project, which 235 | sandboxes each command in order to get reliable, deterministic builds. 236 | Note though that Pier does not currently provide the same strict guarantees 237 | as Bazel. Instead, it uses file organization and marking outputs as 238 | read-only to catch a subset of potential bugs in the build logic. 239 | 240 | The outputs of each command are saved into a distinct directory of the form: 241 | 242 | `_pier/artifact/{HASH}` 243 | 244 | where the `{HASH}` is a unique string depending on the command's command-line 245 | arguments and input dependencies. This file organization is similar to Nix, 246 | though Pier aims for much more fine-grained build steps than a standard Nix 247 | package. 248 | 249 | Build outputs are also mirrored into a shared cache, located by default at `~/.pier/artifact/{HASH}`. 250 | Files are hard-linked between there and the local `_pier`. This enables 251 | sharing work between multiple projects. To disable this behavior, use the 252 | command-line flag `--no-shared-cache`. To change the location, use `--shared-cache-path`, or set the `PIER_SHARED_CACHE` environmental variable. 253 | 254 | If necessary, `pier clean-all` will delete the `_pier` folder (and thus wipe out the entire build). That folder can also be deleted manually with `chmod -R u+w _pier && rm -rf _pier`. (Files and folders in `_pier` are marked as read-only.) 255 | 256 | # Frequently Asked Questions 257 | 258 | ### How much of Cabal/Stack does this project re-use? 259 | 260 | `pier` implements nearly all build logic itself, including: configuration, dependency tracking, and invocation of command-line programs such as `ghc` and `ghc-pkg`. It uses Cabal/Hackage/Stackage in the follow ways: 261 | 262 | - Downloads Stackage's build plans from `github.com/fpco`, and uses them to get the version numbers for the packages in that plan and for GHC. 263 | - Downloads GHC releases from `github.com/commercialhaskell`, getting the exact download location from a file hosted by `github.com/stackage`. 264 | - Downloads individual Haskell packages directly from Hackage. 265 | - Uses the `Cabal` library to parse the `.cabal` file format for each package. 266 | 267 | In particular, it does not: 268 | 269 | - Call the `stack` executable or depend on the `stack` library 270 | - Call the `cabal` binary 271 | - Import `Distribution.Simple{.*}` from the `Cabal` library 272 | 273 | 274 | ### I heard you like `pier`, so I built `pier` with `pier`. 275 | Building `pier` with `pier` is OK, I guess: 276 | 277 | pier build pier 278 | 279 | But what about using *that* `pier` to build `pier`? We'll just need to 280 | distinguish Shake's metadata between the two invocations: 281 | 282 | $ pier -- run pier build pier \ 283 | --shake-arg=--metadata=temp-metadata 284 | Build completed in 0:10m 285 | 286 | Build completed in 0:10m 287 | 288 | The inner run of `pier build` only takes about 10 seconds on my laptop, because it reuses all of the build outputs that 289 | were created by the outer call to `pier` (and were stored under `_pier/artifacts`). It spends its time parsing 290 | package metadata, computing dependencies, and (re)creating all the build 291 | commands in the dependency tree. 292 | -------------------------------------------------------------------------------- /common-extensions.yaml: -------------------------------------------------------------------------------- 1 | - BangPatterns 2 | - DeriveGeneric 3 | - FlexibleContexts 4 | - LambdaCase 5 | - MultiWayIf 6 | - NondecreasingIndentation 7 | - ScopedTypeVariables 8 | - StandaloneDeriving 9 | - TupleSections 10 | - TypeFamilies 11 | - TypeSynonymInstances 12 | -------------------------------------------------------------------------------- /docker/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ubuntu:16.04 2 | 3 | RUN \ 4 | apt-get update && \ 5 | apt-get -y install \ 6 | curl \ 7 | libgmp3-dev \ 8 | libsndfile1-dev \ 9 | libxft-dev \ 10 | libxrandr-dev \ 11 | libxss-dev \ 12 | locales && \ 13 | locale-gen en_US.UTF-8 14 | 15 | RUN curl -L https://github.com/commercialhaskell/stack/releases/download/v1.7.1/stack-1.7.1-linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C /usr/local/bin '*/stack' 16 | -------------------------------------------------------------------------------- /docs/_config.yml: -------------------------------------------------------------------------------- 1 | theme: jekyll-theme-slate -------------------------------------------------------------------------------- /docs/index.md: -------------------------------------------------------------------------------- 1 | Test page for documentation 2 | -------------------------------------------------------------------------------- /example/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >= 1.10 5 | 6 | library 7 | hs-source-dirs: src 8 | exposed-modules: Lib 9 | build-depends: base, text 10 | default-language: Haskell2010 11 | 12 | executable example-exe 13 | hs-source-dirs: exe 14 | main-is: Main.hs 15 | build-depends: base, text, example 16 | default-language: Haskell2010 17 | -------------------------------------------------------------------------------- /example/exe/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import qualified Data.Text.IO as T 4 | 5 | import Lib 6 | 7 | main :: IO () 8 | main = T.putStrLn message 9 | -------------------------------------------------------------------------------- /example/pier.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.8 2 | 3 | packages: 4 | - '.' 5 | 6 | ghc-options: [-Wall] 7 | -------------------------------------------------------------------------------- /example/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib (message) where 2 | 3 | import Data.Text (Text, pack) 4 | 5 | message :: Text 6 | message = pack "Hello, world!" 7 | -------------------------------------------------------------------------------- /pier-core/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Judah Jacobson 2017. 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | 9 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 10 | 11 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 12 | 13 | 14 | -------------------------------------------------------------------------------- /pier-core/package.yaml: -------------------------------------------------------------------------------- 1 | name: pier-core 2 | version: 0.3.0.0 3 | license: BSD3 4 | maintainer: judah.jacobson@gmail.com 5 | synopsis: A library for writing forwards-declared build systems in haskell. 6 | description: | 7 | A library for writing build systems in Haskell, built on top of 8 | . 9 | 10 | Pier provides a generic approach to building and caching file outputs. 11 | It enables build actions to be written in a "forwards" style, which 12 | generally leads to simpler logic than backwards-defined build systems 13 | such as make or (normal) Shake, where each step of the build logic must 14 | be written as a new build rule. 15 | 16 | For more details of the API, start with "Pier.Core.Artifact". 17 | 18 | See for information 19 | on the Haskell build tool that uses this package. 20 | 21 | category: Development 22 | github: judah/pier 23 | 24 | library: 25 | source-dirs: 'src' 26 | dependencies: 27 | - base == 4.11.* 28 | - base64-bytestring == 1.0.* 29 | - binary == 0.8.* 30 | - bytestring == 0.10.* 31 | - containers == 0.5.* 32 | - cryptohash-sha256 == 0.11.* 33 | - directory >= 1.3.1 && < 1.4 34 | - hashable == 1.2.* 35 | - http-client == 0.5.* 36 | - http-client-tls == 0.3.* 37 | - http-types == 0.12.* 38 | - process == 1.6.* 39 | - shake >= 0.16.4 && < 0.17 40 | - temporary == 1.3.* 41 | - text == 1.2.* 42 | - unix == 2.7.* 43 | other-modules: 44 | - Pier.Core.Internal.Directory 45 | - Pier.Core.Internal.HashableSet 46 | - Pier.Core.Internal.Store 47 | default-extensions: !include ../common-extensions.yaml 48 | -------------------------------------------------------------------------------- /pier-core/src/Pier/Core/Artifact.hs: -------------------------------------------------------------------------------- 1 | {- | A generic approach to building and caching file outputs. 2 | 3 | This is a layer on top of Shake which enables build actions to be written in a 4 | "forwards" style. For example: 5 | 6 | > runPier $ action $ do 7 | > contents <- lines <$> readArtifactA (external "result.txt") 8 | > let result = "result.tar" 9 | > runCommandOutput result 10 | > $ foldMap input contents 11 | > <> prog "tar" (["-cf", result] ++ map pathIn contents) 12 | 13 | This approach generally leads to simpler logic than backwards-defined build systems such as 14 | make or (normal) Shake, where each step of the build logic must be written as a 15 | new build rule. 16 | 17 | Inputs and outputs of a command must be declared up-front, using the 'input' 18 | and 'output' functions respectively. This enables isolated, deterministic 19 | build steps which are each run in their own temporary directory. 20 | 21 | Output files are stored in the location 22 | 23 | > _pier/artifact/HASH/path/to/file 24 | 25 | where @HASH@ is a string that uniquely determines the action generating 26 | that file. In particular, there is no need to worry about choosing distinct names 27 | for outputs of different commands. 28 | 29 | Note that 'Development.Shake.Forward' has similar motivation to this module, 30 | but instead uses @fsatrace@ to detect what files changed after the fact. 31 | Unfortunately, that approach is not portable. Additionally, it makes it 32 | difficult to isolate steps and make the build more reproducible (for example, 33 | to prevent the output of one step being mutated by a later one) since every 34 | output file could potentially be an input to every action. Finally, by 35 | explicitly declaring outputs we can detect sooner when a command doesn't 36 | produce the files that we expect. 37 | 38 | -} 39 | {-# LANGUAGE DeriveAnyClass #-} 40 | {-# LANGUAGE TypeOperators #-} 41 | module Pier.Core.Artifact 42 | ( -- * Rules 43 | artifactRules 44 | , SharedCache(..) 45 | , HandleTemps(..) 46 | -- * Artifact 47 | , Artifact 48 | , external 49 | , (/>) 50 | , replaceArtifactExtension 51 | , readArtifact 52 | , readArtifactB 53 | , doesArtifactExist 54 | , matchArtifactGlob 55 | , unfreezeArtifacts 56 | , callArtifact 57 | -- * Creating artifacts 58 | , writeArtifact 59 | , runCommand 60 | , runCommandOutput 61 | , runCommand_ 62 | , runCommandStdout 63 | , Command 64 | , message 65 | -- ** Command outputs 66 | , Output 67 | , output 68 | -- ** Command inputs 69 | , input 70 | , inputs 71 | , inputList 72 | , shadow 73 | , groupFiles 74 | -- * Running commands 75 | , prog 76 | , progA 77 | , progTemp 78 | , pathIn 79 | , withCwd 80 | , createDirectoryA 81 | ) where 82 | 83 | import Control.Monad (forM_, when, unless) 84 | import Control.Monad.IO.Class 85 | import Data.Set (Set) 86 | import Development.Shake 87 | import Development.Shake.Classes 88 | import Development.Shake.FilePath 89 | import GHC.Generics 90 | import System.Directory as Directory 91 | import System.Exit (ExitCode(..)) 92 | import System.Process.Internals (translate) 93 | 94 | import qualified Data.ByteString as B 95 | import qualified Data.ByteString.Char8 as BC 96 | import qualified Data.List as List 97 | import qualified Data.Map.Strict as Map 98 | import qualified Data.Set as Set 99 | import qualified Data.Text as T 100 | import qualified Data.Text.Encoding as T 101 | import qualified Data.Text.Encoding.Error as T hiding (replace) 102 | 103 | import Pier.Core.Internal.Directory 104 | import Pier.Core.Internal.HashableSet 105 | import Pier.Core.Internal.Store 106 | import Pier.Core.Persistent 107 | 108 | -- | A hermetic build step. Consists of a sequence of calls to 'message', 109 | -- 'prog'/'progA'/'progTemp', and/or 'shadow', which may be combined using '<>'/'mappend'. 110 | -- Also specifies the input 'Artifacts' that are used by those commands. 111 | data Command = Command 112 | { _commandProgs :: [Prog] 113 | , commandInputs :: HashableSet Artifact 114 | } 115 | deriving (Typeable, Eq, Generic, Hashable, Binary, NFData) 116 | 117 | data Call 118 | = CallEnv String -- picked up from $PATH 119 | | CallArtifact Artifact 120 | | CallTemp FilePath -- Local file to this Command 121 | -- (e.g. generated by an earlier call) 122 | -- (This is a hack around shake which tries to resolve 123 | -- local files in the env.) 124 | deriving (Typeable, Eq, Generic, Hashable, Binary, NFData) 125 | 126 | data Prog 127 | = ProgCall { _progCall :: Call 128 | , _progArgs :: [String] 129 | , progCwd :: FilePath -- relative to the root of the sandbox 130 | } 131 | | Message String 132 | | Shadow Artifact FilePath 133 | deriving (Typeable, Eq, Generic, Hashable, Binary, NFData) 134 | 135 | instance Monoid Command where 136 | Command ps is `mappend` Command ps' is' = Command (ps ++ ps') (is <> is') 137 | mempty = Command [] mempty 138 | 139 | instance Semigroup Command where 140 | (<>) = mappend 141 | 142 | -- | Run an external command-line program with the given arguments. 143 | prog :: String -> [String] -> Command 144 | prog p as = Command [ProgCall (CallEnv p) as "."] mempty 145 | 146 | -- | Run an artifact as an command-line program with the given arguments. 147 | progA :: Artifact -> [String] -> Command 148 | progA p as = Command [ProgCall (CallArtifact p) as "."] 149 | $ HashableSet $ Set.singleton p 150 | 151 | -- | Run a command-line program with the given arguments, where the program 152 | -- was created by a previous program. 153 | progTemp :: FilePath -> [String] -> Command 154 | progTemp p as = Command [ProgCall (CallTemp p) as "."] mempty 155 | 156 | -- | Prints a status message for the user when this command runs. 157 | message :: String -> Command 158 | message s = Command [Message s] mempty 159 | 160 | -- | Runs a command within the given (relative) directory. 161 | withCwd :: FilePath -> Command -> Command 162 | withCwd path (Command ps as) 163 | | isAbsolute path = error $ "withCwd: expected relative path, got " ++ show path 164 | | otherwise = Command (map setPath ps) as 165 | where 166 | setPath m@Message{} = m 167 | setPath p = p { progCwd = path } 168 | 169 | -- | Specify that an 'Artifact' should be made available to program calls within this 170 | -- 'Command'. 171 | -- 172 | -- Note that the order does not matter; `input f <> cmd === cmd <> input f`. 173 | input :: Artifact -> Command 174 | input = inputs . Set.singleton 175 | 176 | inputList :: [Artifact] -> Command 177 | inputList = inputs . Set.fromList 178 | 179 | -- | Specify that a set of 'Artifact's should be made available to program calls within this 180 | -- 'Command'. 181 | inputs :: Set Artifact -> Command 182 | inputs = Command [] . HashableSet 183 | 184 | -- | Make a "shadow" copy of the given input artifact's by create a symlink of 185 | -- this artifact (if it is a file) or of each sub-file (transitively, if it is 186 | -- a directory). 187 | -- 188 | -- The result may be captured as output, for example when grouping multiple outputs 189 | -- of separate commands into a common directory structure. 190 | shadow :: Artifact -> FilePath -> Command 191 | shadow a f 192 | | isAbsolute f = error $ "shadowArtifact: need relative destination, found " 193 | ++ show f 194 | | otherwise = Command [Shadow a f] mempty 195 | 196 | -- | The output of a given command. 197 | -- 198 | -- Multiple outputs may be combined using the 'Applicative' instance. 199 | data Output a = Output [FilePath] (Hash -> a) 200 | 201 | instance Functor Output where 202 | fmap f (Output g h) = Output g (f . h) 203 | 204 | instance Applicative Output where 205 | pure = Output [] . const 206 | Output f g <*> Output f' g' = Output (f ++ f') (g <*> g') 207 | 208 | -- | Register a single output of a command. 209 | -- 210 | -- The input must be a relative path and nontrivial (i.e., not @"."@ or @""@). 211 | output :: FilePath -> Output Artifact 212 | output f 213 | | ds `elem` [[], ["."]] = error $ "can't output empty path " ++ show f 214 | | ".." `elem` ds = error $ "output: can't have \"..\" as a path component: " 215 | ++ show f 216 | | normalise f == "." = error $ "Can't output empty path " ++ show f 217 | | isAbsolute f = error $ "Can't output absolute path " ++ show f 218 | | otherwise = Output [f] $ flip builtArtifact f 219 | where 220 | ds = splitDirectories f 221 | 222 | externalArtifactDir :: FilePath 223 | externalArtifactDir = artifactDir "external" 224 | 225 | artifactRules :: Maybe SharedCache -> HandleTemps -> Rules () 226 | artifactRules cache ht = do 227 | liftIO createExternalLink 228 | commandRules cache ht 229 | writeArtifactRules cache 230 | storeRules 231 | 232 | createExternalLink :: IO () 233 | createExternalLink = do 234 | exists <- doesPathExist externalArtifactDir 235 | unless exists $ do 236 | createParentIfMissing externalArtifactDir 237 | createDirectoryLink "../.." externalArtifactDir 238 | 239 | -- | The build rule type for commands. 240 | data CommandQ = CommandQ 241 | { commandQCmd :: Command 242 | , _commandQOutputs :: [FilePath] 243 | } 244 | deriving (Eq, Generic) 245 | 246 | instance Show CommandQ where 247 | show CommandQ { commandQCmd = Command progs _ } 248 | = let msgs = List.intercalate "; " [m | Message m <- progs] 249 | in "Command" ++ 250 | if null msgs 251 | then "" 252 | else ": " ++ msgs 253 | 254 | instance Hashable CommandQ 255 | instance Binary CommandQ 256 | instance NFData CommandQ 257 | 258 | type instance RuleResult CommandQ = Hash 259 | 260 | -- TODO: sanity-check filepaths; for example, normalize, should be relative, no 261 | -- "..", etc. 262 | commandHash :: CommandQ -> Action Hash 263 | commandHash cmdQ = do 264 | let externalFiles = [f | Artifact External f <- Set.toList 265 | . unHashableSet 266 | . commandInputs 267 | $ commandQCmd cmdQ 268 | , isRelative f 269 | ] 270 | need externalFiles 271 | -- TODO: streaming hash 272 | userFileHashes <- liftIO $ mapM hashExternalFile externalFiles 273 | makeHash ("commandHash", cmdQ, userFileHashes) 274 | 275 | -- | Run the given command, capturing the specified outputs. 276 | runCommand :: Output t -> Command -> Action t 277 | runCommand (Output outs mk) c 278 | = mk <$> askPersistent (CommandQ c outs) 279 | 280 | runCommandOutput :: FilePath -> Command -> Action Artifact 281 | runCommandOutput f = runCommand (output f) 282 | 283 | -- Run the given command and record its stdout. 284 | runCommandStdout :: Command -> Action String 285 | runCommandStdout c = do 286 | out <- runCommandOutput stdoutOutput c 287 | liftIO $ readFile $ pathIn out 288 | 289 | -- | Run the given command without capturing its output. Can be used to check 290 | -- consistency of the outputs of previous commands. 291 | runCommand_ :: Command -> Action () 292 | runCommand_ = runCommand (pure ()) 293 | 294 | commandRules :: Maybe SharedCache -> HandleTemps -> Rules () 295 | commandRules sharedCache ht = addPersistent $ \cmdQ@(CommandQ (Command progs inps) outs) -> do 296 | putChatty $ showCommand cmdQ 297 | h <- commandHash cmdQ 298 | createArtifacts sharedCache h (progMessages progs) $ \resultDir -> 299 | -- Run the command within a separate temporary directory. 300 | -- When it's done, we'll move the explicit set of outputs into 301 | -- the result location. 302 | withPierTempDirectoryAction ht (hashString h) $ \tmpDir -> do 303 | let tmpPathOut = (tmpDir ) 304 | 305 | liftIO $ collectInputs (unHashableSet inps) tmpDir 306 | mapM_ (createParentIfMissing . tmpPathOut) outs 307 | 308 | -- Run the command, and write its stdout to a special file. 309 | root <- liftIO getCurrentDirectory 310 | stdoutStr <- B.concat <$> mapM (readProg (root tmpDir)) progs 311 | 312 | let stdoutPath = tmpPathOut stdoutOutput 313 | createParentIfMissing stdoutPath 314 | liftIO $ B.writeFile stdoutPath stdoutStr 315 | 316 | -- Check that all the output files exist, and move them 317 | -- into the output directory. 318 | liftIO $ forM_ outs $ \f -> do 319 | let src = tmpPathOut f 320 | let dest = resultDir f 321 | exist <- Directory.doesPathExist src 322 | unless exist $ 323 | error $ "runCommand: missing output " 324 | ++ show f 325 | ++ " in temporary directory " 326 | ++ show tmpDir 327 | createParentIfMissing dest 328 | renamePath src dest 329 | return h 330 | 331 | putChatty :: String -> Action () 332 | putChatty s = do 333 | v <- shakeVerbosity <$> getShakeOptions 334 | when (v >= Chatty) $ putNormal s 335 | 336 | progMessages :: [Prog] -> [String] 337 | progMessages ps = [m | Message m <- ps] 338 | 339 | -- TODO: more hermetic? 340 | collectInputs :: Set Artifact -> FilePath -> IO () 341 | collectInputs inps tmp = do 342 | let inps' = dedupArtifacts inps 343 | checkAllDistinctPaths inps' 344 | liftIO $ mapM_ (linkArtifact tmp) inps' 345 | 346 | -- Call a process inside the given directory and capture its stdout. 347 | -- TODO: more flexibility around the env vars 348 | -- Also: limit valid parameters for the *prog* binary (rather than taking it 349 | -- from the PATH that the `pier` executable sees). 350 | readProg :: FilePath -> Prog -> Action B.ByteString 351 | readProg _ (Message s) = do 352 | putNormal s 353 | return B.empty 354 | readProg dir (ProgCall p as cwd) = readProgCall dir p as cwd 355 | readProg dir (Shadow a0 f0) = do 356 | liftIO $ linkShadow dir a0 f0 357 | return B.empty 358 | 359 | readProgCall :: FilePath -> Call -> [String] -> FilePath -> Action BC.ByteString 360 | readProgCall dir p as cwd = do 361 | -- hack around shake weirdness w.r.t. relative binary paths 362 | let p' = case p of 363 | CallEnv s -> s 364 | CallArtifact f -> dir pathIn f 365 | CallTemp f -> dir f 366 | (ret, Stdout out, Stderr err) 367 | <- quietly $ command 368 | [ Cwd $ dir cwd 369 | , Env defaultEnv 370 | -- stderr will get printed if there's an error. 371 | , EchoStderr False 372 | ] 373 | p' (map (spliceTempDir dir) as) 374 | let errStr = T.unpack . T.decodeUtf8With T.lenientDecode $ err 375 | case ret of 376 | ExitSuccess -> return out 377 | ExitFailure ec -> do 378 | v <- shakeVerbosity <$> getShakeOptions 379 | fail $ if v < Loud 380 | -- TODO: remove trailing newline 381 | then errStr 382 | else unlines 383 | [ showProg (ProgCall p as cwd) 384 | , "Working dir: " ++ translate (dir cwd) 385 | , "Exit code: " ++ show ec 386 | , "Stderr:" 387 | , errStr 388 | ] 389 | 390 | -- TODO: use forFileRecursive_ 391 | linkShadow :: FilePath -> Artifact -> FilePath -> IO () 392 | linkShadow dir a0 f0 = do 393 | createParentIfMissing (dir f0) 394 | loop a0 f0 395 | where 396 | loop a f = do 397 | let aPath = pathIn a 398 | isDir <- Directory.doesDirectoryExist aPath 399 | if isDir 400 | then do 401 | Directory.createDirectoryIfMissing False (dir f) 402 | cs <- getRegularContents aPath 403 | mapM_ (\c -> loop (a /> c) (f c)) cs 404 | else do 405 | srcExists <- Directory.doesFileExist aPath 406 | destExists <- Directory.doesPathExist (dir f) 407 | let aPath' = case a of 408 | Artifact External aa -> "external" aa 409 | Artifact (Built h) aa -> hashString h aa 410 | if 411 | | not srcExists -> error $ "linkShadow: missing source " 412 | ++ show aPath 413 | | destExists -> error $ "linkShadow: destination already exists: " 414 | ++ show f 415 | | otherwise -> createFileLink 416 | (relPathUp f "../../artifact" aPath') 417 | (dir f) 418 | relPathUp = joinPath . map (const "..") . splitDirectories . parentDirectory 419 | 420 | showProg :: Prog -> String 421 | showProg (Shadow a f) = unwords ["Shadow:", pathIn a, "=>", f] 422 | showProg (Message m) = "Message: " ++ show m 423 | showProg (ProgCall call args cwd) = 424 | wrapCwd 425 | . List.intercalate " \\\n " 426 | $ showCall call : args 427 | where 428 | wrapCwd s = case cwd of 429 | "." -> s 430 | _ -> "(cd " ++ translate cwd ++ " &&\n " ++ s ++ ")" 431 | 432 | showCall (CallArtifact a) = pathIn a 433 | showCall (CallEnv f) = f 434 | showCall (CallTemp f) = f -- TODO: differentiate from CallEnv 435 | 436 | showCommand :: CommandQ -> String 437 | showCommand (CommandQ (Command progs inps) outputs) = unlines $ 438 | map showOutput outputs 439 | ++ map showInput (Set.toList $ unHashableSet inps) 440 | ++ map showProg progs 441 | where 442 | showOutput a = "Output: " ++ a 443 | showInput i = "Input: " ++ pathIn i 444 | 445 | stdoutOutput :: FilePath 446 | stdoutOutput = "_stdout" 447 | 448 | defaultEnv :: [(String, String)] 449 | defaultEnv = 450 | [ ("PATH", "/usr/bin:/bin") 451 | -- Set LANG to enable TemplateHaskell code reading UTF-8 files correctly. 452 | , ("LANG", "en_US.UTF-8") 453 | ] 454 | 455 | spliceTempDir :: FilePath -> String -> String 456 | spliceTempDir tmp = T.unpack . T.replace (T.pack "${TMPDIR}") (T.pack tmp) . T.pack 457 | 458 | checkAllDistinctPaths :: Monad m => [Artifact] -> m () 459 | checkAllDistinctPaths as = 460 | case Map.keys . Map.filter (> 1) . Map.fromListWith (+) 461 | . map (\a -> (pathIn a, 1 :: Integer)) $ as of 462 | [] -> return () 463 | -- TODO: nicer error, telling where they came from: 464 | fs -> error $ "Artifacts generated from more than one command: " ++ show fs 465 | 466 | -- Remove duplicate artifacts that are both outputs of the same command, and where 467 | -- one is a subdirectory of the other (for example, constructed via `/>`). 468 | dedupArtifacts :: Set Artifact -> [Artifact] 469 | dedupArtifacts = loop . Set.toAscList 470 | where 471 | -- Loop over artifacts built from the same command. 472 | -- toAscList plus lexicographic sorting means that 473 | -- subdirectories with the same hash will appear consecutively after directories 474 | -- that contain them. 475 | loop (a@(Artifact (Built h) f) : Artifact (Built h') f' : fs) 476 | -- TODO BUG: "Picture", "Picture.hs" and Picture/Foo.hs" sort in the wrong way 477 | -- so "Picture" and "Picture/Foo.hs" aren't deduped. 478 | | h == h', (f "*") ?== f' = loop (a:fs) 479 | loop (f:fs) = f : loop fs 480 | loop [] = [] 481 | 482 | -- Symlink the artifact into the given destination directory. 483 | linkArtifact :: FilePath -> Artifact -> IO () 484 | linkArtifact _ (Artifact External f) 485 | | isAbsolute f = return () 486 | linkArtifact dir a = do 487 | curDir <- getCurrentDirectory 488 | let realPath = curDir realPathIn a 489 | let localPath = dir pathIn a 490 | createParentIfMissing localPath 491 | isFile <- Directory.doesFileExist realPath 492 | if isFile 493 | then createFileLink realPath localPath 494 | else do 495 | isDir <- Directory.doesDirectoryExist realPath 496 | if isDir 497 | then createDirectoryLink realPath localPath 498 | else error $ "linkArtifact: source does not exist: " ++ show realPath 499 | ++ " for artifact " ++ show a 500 | 501 | 502 | -- | Returns the relative path to an Artifact within the sandbox, when provided 503 | -- to a 'Command' by 'input'. 504 | pathIn :: Artifact -> FilePath 505 | pathIn (Artifact External f) = externalArtifactDir f 506 | pathIn (Artifact (Built h) f) = hashDir h f 507 | 508 | -- | Returns the relative path to an artifact within the root directory. 509 | realPathIn :: Artifact -> FilePath 510 | realPathIn (Artifact External f) = f 511 | realPathIn (Artifact (Built h) f) = hashDir h f 512 | 513 | 514 | -- | Replace the extension of an Artifact. In particular, 515 | -- 516 | -- > pathIn (replaceArtifactExtension f ext) == replaceExtension (pathIn f) ext@ 517 | replaceArtifactExtension :: Artifact -> String -> Artifact 518 | replaceArtifactExtension (Artifact s f) ext 519 | = Artifact s $ replaceExtension f ext 520 | 521 | -- | Read the contents of an Artifact. 522 | readArtifact :: Artifact -> Action String 523 | readArtifact (Artifact External f) = readFile' f -- includes need 524 | readArtifact f = liftIO $ readFile $ pathIn f 525 | 526 | readArtifactB :: Artifact -> Action B.ByteString 527 | readArtifactB (Artifact External f) = need [f] >> liftIO (B.readFile f) 528 | readArtifactB f = liftIO $ B.readFile $ pathIn f 529 | 530 | data WriteArtifactQ = WriteArtifactQ 531 | { writePath :: FilePath 532 | , writeContents :: String 533 | } 534 | deriving (Eq, Typeable, Generic, Hashable, Binary, NFData) 535 | 536 | instance Show WriteArtifactQ where 537 | show w = "Write " ++ writePath w 538 | 539 | type instance RuleResult WriteArtifactQ = Artifact 540 | 541 | writeArtifact :: FilePath -> String -> Action Artifact 542 | writeArtifact path contents = askPersistent $ WriteArtifactQ path contents 543 | 544 | writeArtifactRules :: Maybe SharedCache -> Rules () 545 | writeArtifactRules sharedCache = addPersistent 546 | $ \WriteArtifactQ {writePath = path, writeContents = contents} -> do 547 | h <- makeHash . T.encodeUtf8 . T.pack 548 | $ "writeArtifact: " ++ contents 549 | createArtifacts sharedCache h [] $ \tmpDir -> do 550 | let out = tmpDir path 551 | createParentIfMissing out 552 | liftIO $ writeFile out contents 553 | return $ builtArtifact h path 554 | 555 | doesArtifactExist :: Artifact -> Action Bool 556 | doesArtifactExist (Artifact External f) = Development.Shake.doesFileExist f 557 | doesArtifactExist f = liftIO $ Directory.doesFileExist (pathIn f) 558 | 559 | -- Note: this throws an exception if there's no match. 560 | matchArtifactGlob :: Artifact -> FilePath -> Action [FilePath] 561 | matchArtifactGlob (Artifact External f) g 562 | = getDirectoryFiles f [g] 563 | matchArtifactGlob a g 564 | = liftIO $ getDirectoryFilesIO (pathIn a) [g] 565 | 566 | -- TODO: merge more with above code? How hermetic should it be? 567 | callArtifact :: HandleTemps -> Set Artifact -> Artifact -> [String] -> IO () 568 | callArtifact ht inps bin args = withPierTempDirectory ht "exec" $ \tmp -> do 569 | dir <- getCurrentDirectory 570 | collectInputs (Set.insert bin inps) tmp 571 | cmd_ [Cwd tmp] 572 | (dir tmp pathIn bin) args 573 | 574 | createDirectoryA :: FilePath -> Command 575 | createDirectoryA f = prog "mkdir" ["-p", f] 576 | 577 | -- | Group source files by shadowing into a single directory. 578 | groupFiles :: Artifact -> [(FilePath, FilePath)] -> Action Artifact 579 | groupFiles dir files = let out = "group" 580 | in runCommandOutput out 581 | $ createDirectoryA out 582 | <> foldMap (\(f, g) -> shadow (dir /> f) (out g)) 583 | files 584 | -------------------------------------------------------------------------------- /pier-core/src/Pier/Core/Download.hs: -------------------------------------------------------------------------------- 1 | module Pier.Core.Download 2 | ( askDownload 3 | , Download(..) 4 | , downloadRules 5 | ) where 6 | 7 | import Control.Monad (unless) 8 | import Development.Shake 9 | import Development.Shake.Classes 10 | import Development.Shake.FilePath 11 | import GHC.Generics 12 | import Network.HTTP.Client 13 | import Network.HTTP.Client.TLS 14 | import Network.HTTP.Types.Status 15 | 16 | import qualified Data.ByteString.Char8 as BC 17 | import qualified Data.ByteString.Lazy as L 18 | import qualified Data.Text as T 19 | import qualified Data.Text.Encoding as T 20 | 21 | import Pier.Core.Artifact 22 | import Pier.Core.Internal.Directory 23 | import Pier.Core.Internal.Store 24 | import Pier.Core.Persistent 25 | 26 | -- | Downloads @downloadUrlPrefix / downloadName@ to 27 | -- @downloadFilePrefix / downloadName@. 28 | -- Everything is stored in `~/.pier/downloads`. 29 | data Download = Download 30 | { downloadUrlPrefix :: String 31 | , downloadName :: FilePath 32 | } 33 | deriving (Typeable, Eq, Generic) 34 | 35 | instance Show Download where 36 | show d = "Download " ++ show (downloadName d) 37 | ++ " from " ++ show (downloadUrlPrefix d) 38 | 39 | instance Hashable Download 40 | instance Binary Download 41 | instance NFData Download 42 | 43 | type instance RuleResult Download = Artifact 44 | 45 | askDownload :: Download -> Action Artifact 46 | askDownload = askPersistent 47 | 48 | downloadRules :: Maybe SharedCache -> Rules () 49 | downloadRules sharedCache = do 50 | manager <- liftIO $ newManager tlsManagerSettings 51 | addPersistent $ \d -> do 52 | h <- makeHash . T.encodeUtf8 . T.pack 53 | $ "download: " ++ show d 54 | let name = downloadName d 55 | let msg = "Downloading " ++ name 56 | createArtifacts sharedCache h [msg] $ \tmpDir -> do 57 | let out = tmpDir name 58 | createParentIfMissing out 59 | putNormal msg 60 | liftIO $ do 61 | let url = downloadUrlPrefix d ++ "/" ++ downloadName d 62 | req <- parseRequest url 63 | resp <- httpLbs req manager 64 | unless (statusIsSuccessful . responseStatus $ resp) 65 | $ error $ "Unable to download " ++ show url 66 | ++ "\nStatus: " ++ showStatus (responseStatus resp) 67 | liftIO . L.writeFile out . responseBody $ resp 68 | return $ builtArtifact h name 69 | where 70 | showStatus s = show (statusCode s) ++ " " ++ BC.unpack (statusMessage s) 71 | -------------------------------------------------------------------------------- /pier-core/src/Pier/Core/Internal/Directory.hs: -------------------------------------------------------------------------------- 1 | module Pier.Core.Internal.Directory 2 | ( forFileRecursive_ 3 | , FileItem(..) 4 | , getRegularContents 5 | , createParentIfMissing 6 | , copyDirectory 7 | , parentDirectory 8 | ) where 9 | 10 | import Control.Monad.IO.Class 11 | import Development.Shake.FilePath 12 | import System.Directory 13 | import qualified System.Posix.Files as Posix 14 | 15 | -- | Create recursively the parent of the given path, if it doesn't exist. 16 | createParentIfMissing :: MonadIO m => FilePath -> m () 17 | createParentIfMissing 18 | = liftIO . createDirectoryIfMissing True . parentDirectory 19 | 20 | -- | Get the parent of the given directory or file. 21 | -- 22 | -- Examples: 23 | -- 24 | -- parentDirectory "foo/bar" == "foo" 25 | -- parentDirectory "foo/bar/" == "foo" 26 | -- parentDirectory "foo" == "" 27 | parentDirectory :: FilePath -> FilePath 28 | parentDirectory = fixPeriod . takeDirectory . dropTrailingPathSeparator 29 | where 30 | fixPeriod "." = "" 31 | fixPeriod x = x 32 | 33 | data FileItem = RegularFile | DirectoryStart | DirectoryEnd | SymbolicLink 34 | 35 | forFileRecursive_ :: (FileItem -> FilePath -> IO ()) -> FilePath -> IO () 36 | forFileRecursive_ act f = do 37 | isSymLink <- pathIsSymbolicLink f 38 | if isSymLink 39 | then act SymbolicLink f 40 | else do 41 | isDir <- doesDirectoryExist f 42 | if not isDir 43 | then act RegularFile f 44 | else do 45 | act DirectoryStart f 46 | getRegularContents f 47 | >>= mapM_ (forFileRecursive_ act . (f )) 48 | act DirectoryEnd f 49 | 50 | -- | Get the contents of this path, excluding the special files "." and ".." 51 | getRegularContents :: FilePath -> IO [FilePath] 52 | getRegularContents f = 53 | filter (not . specialFile) <$> getDirectoryContents f 54 | where 55 | specialFile "." = True 56 | specialFile ".." = True 57 | specialFile _ = False 58 | 59 | -- | Copy the directory recursively from the source to the target location. 60 | -- Hard-link files, and copy any symlinks. 61 | copyDirectory :: FilePath -> FilePath -> IO () 62 | copyDirectory src dest = do 63 | createParentIfMissing dest 64 | forFileRecursive_ act src 65 | where 66 | act RegularFile f = Posix.createLink f $ dest makeRelative src f 67 | act SymbolicLink f = do 68 | target <- getSymbolicLinkTarget f 69 | let g = dest makeRelative src f 70 | createParentIfMissing g 71 | createFileLink target g 72 | act DirectoryStart f = createDirectoryIfMissing False (dest makeRelative src f) 73 | act DirectoryEnd _ = return () 74 | -------------------------------------------------------------------------------- /pier-core/src/Pier/Core/Internal/HashableSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Pier.Core.Internal.HashableSet 3 | ( HashableSet(..) 4 | ) where 5 | 6 | import qualified Data.Set as Set 7 | import Development.Shake.Classes 8 | 9 | -- | A newtype wrapper for 'Data.Set' which is an instance of 'Hashable', 10 | -- so it can be used in Shake rules. 11 | newtype HashableSet a = HashableSet { unHashableSet :: Set.Set a } 12 | deriving (Eq, Binary, NFData, Semigroup, Monoid) 13 | 14 | instance Hashable a => Hashable (HashableSet a) where 15 | hashWithSalt k = hashWithSalt k . Set.toList . unHashableSet 16 | -------------------------------------------------------------------------------- /pier-core/src/Pier/Core/Internal/Store.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | module Pier.Core.Internal.Store 3 | ( -- * Temporary files and directories 4 | HandleTemps(..), 5 | withPierTempDirectory, 6 | withPierTempDirectoryAction, 7 | -- * Build directory 8 | pierDir, 9 | -- * Hash directories 10 | artifactDir, 11 | Hash, 12 | hashString, 13 | hashDir, 14 | makeHash, 15 | createArtifacts, 16 | unfreezeArtifacts, 17 | SharedCache(..), 18 | hashExternalFile, 19 | -- * Artifacts 20 | Artifact(..), 21 | Source(..), 22 | builtArtifact, 23 | external, 24 | (/>), 25 | -- * Rules 26 | storeRules, 27 | ) where 28 | 29 | import Control.Monad (forM_, when, void) 30 | import Control.Monad.IO.Class 31 | import Crypto.Hash.SHA256 (hashlazy, hash) 32 | import Data.ByteString.Base64 (encode) 33 | import Development.Shake 34 | import Development.Shake.Classes hiding (hash) 35 | import Development.Shake.FilePath 36 | import GHC.Generics 37 | import System.Directory as Directory 38 | import System.IO.Temp 39 | 40 | import qualified Data.Binary as Binary 41 | import qualified Data.ByteString as B 42 | import qualified Data.ByteString.Char8 as BC 43 | import qualified Data.List as List 44 | 45 | import Pier.Core.Internal.Directory 46 | 47 | pierDir :: FilePath 48 | pierDir = "_pier" 49 | 50 | data HandleTemps = RemoveTemps | KeepTemps 51 | 52 | withPierTempDirectoryAction 53 | :: HandleTemps -> String -> (FilePath -> Action a) -> Action a 54 | withPierTempDirectoryAction KeepTemps template f = 55 | createPierTempDirectory template >>= f 56 | withPierTempDirectoryAction RemoveTemps template f = do 57 | tmp <- createPierTempDirectory template 58 | f tmp `actionFinally` removeDirectoryRecursive tmp 59 | 60 | withPierTempDirectory 61 | :: HandleTemps -> String -> (FilePath -> IO a) -> IO a 62 | withPierTempDirectory KeepTemps template f = 63 | createPierTempDirectory template >>= f 64 | withPierTempDirectory RemoveTemps template f = do 65 | createDirectoryIfMissing True pierTempDirectory 66 | withTempDirectory pierTempDirectory template f 67 | 68 | pierTempDirectory :: String 69 | pierTempDirectory = pierDir "tmp" 70 | 71 | createPierTempDirectory :: MonadIO m => String -> m FilePath 72 | createPierTempDirectory template = liftIO $ do 73 | createDirectoryIfMissing True pierTempDirectory 74 | createTempDirectory pierTempDirectory template 75 | 76 | -- | Unique identifier of a command 77 | newtype Hash = Hash B.ByteString 78 | deriving (Show, Eq, Ord, Binary, NFData, Hashable, Generic) 79 | 80 | makeHash :: Binary a => a -> Action Hash 81 | makeHash x = do 82 | version <- askOracle GetArtifactVersion 83 | return . Hash . fixChars . dropPadding . encode . hashlazy . Binary.encode 84 | . tagVersion version 85 | $ x 86 | where 87 | -- Remove slashes, since the strings will appear in filepaths. 88 | fixChars = BC.map $ \case 89 | '/' -> '_' 90 | c -> c 91 | -- Padding just adds noise, since we don't have length requirements (and indeed 92 | -- every sha256 hash is 32 bytes) 93 | dropPadding c 94 | | BC.last c == '=' = BC.init c 95 | -- Shouldn't happen since each hash is the same length: 96 | | otherwise = c 97 | tagVersion = (,) 98 | 99 | hashExternalFile :: FilePath -> IO B.ByteString 100 | hashExternalFile = fmap hash . B.readFile 101 | 102 | -- | Version number of artifacts being generated. 103 | newtype ArtifactVersion = ArtifactVersion Int 104 | deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic) 105 | 106 | data GetArtifactVersion = GetArtifactVersion 107 | deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic) 108 | type instance RuleResult GetArtifactVersion = ArtifactVersion 109 | 110 | artifactVersionRule :: Rules () 111 | artifactVersionRule = void $ addOracle $ \GetArtifactVersion 112 | -- Bumping this will cause every artifact to be regenerated, and should 113 | -- only be done in case of backwards-incompatible changes. 114 | -> return $ ArtifactVersion 1 115 | 116 | hashDir :: Hash -> FilePath 117 | hashDir h = artifactDir hashString h 118 | 119 | hashString :: Hash -> String 120 | hashString (Hash h) = BC.unpack h 121 | 122 | storeRules :: Rules () 123 | storeRules = artifactVersionRule 124 | 125 | newtype SharedCache = SharedCache FilePath 126 | 127 | globalHashDir :: SharedCache -> Hash -> FilePath 128 | globalHashDir (SharedCache f) h = f hashString h 129 | 130 | -- | Create a directory containing Artifacts. 131 | -- 132 | -- If the output directory already exists, don't do anything. Otherwise, run 133 | -- the given function with a temporary directory, and then move that directory 134 | -- atomically to the final output directory for those Artifacts. 135 | -- Files and (sub)directories, as well as the directory itself, will 136 | -- be made read-only. 137 | createArtifacts :: 138 | Maybe SharedCache 139 | -> Hash 140 | -> [String] -- ^ Messages to print if cached 141 | -> (FilePath -> Action ()) 142 | -> Action () 143 | createArtifacts maybeSharedCache h messages act = do 144 | let destDir = hashDir h 145 | exists <- liftIO $ Directory.doesDirectoryExist destDir 146 | -- Skip if the output directory already exists; we'll produce it atomically 147 | -- below. This could happen if Shake's database was cleaned, or if the 148 | -- action stops before Shake registers it as complete, due to either a 149 | -- synchronous or asynchronous exception. 150 | if exists 151 | then mapM_ cacheMessage messages 152 | else do 153 | tempDir <- createPierTempDirectory $ hashString h ++ "-result" 154 | case maybeSharedCache of 155 | Nothing -> act tempDir 156 | Just cache -> do 157 | getFromSharedCache <- liftIO $ copyFromCache cache h tempDir 158 | if getFromSharedCache 159 | then mapM_ sharedCacheMessage messages 160 | else do 161 | act tempDir 162 | liftIO $ copyToCache cache h tempDir 163 | liftIO $ finish tempDir destDir 164 | where 165 | cacheMessage m = putNormal $ "(from cache: " ++ m ++ ")" 166 | sharedCacheMessage m = putNormal $ "(from shared cache: " ++ m ++ ")" 167 | finish tempDir destDir = do 168 | -- Move the created directory to its final location, 169 | -- with all the files and directories inside set to 170 | -- read-only. 171 | -- Don't set permissions on symbolic links; they're ignored 172 | -- on most systems (e.g., Linux). 173 | let freeze RegularFile = freezePath 174 | freeze DirectoryEnd = freezePath 175 | freeze _ = const $ return () 176 | -- TODO: why is getRegularContents used? 177 | -- Ah, to avoid the current directory. 178 | getRegularContents tempDir 179 | >>= mapM_ (forFileRecursive_ freeze . (tempDir )) 180 | createParentIfMissing destDir 181 | Directory.renameDirectory tempDir destDir 182 | -- Also set the directory itself to read-only, but wait 183 | -- until the last step since read-only files can't be moved. 184 | freezePath destDir 185 | 186 | -- TODO: consider using hard links for these copies, to save space 187 | -- TODO: make sure the directories are read-only 188 | copyFromCache :: SharedCache -> Hash -> FilePath -> IO Bool 189 | copyFromCache cache h tempDir = do 190 | let globalDir = globalHashDir cache h 191 | globalExists <- liftIO $ Directory.doesDirectoryExist globalDir 192 | if globalExists 193 | then copyDirectory globalDir tempDir >> return True 194 | else return False 195 | 196 | copyToCache :: SharedCache -> Hash -> FilePath -> IO () 197 | copyToCache cache h src = do 198 | tempDir <- createPierTempDirectory $ hashString h ++ "-cache" 199 | copyDirectory src tempDir 200 | let dest = globalHashDir cache h 201 | createParentIfMissing dest 202 | Directory.renameDirectory tempDir dest 203 | 204 | artifactDir :: FilePath 205 | artifactDir = pierDir "artifact" 206 | 207 | freezePath :: FilePath -> IO () 208 | freezePath f = 209 | getPermissions f >>= setPermissions f . setOwnerWritable False 210 | 211 | -- | Make all artifacts user-writable, so they can be deleted by `clean-all`. 212 | unfreezeArtifacts :: IO () 213 | unfreezeArtifacts = forM_ [artifactDir, pierTempDirectory] $ \dir -> do 214 | exists <- Directory.doesDirectoryExist dir 215 | when exists $ forFileRecursive_ unfreeze dir 216 | where 217 | unfreeze DirectoryStart f = 218 | getPermissions f >>= setPermissions f . setOwnerWritable True 219 | unfreeze _ _ = return () 220 | 221 | -- | An 'Artifact' is a file or folder that was created by a build command. 222 | data Artifact = Artifact Source FilePath 223 | deriving (Eq, Ord, Generic, Hashable, Binary, NFData) 224 | 225 | instance Show Artifact where 226 | show (Artifact External f) = "external:" ++ show f 227 | show (Artifact (Built h) f) = hashString h ++ ":" ++ show f 228 | 229 | data Source = Built Hash | External 230 | deriving (Show, Eq, Ord, Generic, Hashable, Binary, NFData) 231 | 232 | builtArtifact :: Hash -> FilePath -> Artifact 233 | builtArtifact h = Artifact (Built h) . normaliseMore 234 | 235 | -- | Create an 'Artifact' from an input file to the build (for example, a 236 | -- source file created by the user). 237 | -- 238 | -- If it is a relative path, changes to the file will cause rebuilds of 239 | -- Commands and Rules that dependended on it. 240 | external :: FilePath -> Artifact 241 | external f 242 | | null f' = error "external: empty input" 243 | | artifactDir `List.isPrefixOf` f' = error $ "external: forbidden prefix: " ++ show f' 244 | | otherwise = Artifact External f' 245 | where 246 | f' = normaliseMore f 247 | 248 | -- | Normalize a filepath, also dropping the trailing slash. 249 | normaliseMore :: FilePath -> FilePath 250 | normaliseMore = dropTrailingPathSeparator . normalise 251 | 252 | -- | Create a reference to a sub-file of the given 'Artifact', which must 253 | -- refer to a directory. 254 | (/>) :: Artifact -> FilePath -> Artifact 255 | Artifact source f /> g = Artifact source $ normaliseMore $ f g 256 | 257 | infixr 5 /> -- Same as 258 | -------------------------------------------------------------------------------- /pier-core/src/Pier/Core/Persistent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | module Pier.Core.Persistent 3 | ( addPersistent 4 | , askPersistent 5 | , askPersistents 6 | , cleaning 7 | ) where 8 | 9 | 10 | import Data.Binary (encode, decodeOrFail) 11 | import Development.Shake 12 | import Development.Shake.Classes 13 | import Development.Shake.Rule 14 | import GHC.Generics 15 | 16 | import qualified Data.ByteString as BS 17 | import qualified Data.ByteString.Lazy as LBS 18 | 19 | newtype Persistent question = Persistent question 20 | deriving (Typeable, Eq, Generic, Hashable, Binary, NFData) 21 | 22 | -- Improve error messages by just forwarding the instance of the 23 | -- wrapped type. 24 | instance Show q => Show (Persistent q) where 25 | show (Persistent q) = show q 26 | 27 | newtype PersistentA answer = PersistentA { unPersistentA :: answer } 28 | deriving (Show, Typeable, Eq, Generic, Hashable, Binary, NFData) 29 | 30 | type instance RuleResult (Persistent q) = PersistentA (RuleResult q) 31 | 32 | addPersistent 33 | :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) 34 | => (q -> Action a) 35 | -> Rules () 36 | addPersistent act = addBuiltinRule noLint $ \(Persistent q) old depsChanged 37 | -> case old of 38 | Just old' | not depsChanged 39 | , Just val <- decode' old' 40 | -> return $ RunResult ChangedNothing old' val 41 | _ -> do 42 | rerunIfCleaned 43 | new <- PersistentA <$> act q 44 | return $ RunResult 45 | (if (old >>= decode') == Just new 46 | then ChangedRecomputeSame 47 | else ChangedRecomputeDiff) 48 | (encode' new) 49 | new 50 | where 51 | encode' :: Binary a => a -> BS.ByteString 52 | encode' = BS.concat . LBS.toChunks . encode 53 | 54 | decode' :: Binary a => BS.ByteString -> Maybe a 55 | decode' b = case decodeOrFail $ LBS.fromChunks [b] of 56 | Right (bs,_,x) 57 | | LBS.null bs -> Just x 58 | _ -> Nothing 59 | 60 | 61 | -- Idea: use gitrev, or something similar. 62 | -- Save the current git hash, plus the output of "git diff HEAD", 63 | -- to decide whether persistents need to be recomputed. 64 | 65 | askPersistent 66 | :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) 67 | => q 68 | -> Action a 69 | askPersistent question = do 70 | PersistentA answer <- apply1 $ Persistent question 71 | return answer 72 | 73 | askPersistents 74 | :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) 75 | => [q] 76 | -> Action [a] 77 | askPersistents = fmap (map unPersistentA) . apply . map Persistent 78 | 79 | 80 | data Cleaner = Cleaner 81 | deriving (Show, Typeable, Eq, Generic, Binary, NFData, Hashable) 82 | 83 | type instance RuleResult Cleaner = () 84 | 85 | cleaning :: Bool -> Rules () 86 | cleaning shouldClean = do 87 | action rerunIfCleaned 88 | addBuiltinRule noLint $ \Cleaner _ _ -> 89 | let change = if shouldClean 90 | then ChangedRecomputeDiff 91 | else ChangedNothing 92 | in return $ RunResult change BS.empty () 93 | 94 | rerunIfCleaned :: Action () 95 | rerunIfCleaned = apply1 Cleaner 96 | -------------------------------------------------------------------------------- /pier-core/src/Pier/Core/Run.hs: -------------------------------------------------------------------------------- 1 | module Pier.Core.Run 2 | ( -- * Build directory 3 | runPier 4 | , cleanAll 5 | ) where 6 | 7 | import Development.Shake 8 | 9 | import Pier.Core.Internal.Store 10 | 11 | runPier :: Rules () -> IO () 12 | runPier = shakeArgs shakeOptions 13 | { shakeFiles = pierDir 14 | , shakeProgress = progressSimple 15 | , shakeChange = ChangeDigest 16 | -- Detect the number of threads: 17 | , shakeThreads = 0 18 | } 19 | 20 | cleanAll :: Rules () 21 | cleanAll = action $ do 22 | putNormal $ "Removing " ++ pierDir 23 | removeFilesAfter pierDir ["//"] 24 | 25 | 26 | -------------------------------------------------------------------------------- /pier.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.8 2 | 3 | packages: 4 | - 'pier' 5 | - 'pier-core' 6 | - 'example' 7 | -------------------------------------------------------------------------------- /pier/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Judah Jacobson 2017. 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | 9 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 10 | 11 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 12 | 13 | 14 | -------------------------------------------------------------------------------- /pier/package.yaml: -------------------------------------------------------------------------------- 1 | name: pier 2 | version: 0.3.0.0 3 | license: BSD3 4 | maintainer: judah.jacobson@gmail.com 5 | synopsis: Yet another Haskell build system. 6 | description: | 7 | Pier is a command-line tool for building Haskell projects. It is 8 | similar in purpose to , 9 | but explores a different design: 10 | 11 | * Pier implements the fine-grained Haskell build logic from (nearly) 12 | scratch. In contrast, Stack relies on Cabal to implement most of its 13 | build steps, giving it a more coarse control over the build. 14 | * Pier uses general-purpose libraries for implementing build systems, namely 15 | and . 16 | 17 | For more information, see the official . 18 | 19 | category: Development 20 | github: judah/pier 21 | 22 | # Work around haskell/cabal#4739 23 | when: 24 | - condition: os(darwin) 25 | ghc-options: -optP-Wno-nonportable-include-path 26 | 27 | executables: 28 | pier: 29 | source-dirs: 'src' 30 | main: Main.hs 31 | ghc-options: -threaded -with-rtsopts=-I0 32 | dependencies: 33 | - Cabal == 2.2.* 34 | - aeson >= 1.3 && < 1.5 35 | - base == 4.11.* 36 | - binary == 0.8.* 37 | - binary-orphans == 0.1.* 38 | - containers == 0.5.* 39 | - directory >= 1.3.1 && < 1.4 40 | - hashable == 1.2.* 41 | - optparse-applicative 42 | - pier-core == 0.3.* 43 | - shake == 0.16.* 44 | - split == 0.2.* 45 | - text == 1.2.* 46 | - transformers == 0.5.* 47 | - unordered-containers == 0.2.* 48 | - yaml >= 0.8 && < 0.11 49 | default-extensions: !include "../common-extensions.yaml" 50 | -------------------------------------------------------------------------------- /pier/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | module Main (main) where 3 | 4 | import Control.Exception (bracket) 5 | import Control.Monad (join, void) 6 | import Data.IORef 7 | import Data.List.Split (splitOn) 8 | import Data.Maybe (fromMaybe) 9 | import Data.Monoid (Last(..)) 10 | import Data.Semigroup (Semigroup, (<>)) 11 | import Development.Shake hiding (command) 12 | import Development.Shake.FilePath ((), takeDirectory, splitFileName) 13 | import Distribution.Package 14 | import Distribution.Text (display, simpleParse) 15 | import Options.Applicative hiding (action) 16 | import System.Directory as Directory 17 | import System.Environment 18 | 19 | import qualified Data.HashMap.Strict as HM 20 | 21 | import Pier.Build.Components 22 | import Pier.Build.Config 23 | import Pier.Build.Stackage 24 | import Pier.Core.Artifact hiding (runCommand) 25 | import Pier.Core.Download 26 | import Pier.Core.Persistent 27 | import Pier.Core.Run 28 | 29 | data CommandOpt 30 | = Clean 31 | | CleanAll 32 | | Setup 33 | | Build [(PackageName, Target)] 34 | | Run Sandboxed (PackageName, Target) [String] 35 | | Test Sandboxed [(PackageName, Target)] 36 | | Which (PackageName, Target) 37 | 38 | data Sandboxed = Sandbox | NoSandbox 39 | 40 | parseSandboxed :: Parser Sandboxed 41 | parseSandboxed = 42 | flag NoSandbox Sandbox 43 | $ long "sandbox" 44 | <> help "Run hermetically in a temporary folder" 45 | 46 | data CommonOptions = CommonOptions 47 | { pierYaml :: Last FilePath 48 | , shakeFlags :: [String] 49 | , lastHandleTemps :: Last HandleTemps 50 | , lastSharedCache :: Last UseSharedCache 51 | } 52 | 53 | instance Semigroup CommonOptions where 54 | CommonOptions y f ht sc <> CommonOptions y' f' ht' sc' 55 | = CommonOptions (y <> y') (f <> f') (ht <> ht') (sc <> sc') 56 | 57 | handleTemps :: CommonOptions -> HandleTemps 58 | handleTemps = fromMaybe RemoveTemps . getLast . lastHandleTemps 59 | 60 | sharedCache :: CommonOptions -> UseSharedCache 61 | sharedCache = fromMaybe UseHomeSharedCache . getLast . lastSharedCache 62 | 63 | -- | Parse command-independent options. 64 | -- 65 | -- These are allowed both at the top level 66 | -- (for example, "-V" in "pier -V build TARGETS") and within individual 67 | -- commands ("pier build -V TARGETS"). However, we want them to only appear 68 | -- in "pier --help", not "pier build --help". Doing so is slightly 69 | -- cumbersome with optparse-applicative. 70 | parseCommonOptions :: Hidden -> Parser CommonOptions 71 | parseCommonOptions h = CommonOptions <$> parsePierYaml 72 | <*> parseShakeFlags h 73 | <*> parseHandleTemps 74 | <*> parseSharedCache 75 | where 76 | parsePierYaml :: Parser (Last FilePath) 77 | parsePierYaml = fmap Last $ optional $ strOption 78 | $ long "pier-yaml" <> metavar "YAML" <> hide h 79 | 80 | parseHandleTemps :: Parser (Last HandleTemps) 81 | parseHandleTemps = 82 | Last <$> 83 | flag Nothing (Just KeepTemps) 84 | (long "keep-temps" 85 | <> help "Don't remove temporary directories") 86 | 87 | parseSharedCache :: Parser (Last UseSharedCache) 88 | parseSharedCache = fmap Last $ 89 | flag Nothing (Just DontUseSharedCache) 90 | ( long "no-shared-cache" 91 | <> help "Don't use the shared cache at ~/.pier/artifact") 92 | <|> optional (fmap UseSharedCacheAt $ strOption 93 | $ long "shared-cache-path" 94 | <> metavar "PATH" 95 | <> help "Location of shared cache") 96 | 97 | data UseSharedCache 98 | = UseHomeSharedCache 99 | | DontUseSharedCache 100 | | UseSharedCacheAt FilePath 101 | deriving Show 102 | 103 | data Hidden = Hidden | Shown 104 | 105 | hide :: Hidden -> Mod f a 106 | hide Hidden = hidden <> internal 107 | hide Shown = mempty 108 | 109 | parseShakeFlags :: Hidden -> Parser [String] 110 | parseShakeFlags h = 111 | mconcat <$> sequenceA [verbosity, parallelism, keepGoing, shakeArg] 112 | where 113 | shakeArg = many $ strOption (long "shake-arg" <> metavar "SHAKEARG" <> hide h) 114 | 115 | verbosity, parallelism, keepGoing, shakeArg :: Parser [String] 116 | parallelism = 117 | fmap (maybe [] (\j -> ["--jobs=" ++ j])) 118 | $ optional $ strOption 119 | $ long "jobs" 120 | <> short 'j' 121 | <> help "Number of job/threads at once [default CPUs]" 122 | <> hide h 123 | 124 | keepGoing = flag [] ["--keep-going"] 125 | $ long "keep-going" 126 | <> help "Keep going when some targets can't be built." 127 | 128 | verbosity = 129 | fmap combineFlags . many . flag' 'V' 130 | $ long "verbose" 131 | <> short 'V' 132 | <> help "Increase the verbosity level" 133 | <> hide h 134 | 135 | combineFlags [] = [] 136 | combineFlags vs = ['-':vs] 137 | 138 | parser :: ParserInfo (CommonOptions, CommandOpt) 139 | parser = fmap (\(x,(y,z)) -> (x <> y, z)) 140 | $ info (helper <*> liftA2 (,) (parseCommonOptions Shown) 141 | parseCommand) 142 | $ progDesc "Yet another Haskell build tool" 143 | 144 | parseCommand :: Parser (CommonOptions, CommandOpt) 145 | parseCommand = subparser $ mconcat 146 | [ make "clean" cleanCommand "Clean project" 147 | , make "clean-all" cleanAllCommand "Clean project & dependencies" 148 | , make "setup" setupCommand "Only configure the compiler and build plan" 149 | , make "build" buildCommand "Build project" 150 | , make "run" runCommand "Run executable" 151 | , make "test" testCommand "Run test suites" 152 | , make "which" whichCommand "Build executable and print its location" 153 | ] 154 | where 155 | make name act desc = 156 | command name $ info (liftA2 (,) (parseCommonOptions Hidden) 157 | (helper <*> act)) 158 | $ progDesc desc 159 | 160 | cleanCommand :: Parser CommandOpt 161 | cleanCommand = pure Clean 162 | 163 | cleanAllCommand :: Parser CommandOpt 164 | cleanAllCommand = pure CleanAll 165 | 166 | setupCommand :: Parser CommandOpt 167 | setupCommand = pure Setup 168 | 169 | buildCommand :: Parser CommandOpt 170 | buildCommand = Build <$> many parseTarget 171 | 172 | runCommand :: Parser CommandOpt 173 | runCommand = Run <$> parseSandboxed <*> parseTarget 174 | <*> many (strArgument (metavar "ARGUMENT")) 175 | 176 | testCommand :: Parser CommandOpt 177 | testCommand = Test <$> parseSandboxed <*> many parseTarget 178 | 179 | whichCommand :: Parser CommandOpt 180 | whichCommand = Which <$> parseTarget 181 | 182 | 183 | findPierYamlFile :: Maybe FilePath -> IO FilePath 184 | findPierYamlFile (Just f) = return f 185 | findPierYamlFile Nothing = getCurrentDirectory >>= loop 186 | where 187 | loop dir = do 188 | let baseFile = "pier.yaml" 189 | let candidate = dir baseFile 190 | let parent = takeDirectory dir 191 | exists <- Directory.doesFileExist candidate 192 | if 193 | | exists -> return candidate 194 | | parent == dir -> 195 | error $ "Couldn't locate " ++ baseFile 196 | ++ " from the current directory" 197 | | otherwise -> loop parent 198 | 199 | runWithOptions 200 | :: IORef (IO ()) -- ^ Sink for what to do after the build 201 | -> HandleTemps 202 | -> CommandOpt 203 | -> Rules () 204 | runWithOptions _ _ Clean = cleaning True 205 | runWithOptions _ _ CleanAll = do 206 | liftIO unfreezeArtifacts 207 | cleaning True 208 | cleanAll 209 | runWithOptions _ _ Setup = do 210 | cleaning False 211 | action $ void askConfig 212 | runWithOptions _ _ (Build targets) = do 213 | cleaning False 214 | action $ do 215 | targets' <- targetsOrEverything targets 216 | -- Keep track of the number of targets. 217 | -- TODO: count transitive deps as well. 218 | let numTargets = length targets' 219 | successCount <- liftIO $ newIORef (0::Int) 220 | forP targets' $ \(p,t) -> do 221 | buildTarget p t 222 | k <- liftIO $ atomicModifyIORef' successCount 223 | $ \n -> let n' = n+1 in (n', n') 224 | putLoud $ "Built " ++ showTarget p t 225 | ++ " (" ++ show k ++ "/" ++ show numTargets ++ ")" 226 | runWithOptions next ht (Run sandbox (pkg, target) args) = do 227 | cleaning False 228 | action $ do 229 | exe <- buildExeTarget pkg target 230 | liftIO $ writeIORef next $ runBin ht sandbox exe args 231 | runWithOptions next ht (Test sandbox targets) = do 232 | cleaning False 233 | action $ do 234 | targets' <- targetsOrEverything targets 235 | tests <- concat <$> mapM (uncurry buildTestTargets) targets' 236 | liftIO $ writeIORef next $ mapM_ (\t -> runBin ht sandbox t []) tests 237 | runWithOptions _ _ (Which (pkg, target)) = do 238 | cleaning False 239 | action $ do 240 | exe <- buildExeTarget pkg target 241 | -- TODO: nicer output format. 242 | putNormal $ pathIn (builtBinary exe) 243 | 244 | -- Post-process command-line input. If it's empty, build all local packages. 245 | targetsOrEverything :: [(PackageName, Target)] -> Action [(PackageName, Target)] 246 | targetsOrEverything [] = map (, TargetAll) . HM.keys . localPackages 247 | <$> askConfig 248 | targetsOrEverything ts = return ts 249 | 250 | runBin :: HandleTemps -> Sandboxed -> BuiltBinary -> [String] -> IO () 251 | runBin ht sandbox exe args = 252 | case sandbox of 253 | Sandbox -> callArtifact ht (builtBinaryDataFiles exe) 254 | (builtBinary exe) args 255 | NoSandbox -> cmd_ (WithStderr False) 256 | (pathIn $ builtBinary exe) args 257 | 258 | buildExeTarget :: PackageName -> Target -> Action BuiltBinary 259 | buildExeTarget pkg target = case target of 260 | TargetExe name -> askBuiltExecutable pkg name 261 | TargetAll -> askBuiltExecutable pkg $ display pkg 262 | TargetAllExes -> askBuiltExecutable pkg $ display pkg 263 | TargetLib -> error "command can't be used with a \"lib\" target" 264 | TargetAllTests -> error "command can't be used with multiple \"test\" targets" 265 | TargetTest name -> askBuiltTestSuite pkg name 266 | 267 | buildTestTargets :: PackageName -> Target -> Action [BuiltBinary] 268 | buildTestTargets pkg target = case target of 269 | TargetExe _ -> error "command can't be used with an \"exe\" target" 270 | TargetAll -> askBuiltTestSuites pkg 271 | TargetAllTests -> askBuiltTestSuites pkg 272 | TargetTest name -> (: []) <$> askBuiltTestSuite pkg name 273 | TargetAllExes -> error "command can't be used with \"exe\" targets" 274 | TargetLib -> error "command can't be used with \"lib\" targets" 275 | 276 | main :: IO () 277 | main = do 278 | (commonOpts, cmdOpt) <- execParser parser 279 | -- A store for an optional action to run after building. 280 | -- It may be set by runWithOptions. This lets `pier run` "break" out 281 | -- of the Rules/Action monads. 282 | next <- newIORef $ pure () 283 | -- Run relative to the `pier.yaml` file. 284 | -- Afterwards, move explicitly back into the original directory in case 285 | -- this code is being interpreted by ghci. 286 | -- TODO (#69): don't rely on setCurrentDirectory; just use absolute paths 287 | -- everywhere in the code. 288 | (root, pierYamlFile) 289 | <- splitFileName <$> findPierYamlFile (getLast $ pierYaml commonOpts) 290 | let ht = handleTemps commonOpts 291 | cache <- getSharedCache $ sharedCache commonOpts 292 | bracket getCurrentDirectory setCurrentDirectory $ const $ do 293 | setCurrentDirectory root 294 | withArgs (shakeFlags commonOpts) $ runPier $ do 295 | buildPlanRules 296 | buildPackageRules 297 | artifactRules cache ht 298 | downloadRules cache 299 | installGhcRules 300 | configRules pierYamlFile 301 | runWithOptions next ht cmdOpt 302 | join $ readIORef next 303 | 304 | getSharedCache :: UseSharedCache -> IO (Maybe SharedCache) 305 | getSharedCache DontUseSharedCache = return Nothing 306 | getSharedCache (UseSharedCacheAt f) = return (Just $ SharedCache f) 307 | getSharedCache UseHomeSharedCache = do 308 | env <- lookupEnv "PIER_SHARED_CACHE" 309 | Just . SharedCache <$> case env of 310 | Just p -> return p 311 | Nothing -> do 312 | h <- getHomeDirectory 313 | return $ h ".pier" "artifact" 314 | 315 | -- TODO: move into Build.hs 316 | data Target 317 | = TargetAll 318 | | TargetLib 319 | | TargetAllExes 320 | | TargetExe String 321 | | TargetAllTests 322 | | TargetTest String 323 | deriving Show 324 | 325 | showTarget :: PackageName -> Target -> String 326 | showTarget pkg t = display pkg ++ case t of 327 | TargetAll -> "" 328 | TargetLib -> ":lib" 329 | TargetAllExes -> ":exe" 330 | TargetExe e -> ":exe:" ++ e 331 | TargetAllTests -> ":test-suite" 332 | TargetTest s -> ":test-suite:" ++ s 333 | 334 | parseTarget :: Parser (PackageName, Target) 335 | parseTarget = argument (eitherReader readTarget) (metavar "TARGET") 336 | where 337 | readTarget :: String -> Either String (PackageName, Target) 338 | readTarget s = case splitOn ":" s of 339 | [n] -> (, TargetAll) <$> readPackageName n 340 | [n, "lib"] -> (, TargetLib) <$> readPackageName n 341 | [n, "exe"] -> (, TargetAllExes) <$> readPackageName n 342 | [n, "exe", e] -> (, TargetExe e) <$> readPackageName n 343 | [n, "test"] -> (, TargetAllTests) <$> readPackageName n 344 | [n, "test", e] -> (, TargetTest e) <$> readPackageName n 345 | _ -> Left $ "Error parsing target " ++ show s 346 | readPackageName n = case simpleParse n of 347 | Just p -> return p 348 | Nothing -> Left $ "Error parsing package name " ++ show n 349 | 350 | buildTarget :: PackageName -> Target -> Action () 351 | buildTarget n TargetAll = void $ askMaybeBuiltLibrary n >> askBuiltExecutables n 352 | buildTarget n TargetLib = void $ askBuiltLibrary n 353 | buildTarget n TargetAllExes = void $ askBuiltExecutables n 354 | buildTarget n (TargetExe e) = void $ askBuiltExecutable n e 355 | buildTarget n TargetAllTests = void $ askBuiltTestSuites n 356 | buildTarget n (TargetTest s) = void $ askBuiltTestSuite n s 357 | -------------------------------------------------------------------------------- /pier/src/Pier/Build/CFlags.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | module Pier.Build.CFlags 3 | ( TransitiveDeps(..) 4 | , CFlags(..) 5 | , getCFlags 6 | , ghcDefines 7 | ) where 8 | 9 | import Control.Applicative (liftA2) 10 | import Control.Monad (guard) 11 | import Data.Set (Set) 12 | import Development.Shake 13 | import Development.Shake.Classes 14 | import Distribution.PackageDescription 15 | import Distribution.System (buildOS, OS(OSX)) 16 | import Distribution.Text (display) 17 | import Distribution.Types.PkgconfigDependency 18 | import Distribution.Version (versionNumbers) 19 | import GHC.Generics (Generic(..)) 20 | 21 | import qualified Data.Set as Set 22 | 23 | import Pier.Build.Stackage 24 | import Pier.Core.Artifact 25 | 26 | data TransitiveDeps = TransitiveDeps 27 | { transitiveDBs :: Set Artifact 28 | , transitiveLibFiles :: Set Artifact 29 | , transitiveIncludeDirs :: Set Artifact 30 | , transitiveDataFiles :: Set Artifact 31 | } deriving (Show, Eq, Typeable, Generic, Hashable, Binary, NFData) 32 | 33 | instance Semigroup TransitiveDeps where 34 | (<>) = mappend 35 | 36 | instance Monoid TransitiveDeps where 37 | mempty = TransitiveDeps Set.empty Set.empty Set.empty Set.empty 38 | TransitiveDeps dbs files is datas 39 | `mappend` TransitiveDeps dbs' files' is' datas' 40 | = TransitiveDeps (dbs <> dbs') (files <> files') (is <> is') 41 | (datas <> datas') 42 | 43 | -- TODO: macros file also 44 | data CFlags = CFlags 45 | { ccFlags :: [String] 46 | , cppFlags :: [String] 47 | , cIncludeDirs :: Set Artifact 48 | , linkFlags :: [String] 49 | , linkLibs :: [String] 50 | , macFrameworks :: [String] 51 | } 52 | 53 | -- TODO: include macros file too 54 | getCFlags :: TransitiveDeps -> Artifact -> BuildInfo -> Action CFlags 55 | getCFlags deps pkgDir bi = do 56 | pkgConfFlags <- mconcat <$> mapM getPkgConfFlags (pkgconfigDepends bi) 57 | return CFlags 58 | { ccFlags = ccOptions bi ++ fst pkgConfFlags 59 | , cppFlags = cppOptions bi 60 | , cIncludeDirs = 61 | Set.fromList (map (pkgDir />) $ includeDirs bi) 62 | <> transitiveIncludeDirs deps 63 | , linkFlags = ldOptions bi ++ snd pkgConfFlags 64 | , linkLibs = extraLibs bi 65 | , macFrameworks = guard (buildOS == OSX) 66 | >> frameworks bi 67 | } 68 | 69 | -- TODO: handle version numbers too 70 | getPkgConfFlags :: PkgconfigDependency -> Action ([String], [String]) 71 | getPkgConfFlags (PkgconfigDependency name _) = liftA2 (,) 72 | (runPkgConfig [display name, "--cflags"]) 73 | (runPkgConfig [display name, "--libs"]) 74 | where 75 | runPkgConfig = fmap words . runCommandStdout . prog "pkg-config" 76 | 77 | 78 | -- | Definitions that GHC provides by default 79 | ghcDefines :: InstalledGhc -> [String] 80 | ghcDefines ghc = ["-D__GLASGOW_HASKELL__=" ++ 81 | cppVersion (ghcInstalledVersion ghc)] 82 | where 83 | cppVersion v = case versionNumbers v of 84 | (v1:v2:_) -> show v1 ++ if v2 < 10 then '0':show v2 else show v2 85 | _ -> error $ "cppVersion: " ++ display v 86 | 87 | 88 | -------------------------------------------------------------------------------- /pier/src/Pier/Build/Components.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | module Pier.Build.Components 3 | ( buildPackageRules 4 | , askBuiltLibrary 5 | , askMaybeBuiltLibrary 6 | , askBuiltExecutables 7 | , askBuiltExecutable 8 | , askBuiltTestSuite 9 | , askBuiltTestSuites 10 | , BuiltBinary(..) 11 | ) 12 | where 13 | 14 | import Control.Applicative (liftA2) 15 | import Control.Monad (filterM, (>=>)) 16 | import Data.List (find) 17 | import Data.Maybe (fromMaybe) 18 | import Development.Shake 19 | import Development.Shake.Classes 20 | import Development.Shake.FilePath hiding (exe) 21 | import Distribution.Package 22 | import Distribution.PackageDescription 23 | import Distribution.System (buildOS, OS(..)) 24 | import Distribution.Text 25 | import GHC.Generics hiding (packageName) 26 | 27 | import qualified Data.Map as Map 28 | import qualified Data.Set as Set 29 | import qualified Distribution.InstalledPackageInfo as IP 30 | 31 | import Pier.Build.Config 32 | import Pier.Build.ConfiguredPackage 33 | import Pier.Build.Executable 34 | import Pier.Build.CFlags 35 | import Pier.Build.Stackage 36 | import Pier.Build.TargetInfo 37 | import Pier.Core.Artifact 38 | import Pier.Core.Persistent 39 | 40 | 41 | buildPackageRules :: Rules () 42 | buildPackageRules = do 43 | addPersistent buildLibrary 44 | addPersistent getBuiltinLib 45 | addPersistent buildExecutables 46 | addPersistent buildExecutable 47 | addPersistent buildTestSuites 48 | addPersistent buildTestSuite 49 | 50 | newtype BuiltLibraryQ = BuiltLibraryQ PackageName 51 | deriving (Typeable, Eq, Generic, Hashable, Binary, NFData) 52 | type instance RuleResult BuiltLibraryQ = Maybe BuiltLibrary 53 | 54 | instance Show BuiltLibraryQ where 55 | show (BuiltLibraryQ p) = "Library " ++ display p 56 | 57 | 58 | -- ghc --package-db .../text-1234.pkg/db --package text-1234 59 | data BuiltLibrary = BuiltLibrary 60 | { builtPackageId :: PackageIdentifier 61 | , builtPackageTrans :: TransitiveDeps 62 | } 63 | deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic) 64 | 65 | askBuiltLibraries :: [PackageName] -> Action [BuiltLibrary] 66 | askBuiltLibraries = flip forP askBuiltLibrary 67 | 68 | askMaybeBuiltLibrary :: PackageName -> Action (Maybe BuiltLibrary) 69 | askMaybeBuiltLibrary pkg = askPersistent (BuiltLibraryQ pkg) 70 | 71 | askBuiltLibrary :: PackageName -> Action BuiltLibrary 72 | askBuiltLibrary pkg = askMaybeBuiltLibrary pkg >>= helper 73 | where 74 | helper Nothing = error $ "buildFromDesc: " ++ display pkg 75 | ++ " does not have a buildable library" 76 | helper (Just lib) = return lib 77 | 78 | 79 | data BuiltDeps = BuiltDeps [PackageIdentifier] TransitiveDeps 80 | deriving Show 81 | 82 | askBuiltDeps 83 | :: [PackageName] 84 | -> Action BuiltDeps 85 | askBuiltDeps pkgs = do 86 | deps <- askBuiltLibraries pkgs 87 | return $ BuiltDeps (dedup $ map builtPackageId deps) 88 | (foldMap builtPackageTrans deps) 89 | where 90 | dedup = Set.toList . Set.fromList 91 | 92 | buildLibrary :: BuiltLibraryQ -> Action (Maybe BuiltLibrary) 93 | buildLibrary (BuiltLibraryQ pkg) = 94 | getConfiguredPackage pkg >>= \case 95 | Left p -> Just . BuiltLibrary p <$> askBuiltinLibrary 96 | (packageIdToUnitId p) 97 | Right confd 98 | | Just lib <- library (confdDesc confd) 99 | , let bi = libBuildInfo lib 100 | , buildable bi -> Just <$> do 101 | deps <- askBuiltDeps $ targetDepNames bi 102 | buildLibraryFromDesc deps confd lib 103 | | otherwise -> return Nothing 104 | where 105 | packageIdToUnitId :: PackageId -> UnitId 106 | packageIdToUnitId = mkUnitId . display 107 | 108 | getBuiltinLib :: BuiltinLibraryR -> Action TransitiveDeps 109 | getBuiltinLib (BuiltinLibraryR p) = do 110 | conf <- askConfig 111 | let ghc = configGhc conf 112 | result <- runCommandStdout 113 | $ ghcPkgProg ghc 114 | ["describe" , display p] 115 | info <- case IP.parseInstalledPackageInfo result of 116 | IP.ParseFailed err -> error (show err) 117 | IP.ParseOk _ info -> return info 118 | deps <- mapM askBuiltinLibrary $ IP.depends info 119 | let paths f = Set.fromList . map (parseGlobalPackagePath ghc) 120 | . f $ info 121 | return $ mconcat deps <> TransitiveDeps 122 | { transitiveDBs = Set.empty 123 | -- Don't bother tracking compile-time files for built-in 124 | -- libraries, since they're already provided implicitly 125 | -- by `ghcProg`. 126 | , transitiveLibFiles = Set.empty 127 | , transitiveIncludeDirs = paths IP.includeDirs 128 | -- Make dynamic libraries available at runtime, 129 | -- falling back to the regular dir if it's not set 130 | -- (usually these will be the same). 131 | , transitiveDataFiles = paths IP.libraryDirs 132 | <> paths IP.libraryDynDirs 133 | } 134 | 135 | askBuiltinLibrary :: UnitId -> Action TransitiveDeps 136 | askBuiltinLibrary = askPersistent . BuiltinLibraryR 137 | 138 | newtype BuiltinLibraryR = BuiltinLibraryR UnitId 139 | deriving (Typeable, Eq, Generic, Hashable, Binary, NFData) 140 | type instance RuleResult BuiltinLibraryR = TransitiveDeps 141 | 142 | instance Show BuiltinLibraryR where 143 | show (BuiltinLibraryR p) = "Library " ++ display p ++ " (built-in)" 144 | 145 | 146 | buildLibraryFromDesc 147 | :: BuiltDeps 148 | -> ConfiguredPackage 149 | -> Library 150 | -> Action BuiltLibrary 151 | buildLibraryFromDesc deps@(BuiltDeps _ transDeps) confd lib = do 152 | let pkg = package $ confdDesc confd 153 | conf <- askConfig 154 | let ghc = configGhc conf 155 | let lbi = libBuildInfo lib 156 | tinfo <- getTargetInfo confd lbi (TargetLibrary $ exposedModules lib) 157 | transDeps ghc 158 | maybeLib <- if null $ exposedModules lib 159 | then return Nothing 160 | else do 161 | let hiDir = "hi" 162 | let oDir = "o" 163 | let libHSName = "HS" ++ display (packageName pkg) 164 | let dynLibFile = "lib" ++ libHSName 165 | ++ "-ghc" ++ display (ghcVersion $ plan conf) 166 | <.> dynExt 167 | (hiDir', dynLib) <- runCommand 168 | (liftA2 (,) (output hiDir) (output dynLibFile)) 169 | $ message (display pkg ++ ": building library") 170 | <> ghcCommand ghc deps confd tinfo 171 | (ghcOptions conf ++ 172 | [ "-this-unit-id", display pkg 173 | , "-hidir", hiDir 174 | , "-hisuf", "dyn_hi" 175 | , "-osuf", "dyn_o" 176 | , "-odir", oDir 177 | , "-shared", "-dynamic" 178 | , "-o", dynLibFile 179 | ]) 180 | return $ Just (libHSName, lib, dynLib, hiDir') 181 | (pkgDb, libFiles) <- registerPackage ghc pkg lbi 182 | (targetCFlags tinfo) maybeLib 183 | deps 184 | let linkerData = maybe Set.empty (\(_,_,dyn,_) -> Set.singleton dyn) 185 | maybeLib 186 | transInstallIncludes <- collectInstallIncludes (confdSourceDir confd) lbi 187 | return $ BuiltLibrary pkg 188 | $ transDeps <> TransitiveDeps 189 | { transitiveDBs = Set.singleton pkgDb 190 | , transitiveLibFiles = Set.singleton libFiles 191 | , transitiveIncludeDirs = 192 | maybe Set.empty Set.singleton transInstallIncludes 193 | , transitiveDataFiles = linkerData 194 | -- TODO: just the lib 195 | <> Set.singleton libFiles 196 | } 197 | 198 | 199 | -- TODO: double-check no two executables with the same name 200 | 201 | newtype BuiltExecutablesQ = BuiltExecutablesQ PackageName 202 | deriving (Typeable, Eq, Generic, Hashable, Binary, NFData) 203 | type instance RuleResult BuiltExecutablesQ = [BuiltBinary] 204 | instance Show BuiltExecutablesQ where 205 | show (BuiltExecutablesQ p) = "Executables from " ++ display p 206 | 207 | askBuiltExecutables :: PackageName -> Action [BuiltBinary] 208 | askBuiltExecutables = askPersistent . BuiltExecutablesQ 209 | 210 | data BuiltTestSuiteQ = BuiltTestSuiteQ PackageName String 211 | deriving (Typeable, Eq, Generic, Hashable, Binary, NFData) 212 | type instance RuleResult BuiltTestSuiteQ = BuiltBinary 213 | 214 | instance Show BuiltTestSuiteQ where 215 | show (BuiltTestSuiteQ p s) = "TestSuite " ++ s ++ " from " ++ display p 216 | 217 | askBuiltTestSuite :: PackageName -> String -> Action BuiltBinary 218 | askBuiltTestSuite p e = askPersistent $ BuiltTestSuiteQ p e 219 | 220 | buildExecutables :: BuiltExecutablesQ -> Action [BuiltBinary] 221 | buildExecutables (BuiltExecutablesQ p) = getConfiguredPackage p >>= \case 222 | Left _ -> return [] 223 | Right confd -> 224 | mapM (buildBinaryFromPkg confd . exeSpec) 225 | . filter (buildable . buildInfo) 226 | $ executables (confdDesc confd) 227 | 228 | -- TODO: error if not buildable? 229 | buildExecutable :: BuiltExecutableQ -> Action BuiltBinary 230 | buildExecutable (BuiltExecutableQ p e) = getConfiguredPackage p >>= \case 231 | Left pid -> error $ "Built-in package " ++ display pid 232 | ++ " has no executables" 233 | Right confd 234 | | Just exe <- find ((== e) . display . exeName) (executables $ confdDesc confd) 235 | -> buildBinaryFromPkg confd (exeSpec exe) 236 | | otherwise -> error $ "Package " ++ display (packageId confd) 237 | ++ " has no executable named " ++ e 238 | 239 | data BinarySpec = BinarySpec 240 | { binaryTypeName :: String 241 | , binaryName :: String 242 | , binaryPath :: FilePath 243 | , binaryBuildInfo :: BuildInfo 244 | } 245 | 246 | exeSpec :: Executable -> BinarySpec 247 | exeSpec e = BinarySpec 248 | { binaryTypeName = "executable" 249 | , binaryName = display $ exeName e 250 | , binaryPath = modulePath e 251 | , binaryBuildInfo = buildInfo e 252 | } 253 | 254 | testSpec :: TestSuite -> Action BinarySpec 255 | testSpec t@TestSuite { testInterface = TestSuiteExeV10 _ path } 256 | = return BinarySpec 257 | { binaryTypeName = "test-suite" 258 | , binaryName = display $ testName t 259 | , binaryPath = path 260 | , binaryBuildInfo = testBuildInfo t 261 | } 262 | testSpec t = fail $ "Unknown test type " ++ show (testInterface t) 263 | ++ " for test " ++ display (testName t) 264 | 265 | buildBinaryFromPkg 266 | :: ConfiguredPackage 267 | -> BinarySpec 268 | -> Action BuiltBinary 269 | buildBinaryFromPkg confd bin = do 270 | let desc = confdDesc confd 271 | deps@(BuiltDeps _ transDeps) 272 | <- askBuiltDeps $ exeDepNames desc (binaryBuildInfo bin) 273 | conf <- askConfig 274 | let ghc = configGhc conf 275 | let out = "bin" binaryName bin 276 | tinfo <- getTargetInfo confd (binaryBuildInfo bin) (TargetBinary $ binaryPath bin) 277 | transDeps ghc 278 | result <- runCommandOutput out 279 | $ message (display (package desc) ++ ": building " 280 | ++ binaryTypeName bin ++ " " ++ binaryName bin) 281 | <> ghcCommand ghc deps confd tinfo 282 | (ghcOptions conf ++ 283 | [ "-o", out 284 | , "-hidir", "hi" 285 | , "-odir", "o" 286 | , "-dynamic" 287 | , "-threaded" 288 | ]) 289 | return BuiltBinary 290 | { builtBinary = result 291 | , builtBinaryDataFiles = foldr Set.insert (transitiveDataFiles transDeps) 292 | (confdDataFiles confd) 293 | } 294 | 295 | newtype BuiltTestSuitesQ = BuiltTestSuitesQ PackageName 296 | deriving (Typeable, Eq, Generic, Hashable, Binary, NFData) 297 | type instance RuleResult BuiltTestSuitesQ = [BuiltBinary] 298 | instance Show BuiltTestSuitesQ where 299 | show (BuiltTestSuitesQ p) = "Test suites from " ++ display p 300 | 301 | askBuiltTestSuites :: PackageName -> Action [BuiltBinary] 302 | askBuiltTestSuites = askPersistent . BuiltTestSuitesQ 303 | 304 | buildTestSuites :: BuiltTestSuitesQ -> Action [BuiltBinary] 305 | buildTestSuites (BuiltTestSuitesQ p) = getConfiguredPackage p >>= \case 306 | Left _ -> return [] 307 | Right confd -> 308 | mapM (testSpec >=> buildBinaryFromPkg confd) 309 | . filter (buildable . testBuildInfo) 310 | $ testSuites (confdDesc confd) 311 | 312 | -- TODO: error if not buildable? 313 | buildTestSuite :: BuiltTestSuiteQ -> Action BuiltBinary 314 | buildTestSuite (BuiltTestSuiteQ p s) = getConfiguredPackage p >>= \case 315 | Left pid -> error $ "Built-in package " ++ display pid 316 | ++ " has no test suites" 317 | Right confd 318 | | Just suite <- 319 | find ((== s) . display . testName) (testSuites $ confdDesc confd) 320 | -> testSpec suite >>= buildBinaryFromPkg confd 321 | | otherwise -> error $ "Package " ++ display (packageId confd) 322 | ++ " has no test suite named " ++ s 323 | 324 | ghcCommand 325 | :: InstalledGhc 326 | -> BuiltDeps 327 | -> ConfiguredPackage 328 | -> TargetInfo 329 | -> [String] 330 | -> Command 331 | ghcCommand ghc (BuiltDeps depPkgs transDeps) confd tinfo args 332 | = inputs (transitiveDBs transDeps) 333 | <> inputs (transitiveLibFiles transDeps) 334 | <> inputList (targetSourceInputs tinfo ++ targetOtherInputs tinfo) 335 | -- Embed extra-source-files two ways: as regular inputs, and shadowed 336 | -- directly into the working directory. 337 | -- They're needed as regular inputs so that, if they're headers, they 338 | -- stay next to c-sources (which the C include system expects). 339 | -- They're needed directly in the working directory to be available to 340 | -- template haskell splices. 341 | <> inputList (map pkgFile $ confdExtraSrcFiles confd) 342 | <> foldMap (\f -> shadow (pkgFile f) f) (confdExtraSrcFiles confd) 343 | <> ghcProg ghc (allArgs ++ map pathIn (targetSourceInputs tinfo)) 344 | where 345 | cflags = targetCFlags tinfo 346 | pkgFile = (confdSourceDir confd />) 347 | allArgs = 348 | -- Rely on GHC for module ordering and hs-boot files: 349 | [ "--make" 350 | , "-v0" 351 | , "-fPIC" 352 | , "-i" 353 | ] 354 | -- Necessary for boot files: 355 | ++ map (("-i" ++) . pathIn) (targetSourceDirs tinfo) 356 | ++ 357 | concatMap (\p -> ["-package-db", pathIn p]) 358 | (Set.toList $ transitiveDBs transDeps) 359 | ++ 360 | concat [["-package", display d] | d <- depPkgs] 361 | -- Include files which are sources 362 | ++ map (("-I" ++) . pathIn . pkgFile) (targetIncludeDirs tinfo) 363 | -- Include files which are listed as extra-src-files, and thus shadowed directly into 364 | -- the working dir: 365 | ++ map ("-I" ++) (targetIncludeDirs tinfo) 366 | ++ targetOptions tinfo 367 | ++ map ("-optP" ++) (cppFlags cflags) 368 | ++ ["-optc" ++ opt | opt <- ccFlags cflags] 369 | ++ ["-l" ++ libDep | libDep <- linkLibs cflags] 370 | ++ ["-optl" ++ f | f <- linkFlags cflags] 371 | ++ concat [["-framework", f] | f <- macFrameworks cflags] 372 | -- TODO: configurable 373 | ++ ["-O0"] 374 | -- TODO: just for local builds 375 | ++ ["-w"] 376 | ++ args 377 | 378 | registerPackage 379 | :: InstalledGhc 380 | -> PackageIdentifier 381 | -> BuildInfo 382 | -> CFlags 383 | -> Maybe ( String -- Library name for linking 384 | , Library 385 | , Artifact -- dyn lib archive 386 | , Artifact -- hi 387 | ) 388 | -> BuiltDeps 389 | -> Action (Artifact, Artifact) 390 | registerPackage ghc pkg bi cflags maybeLib (BuiltDeps depPkgs transDeps) 391 | = do 392 | let pre = "files" 393 | let depsByName = Map.fromList [(packageName p, p) | p <- depPkgs] 394 | let (collectLibInputs, libDesc) = case maybeLib of 395 | Nothing -> (createDirectoryA pre, []) 396 | Just (libHSName, lib, dynLibA, hi) -> 397 | ( shadow dynLibA (pre takeFileName (pathIn dynLibA)) 398 | <> shadow hi (pre "hi") 399 | , [ "hs-libraries: " ++ libHSName 400 | , "library-dirs: ${pkgroot}" pre 401 | , "dynamic-library-dirs: ${pkgroot}" pre 402 | , "import-dirs: ${pkgroot}" pre "hi" 403 | , "exposed-modules: " ++ 404 | unwords (map display (exposedModules lib) 405 | ++ map (renderReexport depsByName) 406 | (reexportedModules lib)) 407 | , "hidden-modules: " ++ unwords (map display $ otherModules bi) 408 | ] 409 | ) 410 | spec <- writeArtifact "spec" $ unlines $ 411 | [ "name: " ++ display (packageName pkg) 412 | , "version: " ++ display (packageVersion pkg) 413 | , "id: " ++ display pkg 414 | , "key: " ++ display pkg 415 | , "extra-libraries: " ++ unwords (linkLibs cflags) 416 | -- TODO: this list should be string-separated, and make sure 417 | -- to quote flags that contain strings (e.g. "-Wl,-E" from hslua). 418 | -- , "ld-options: " ++ unwords (linkFlags cflags) 419 | , "depends: " ++ unwords (map display depPkgs) 420 | ] 421 | ++ [ "frameworks: " ++ unwords (macFrameworks cflags) 422 | | not (null $ macFrameworks cflags) 423 | ] 424 | ++ libDesc 425 | let db = display pkg 426 | runCommand (liftA2 (,) (output db) (output pre)) 427 | $ collectLibInputs 428 | <> ghcPkgProg ghc ["init", db] 429 | <> ghcPkgProg ghc 430 | (["-v0"] 431 | ++ [ "--package-db=" ++ pathIn f 432 | | f <- Set.toList $ transitiveDBs transDeps 433 | ] 434 | ++ ["--package-db", db, "register", 435 | pathIn spec]) 436 | <> input spec 437 | <> inputs (transitiveDBs transDeps) 438 | 439 | 440 | dynExt :: String 441 | dynExt = case buildOS of 442 | OSX -> "dylib" 443 | _ -> "so" 444 | 445 | renderReexport :: 446 | Map.Map PackageName PackageIdentifier -> ModuleReexport -> String 447 | renderReexport deps re = display (moduleReexportName re) ++ " from " 448 | ++ maybe "" (\pkg -> display (originalPkg pkg) ++ ":") 449 | (moduleReexportOriginalPackage re) 450 | ++ display (moduleReexportOriginalName re) 451 | where 452 | originalPkg p = 453 | fromMaybe (error $ "Unknown package name " ++ display p 454 | ++ " for module reexport " ++ display re) 455 | $ Map.lookup p deps 456 | 457 | collectInstallIncludes :: Artifact -> BuildInfo -> Action (Maybe Artifact) 458 | collectInstallIncludes dir bi 459 | | null (installIncludes bi) = pure Nothing 460 | | otherwise = fmap Just (mapM locateHeader (installIncludes bi) 461 | >>= groupFiles dir) 462 | where 463 | -- | Returns the actual location of that header (potentially in some includeDir) 464 | -- paired with the original name of that header without the dir. 465 | locateHeader :: FilePath -> Action (FilePath, FilePath) 466 | locateHeader f = do 467 | let candidates = map (\d -> (d, dir /> d f)) ("" : includeDirs bi) 468 | existing <- filterM (doesArtifactExist . snd) candidates 469 | case existing of 470 | (d, _):_ -> return (d f, f) 471 | _ -> error $ "Couldn't locate install-include " ++ show f 472 | -------------------------------------------------------------------------------- /pier/src/Pier/Build/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Pier.Build.Config 4 | ( configRules 5 | , askConfig 6 | , Config(..) 7 | , Resolved(..) 8 | , resolvePackage 9 | ) where 10 | 11 | import Control.Exception (throw) 12 | import Control.Monad (void) 13 | import Data.Maybe (fromMaybe) 14 | import Data.Yaml 15 | import Development.Shake 16 | import Development.Shake.Classes 17 | import Distribution.Package 18 | import Distribution.Text (display) 19 | import Distribution.Version 20 | import GHC.Generics hiding (packageName) 21 | 22 | import qualified Data.HashMap.Strict as HM 23 | 24 | import Pier.Build.Package 25 | import Pier.Build.Stackage 26 | import Pier.Core.Artifact 27 | import Pier.Core.Persistent 28 | 29 | data PierYamlPath = PierYamlPath 30 | deriving (Show, Eq, Typeable, Generic) 31 | instance Hashable PierYamlPath 32 | instance Binary PierYamlPath 33 | instance NFData PierYamlPath 34 | 35 | type instance RuleResult PierYamlPath = FilePath 36 | 37 | configRules :: FilePath -> Rules () 38 | configRules f = do 39 | void $ addOracle $ \PierYamlPath -> return f 40 | void $ addPersistent $ \PierYamlQ -> do 41 | path <- askOracle PierYamlPath 42 | need [path] 43 | yamlE <- liftIO $ decodeFileEither path 44 | either (liftIO . throw) return yamlE 45 | 46 | -- TODO: rename; maybe ConfigSpec and ConfigEnv? Or Config and Env? 47 | data PierYaml = PierYaml 48 | { resolver :: PlanName 49 | , packages :: [FilePath] 50 | , extraDeps :: [PackageIdentifier] 51 | , systemGhc :: Bool 52 | , yamlGhcOptions :: [String] 53 | } deriving (Show, Eq, Typeable, Generic) 54 | instance Hashable PierYaml 55 | instance Binary PierYaml 56 | instance NFData PierYaml 57 | 58 | instance FromJSON PierYaml where 59 | parseJSON = withObject "PierYaml" $ \o -> do 60 | r <- o .: "resolver" 61 | pkgs <- o .:? "packages" 62 | ed <- o .:? "extra-deps" 63 | sysGhc <- o .:? "system-ghc" 64 | opts <- o .:? "ghc-options" 65 | return PierYaml 66 | { resolver = r 67 | , packages = fromMaybe [] pkgs 68 | , extraDeps = fromMaybe [] ed 69 | , systemGhc = fromMaybe False sysGhc 70 | , yamlGhcOptions = fromMaybe [] opts 71 | } 72 | 73 | data PierYamlQ = PierYamlQ 74 | deriving (Eq, Typeable, Generic) 75 | instance Hashable PierYamlQ 76 | instance Binary PierYamlQ 77 | instance NFData PierYamlQ 78 | 79 | type instance RuleResult PierYamlQ = PierYaml 80 | 81 | instance Show PierYamlQ where 82 | show _ = "Pier YAML configuration" 83 | 84 | data Config = Config 85 | { plan :: BuildPlan 86 | , configExtraDeps :: HM.HashMap PackageName Version 87 | , localPackages :: HM.HashMap PackageName (Artifact, Version) 88 | , configGhc :: InstalledGhc 89 | , ghcOptions :: [String] 90 | } deriving Show 91 | 92 | -- TODO: cache? 93 | askConfig :: Action Config 94 | askConfig = do 95 | yaml <- askPersistent PierYamlQ 96 | p <- askBuildPlan (resolver yaml) 97 | ghc <- askInstalledGhc p (if systemGhc yaml then SystemGhc else StackageGhc) 98 | -- TODO: don't parse local package defs twice. 99 | -- We do it again later so the full PackageDescription 100 | -- doesn't need to get saved in the cache. 101 | pkgDescs <- mapM (\f -> do 102 | let a = external f 103 | pkg <- parseCabalFileInDir a 104 | return (packageName pkg, (a, packageVersion pkg))) 105 | $ packages yaml 106 | return Config 107 | { plan = p 108 | , configGhc = ghc 109 | , localPackages = HM.fromList pkgDescs 110 | , configExtraDeps = HM.fromList [ (packageName pkg, packageVersion pkg) 111 | | pkg <- extraDeps yaml 112 | ] 113 | , ghcOptions = yamlGhcOptions yaml 114 | } 115 | 116 | data Resolved 117 | = Builtin PackageId 118 | | Hackage PackageId Flags 119 | -- TODO: flags for local packages as well 120 | | Local Artifact PackageId 121 | deriving (Show,Typeable,Eq,Generic) 122 | instance Hashable Resolved 123 | instance Binary Resolved 124 | instance NFData Resolved 125 | 126 | resolvePackage :: Config -> PackageName -> Resolved 127 | resolvePackage conf n 128 | -- TODO: nicer syntax 129 | -- core packages can't be overridden. (TODO: is this right?) 130 | | Just v <- HM.lookup n (corePackageVersions $ plan conf) 131 | = Builtin $ PackageIdentifier n v 132 | | Just (a, v) <- HM.lookup n (localPackages conf) 133 | = Local a $ PackageIdentifier n v 134 | -- Extra-deps override packages in the build plan: 135 | | Just v <- HM.lookup n (configExtraDeps conf) 136 | = Hackage (PackageIdentifier n v) HM.empty 137 | | Just p <- HM.lookup n (planPackages $ plan conf) 138 | = Hackage (PackageIdentifier n $ planPackageVersion p) 139 | (planPackageFlags p) 140 | | otherwise = error $ "Couldn't find package " ++ show (display n) 141 | -------------------------------------------------------------------------------- /pier/src/Pier/Build/ConfiguredPackage.hs: -------------------------------------------------------------------------------- 1 | module Pier.Build.ConfiguredPackage 2 | ( ConfiguredPackage(..) 3 | , getConfiguredPackage 4 | , targetDepNames 5 | , exeDepNames 6 | ) where 7 | 8 | import Data.List (nub) 9 | import Development.Shake 10 | import Distribution.Package 11 | import Distribution.PackageDescription 12 | import Distribution.Text (display) 13 | import Distribution.Version (mkVersion) 14 | 15 | import qualified Data.HashMap.Strict as HM 16 | import qualified Data.Set as Set 17 | 18 | import Pier.Build.Config 19 | import Pier.Build.Custom 20 | import Pier.Build.Package 21 | import Pier.Build.Stackage (Flags, InstalledGhc) 22 | import Pier.Core.Artifact 23 | 24 | data ConfiguredPackage = ConfiguredPackage 25 | { confdDesc :: PackageDescription 26 | , confdSourceDir :: Artifact 27 | , confdDataFiles :: Maybe Artifact 28 | , confdExtraSrcFiles :: [FilePath] -- relative to source dir 29 | } 30 | 31 | instance Package ConfiguredPackage where 32 | packageId = packageId . confdDesc 33 | 34 | -- TODO: merge with Resolved 35 | -- TODO: don't copy everything if configuring a local package? Or at least 36 | -- treat deps less coarsely? 37 | getConfiguredPackage 38 | :: PackageName -> Action (Either PackageId ConfiguredPackage) 39 | getConfiguredPackage p = do 40 | conf <- askConfig 41 | case resolvePackage conf p of 42 | Builtin pid -> return $ Left pid 43 | Hackage pid flags -> do 44 | dir <- getPackageSourceDir pid 45 | Right . addHappyAlexSourceDirs <$> getConfigured conf flags dir 46 | Local dir _ -> Right <$> getConfigured conf HM.empty dir 47 | where 48 | getConfigured :: Config -> Flags -> Artifact -> Action ConfiguredPackage 49 | getConfigured conf flags dir = do 50 | (desc, dir') <- configurePackage (plan conf) flags dir 51 | datas <- collectDataFiles (configGhc conf) desc dir' 52 | extras <- fmap (nub . concat) 53 | . mapM (matchArtifactGlob dir') 54 | . extraSrcFiles 55 | $ desc 56 | return $ ConfiguredPackage desc dir' datas extras 57 | 58 | targetDepNames :: BuildInfo -> [PackageName] 59 | targetDepNames bi = [n | Dependency n _ <- targetBuildDepends bi] 60 | 61 | -- | In older versions of Cabal, executables could use packages that were only 62 | -- explicitly depended on in the library or in other executables. Some existing 63 | -- packages still assume this behavior. 64 | exeDepNames :: PackageDescription -> BuildInfo -> [PackageName] 65 | exeDepNames desc bi 66 | | specVersion desc >= mkVersion [1,8] = targetDepNames bi 67 | | otherwise = maybe [] (const [packageName desc]) (library desc) 68 | ++ allDependencies desc 69 | 70 | allDependencies :: PackageDescription -> [PackageName] 71 | allDependencies desc = let 72 | allBis = [libBuildInfo l | Just l <- [library desc]] 73 | ++ map buildInfo (executables desc) 74 | ++ map testBuildInfo (testSuites desc) 75 | ++ map benchmarkBuildInfo (benchmarks desc) 76 | in Set.toList . Set.fromList . concatMap targetDepNames $ allBis 77 | 78 | addHappyAlexSourceDirs :: ConfiguredPackage -> ConfiguredPackage 79 | addHappyAlexSourceDirs confd 80 | | packageName (confdDesc confd) `elem` map mkPackageName ["happy", "alex"] 81 | = confd { confdDesc = addDistSourceDirs $ confdDesc confd } 82 | | otherwise = confd 83 | 84 | collectDataFiles 85 | :: InstalledGhc -> PackageDescription -> Artifact -> Action (Maybe Artifact) 86 | collectDataFiles ghc desc dir = case display (packageName desc) of 87 | "happy" -> Just <$> collectHappyDataFiles ghc dir 88 | "alex" -> Just <$> collectAlexDataFiles ghc dir 89 | _ -> collectPlainDataFiles desc dir 90 | 91 | -- TODO: should we filter out packages without data-files? 92 | -- Or short-cut it somewhere else? 93 | collectPlainDataFiles 94 | :: PackageDescription -> Artifact -> Action (Maybe Artifact) 95 | collectPlainDataFiles desc dir = do 96 | let inDir = dir /> dataDir desc 97 | if null (dataFiles desc) 98 | then return Nothing 99 | else Just <$> do 100 | files <- concat <$> mapM (matchArtifactGlob inDir) (dataFiles desc) 101 | groupFiles inDir . map (\x -> (x,x)) $ files 102 | -------------------------------------------------------------------------------- /pier/src/Pier/Build/Custom.hs: -------------------------------------------------------------------------------- 1 | -- Hacks around Happy and Alex's custom setup scripts, which are used to 2 | -- generate the templates they use at runtime. 3 | -- 4 | -- TODO: find a more generic solution for this. 5 | module Pier.Build.Custom 6 | ( collectHappyDataFiles 7 | , collectAlexDataFiles 8 | , addDistSourceDirs 9 | ) where 10 | 11 | import Data.Char (isDigit) 12 | import Development.Shake 13 | import Development.Shake.FilePath 14 | import Distribution.PackageDescription 15 | import Distribution.Text (display) 16 | 17 | import Pier.Build.Stackage 18 | import Pier.Core.Artifact 19 | 20 | -- | Older versions of Happy and Alex were distributed with a "dist" directory 21 | -- (remnant of Cabal) that contained some bootstrapped source files. 22 | -- Add that directory to the hs-source-dirs for every executable in the package. 23 | addDistSourceDirs :: PackageDescription -> PackageDescription 24 | addDistSourceDirs pkg 25 | = pkg { executables = map addDistToExe 26 | $ executables pkg 27 | } 28 | where 29 | addDistToExe e = e { 30 | buildInfo = (buildInfo e) { 31 | hsSourceDirs = distPath (display $ exeName e) 32 | : hsSourceDirs (buildInfo e) 33 | } 34 | } 35 | distPath name = "dist/build" name name ++ "-tmp" 36 | 37 | collectHappyDataFiles 38 | :: InstalledGhc -> Artifact -> Action Artifact 39 | collectHappyDataFiles ghc dir = do 40 | as <- concat <$> sequence 41 | [ mapM (uncurry $ processTemplate ghc (dir /> "templates/GenericTemplate.hs")) 42 | templates 43 | , mapM (uncurry $ processTemplate ghc (dir /> "templates/GLR_Base.hs")) 44 | glr_base_templates 45 | , mapM (uncurry $ processTemplate ghc (dir /> "templates/GLR_Lib.hs")) 46 | glr_templates 47 | ] 48 | let files = "data-files" 49 | runCommandOutput files $ 50 | foldMap (\a -> shadow a $ files takeBaseName (pathIn a)) 51 | as 52 | where 53 | templates :: [(FilePath,[String])] 54 | templates = [ 55 | ("HappyTemplate" , []), 56 | ("HappyTemplate-ghc" , ["-DHAPPY_GHC"]), 57 | ("HappyTemplate-coerce" , ["-DHAPPY_GHC","-DHAPPY_COERCE"]), 58 | ("HappyTemplate-arrays" , ["-DHAPPY_ARRAY"]), 59 | ("HappyTemplate-arrays-ghc" , ["-DHAPPY_ARRAY","-DHAPPY_GHC"]), 60 | ("HappyTemplate-arrays-coerce" , ["-DHAPPY_ARRAY","-DHAPPY_GHC","-DHAPPY_COERCE"]), 61 | ("HappyTemplate-arrays-debug" , ["-DHAPPY_ARRAY","-DHAPPY_DEBUG"]), 62 | ("HappyTemplate-arrays-ghc-debug" , ["-DHAPPY_ARRAY","-DHAPPY_GHC","-DHAPPY_DEBUG"]), 63 | ("HappyTemplate-arrays-coerce-debug" , ["-DHAPPY_ARRAY","-DHAPPY_GHC","-DHAPPY_COERCE","-DHAPPY_DEBUG"]) 64 | ] 65 | 66 | glr_base_templates :: [(FilePath,[String])] 67 | glr_base_templates = [ 68 | ("GLR_Base" , []) 69 | ] 70 | 71 | glr_templates :: [(FilePath,[String])] 72 | glr_templates = [ 73 | ("GLR_Lib" , []), 74 | ("GLR_Lib-ghc" , ["-DHAPPY_GHC"]), 75 | ("GLR_Lib-ghc-debug" , ["-DHAPPY_GHC", "-DHAPPY_DEBUG"]) 76 | ] 77 | 78 | 79 | 80 | 81 | collectAlexDataFiles 82 | :: InstalledGhc -> Artifact -> Action Artifact 83 | collectAlexDataFiles ghc dir = do 84 | as <- concat <$> sequence 85 | [ mapM (uncurry $ processTemplate ghc (dir /> "templates/GenericTemplate.hs")) 86 | templates 87 | , mapM (uncurry $ processTemplate ghc (dir /> "templates/wrappers.hs")) 88 | wrappers 89 | ] 90 | let files = "data-files" 91 | runCommandOutput files $ 92 | foldMap (\a -> shadow a $ files takeBaseName (pathIn a)) 93 | as 94 | where 95 | templates :: [(FilePath,[String])] 96 | templates = [ 97 | ("AlexTemplate", []), 98 | ("AlexTemplate-ghc", ["-DALEX_GHC"]), 99 | ("AlexTemplate-ghc-nopred",["-DALEX_GHC", "-DALEX_NOPRED"]), 100 | ("AlexTemplate-ghc-debug", ["-DALEX_GHC","-DALEX_DEBUG"]), 101 | ("AlexTemplate-debug", ["-DALEX_DEBUG"]) 102 | ] 103 | 104 | wrappers :: [(FilePath,[String])] 105 | wrappers = [ 106 | ("AlexWrapper-basic", ["-DALEX_BASIC"]), 107 | ("AlexWrapper-basic-bytestring", ["-DALEX_BASIC_BYTESTRING"]), 108 | ("AlexWrapper-strict-bytestring", ["-DALEX_STRICT_BYTESTRING"]), 109 | ("AlexWrapper-posn", ["-DALEX_POSN"]), 110 | ("AlexWrapper-posn-bytestring", ["-DALEX_POSN_BYTESTRING"]), 111 | ("AlexWrapper-monad", ["-DALEX_MONAD"]), 112 | ("AlexWrapper-monad-bytestring", ["-DALEX_MONAD_BYTESTRING"]), 113 | ("AlexWrapper-monadUserState", ["-DALEX_MONAD", "-DALEX_MONAD_USER_STATE"]), 114 | ("AlexWrapper-monadUserState-bytestring", ["-DALEX_MONAD_BYTESTRING", "-DALEX_MONAD_USER_STATE"]), 115 | ("AlexWrapper-gscan", ["-DALEX_GSCAN"]) 116 | ] 117 | 118 | processTemplate 119 | :: InstalledGhc -> Artifact -> String -> [String] -> Action Artifact 120 | processTemplate ghc baseTemplate outFile args = do 121 | a <- runCommandOutput outFile 122 | $ ghcProg ghc 123 | (["-o", outFile, "-E", "-cpp", pathIn baseTemplate] ++ args) 124 | <> input baseTemplate 125 | writeArtifact outFile . unlines . map mungeLinePragma . lines 126 | =<< readArtifact a 127 | 128 | 129 | -------------------------------------------------------------------------------- 130 | -- Copied from Setup.hs scripts for happy/alex 131 | 132 | -- hack to turn cpp-style '# 27 "GenericTemplate.hs"' into 133 | -- '{-# LINE 27 "GenericTemplate.hs" #-}'. 134 | mungeLinePragma :: String -> String 135 | mungeLinePragma line = case symbols line of 136 | syms | Just prag <- getLinePrag syms -> prag 137 | -- Also convert old-style CVS lines, no idea why we do this... 138 | ("--":"$":"Id":":":_) -> filter (/='$') line 139 | ( "$":"Id":":":_) -> filter (/='$') line 140 | _ -> line 141 | where 142 | getLinePrag :: [String] -> Maybe String 143 | getLinePrag ("#" : n : string : rest) 144 | | length rest <= 1 -- clang puts an extra field 145 | , length string >= 2 && head string == '"' && last string == '"' 146 | , all isDigit n 147 | = Just $ "{-# LINE " ++ n ++ " " ++ string ++ " #-}" 148 | getLinePrag _ = Nothing 149 | 150 | symbols :: String -> [String] 151 | symbols cs = case lex cs of 152 | (sym, cs'):_ | not (null sym) -> sym : symbols cs' 153 | _ -> [] 154 | 155 | -------------------------------------------------------------------------------- /pier/src/Pier/Build/Executable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | module Pier.Build.Executable 3 | ( askBuiltExecutable 4 | , BuiltExecutableQ(..) 5 | , BuiltBinary(..) 6 | , progBinary 7 | ) where 8 | 9 | import Data.Set (Set) 10 | import Development.Shake 11 | import Development.Shake.Classes 12 | import Distribution.Package (PackageName) 13 | import Distribution.Text (display) 14 | import GHC.Generics (Generic(..)) 15 | 16 | import Pier.Core.Artifact 17 | import Pier.Core.Persistent 18 | import Pier.Orphans () 19 | 20 | data BuiltBinary = BuiltBinary 21 | { builtBinary :: Artifact 22 | , builtBinaryDataFiles :: Set Artifact 23 | } deriving (Show, Eq, Generic, Hashable, Binary, NFData) 24 | 25 | 26 | data BuiltExecutableQ = BuiltExecutableQ PackageName String 27 | deriving (Typeable, Eq, Generic, Hashable, Binary, NFData) 28 | type instance RuleResult BuiltExecutableQ = BuiltBinary 29 | 30 | instance Show BuiltExecutableQ where 31 | show (BuiltExecutableQ p e) = "Executable " ++ e ++ " from " ++ display p 32 | 33 | askBuiltExecutable :: PackageName -> String -> Action BuiltBinary 34 | askBuiltExecutable p e = askPersistent $ BuiltExecutableQ p e 35 | 36 | progBinary :: BuiltBinary -> [String] -> Command 37 | progBinary exe args = progA (builtBinary exe) args 38 | <> inputs (builtBinaryDataFiles exe) 39 | -------------------------------------------------------------------------------- /pier/src/Pier/Build/Module.hs: -------------------------------------------------------------------------------- 1 | module Pier.Build.Module 2 | ( findModule 3 | , findMainFile 4 | , findBootFile 5 | , sourceDirArtifacts 6 | ) where 7 | 8 | import Control.Applicative ((<|>)) 9 | import Control.Monad (guard, msum) 10 | import Control.Monad.Trans.Class (lift) 11 | import Control.Monad.Trans.Maybe 12 | import Data.List (intercalate) 13 | import Development.Shake 14 | import Distribution.ModuleName 15 | import Distribution.Package (PackageIdentifier(..), mkPackageName) 16 | import Distribution.PackageDescription 17 | import Distribution.Version (versionNumbers) 18 | import Development.Shake.FilePath 19 | import Distribution.Text (display) 20 | 21 | import qualified Data.Set as Set 22 | 23 | import Pier.Build.ConfiguredPackage 24 | import Pier.Build.Executable 25 | import Pier.Build.CFlags 26 | import Pier.Build.Stackage 27 | import Pier.Core.Artifact 28 | 29 | findModule 30 | :: InstalledGhc 31 | -> ConfiguredPackage 32 | -> CFlags 33 | -> [Artifact] -- ^ Source directory to check 34 | -> ModuleName 35 | -> Action Artifact 36 | findModule ghc confd flags paths m = do 37 | found <- runMaybeT $ genPathsModule m confd <|> 38 | msum (map (search ghc flags m) paths) 39 | maybe (error $ "Missing module " ++ display m 40 | ++ "; searched " ++ show paths) 41 | return found 42 | 43 | findMainFile 44 | :: InstalledGhc 45 | -> CFlags 46 | -> [Artifact] -- ^ Source directory to check 47 | -> FilePath 48 | -> Action Artifact 49 | findMainFile ghc flags paths f = do 50 | found <- runMaybeT $ msum $ 51 | map findFileDirectly paths ++ 52 | map (search ghc flags $ filePathToModule f) paths 53 | maybe (error $ "Missing main file " ++ f 54 | ++ "; searched " ++ show paths) 55 | return found 56 | where 57 | findFileDirectly path = do 58 | let candidate = path /> f 59 | exists candidate 60 | return candidate 61 | 62 | genPathsModule 63 | :: ModuleName -> ConfiguredPackage -> MaybeT Action Artifact 64 | genPathsModule m confd = do 65 | guard $ m == pathsModule 66 | lift $ writeArtifact ("paths" display m <.> "hs") $ unlines 67 | [ "{-# LANGUAGE CPP #-}" 68 | , "{-# LANGUAGE ImplicitPrelude #-}" 69 | , "module " ++ display m ++ " (getDataFileName, getDataDir, version) where" 70 | , "import Data.Version (Version(..))" 71 | , "version = Version " ++ show (versionNumbers 72 | $ pkgVersion pkg) 73 | ++ "" 74 | ++ " []" -- tags are deprecated 75 | , "getDataFileName :: FilePath -> IO FilePath" 76 | , "getDataFileName f = (\\d -> d ++ \"/\" ++ f) <$> getDataDir" 77 | , "getDataDir :: IO FilePath" 78 | , "getDataDir = " ++ maybe err (("return " ++) . show . pathIn) 79 | (confdDataFiles confd) 80 | ] 81 | where 82 | pkg = package (confdDesc confd) 83 | pathsModule = fromString $ "Paths_" ++ map fixHyphen (display $ pkgName pkg) 84 | fixHyphen '-' = '_' 85 | fixHyphen c = c 86 | err = "error " ++ show ("Missing data files from package " ++ display pkg) 87 | 88 | 89 | search 90 | :: InstalledGhc 91 | -> CFlags 92 | -> ModuleName 93 | -> Artifact -- ^ Source directory to check 94 | -> MaybeT Action Artifact 95 | search ghc flags m srcDir 96 | = genHsc2hs <|> 97 | genHappy "y" <|> 98 | genHappy "ly" <|> 99 | genAlex "x" <|> 100 | genC2hs <|> 101 | existing "lhs" <|> 102 | existing "hs" 103 | where 104 | existing ext = let f = srcDir /> toFilePath m <.> ext 105 | in exists f >> return f 106 | 107 | genHappy ext = do 108 | let yFile = srcDir /> toFilePath m <.> ext 109 | exists yFile 110 | let relOutput = toFilePath m <.> "hs" 111 | happy <- lift $ askBuiltExecutable (mkPackageName "happy") "happy" 112 | lift . runCommandOutput relOutput 113 | $ progBinary happy 114 | ["-agc", "-o", relOutput, pathIn yFile] 115 | <> input yFile 116 | 117 | genHsc2hs = do 118 | let hsc = srcDir /> toFilePath m <.> "hsc" 119 | exists hsc 120 | let relOutput = toFilePath m <.> "hs" 121 | lift $ runCommandOutput relOutput 122 | $ hsc2hsProg ghc 123 | (["-o", relOutput 124 | , pathIn hsc 125 | ] 126 | ++ ["--cflag=" ++ f | f <- ccFlags flags 127 | ++ cppFlags flags] 128 | ++ ["-I" ++ pathIn f | f <- Set.toList $ cIncludeDirs flags] 129 | ++ ghcDefines ghc) 130 | <> input hsc <> inputs (cIncludeDirs flags) 131 | 132 | genAlex ext = do 133 | let xFile = srcDir /> toFilePath m <.> ext 134 | exists xFile 135 | let relOutput = toFilePath m <.> "hs" 136 | -- TODO: mkPackageName doesn't exist in older ones 137 | alex <- lift $ askBuiltExecutable (mkPackageName "alex") "alex" 138 | lift . runCommandOutput relOutput 139 | $ progBinary alex 140 | ["-g", "-o", relOutput, pathIn xFile] 141 | <> input xFile 142 | genC2hs = do 143 | let chsFile = srcDir /> toFilePath m <.> "chs" 144 | exists chsFile 145 | let relOutput = toFilePath m <.> "hs" 146 | c2hs <- lift $ askBuiltExecutable (mkPackageName "c2hs") "c2hs" 147 | lift . runCommandOutput relOutput 148 | $ input chsFile 149 | <> inputs (cIncludeDirs flags) 150 | <> progBinary c2hs 151 | (["-o", relOutput, pathIn chsFile] 152 | ++ ["--include=" ++ pathIn f | f <- Set.toList (cIncludeDirs flags)] 153 | ++ ["--cppopts=" ++ f | f <- ccFlags flags ++ cppFlags flags 154 | ++ ghcDefines ghc] 155 | ) 156 | -- TODO: issue if this doesn't preserve ".lhs" vs ".hs", for example? 157 | filePathToModule :: FilePath -> ModuleName 158 | filePathToModule = fromString . intercalate "." . splitDirectories . dropExtension 159 | 160 | exists :: Artifact -> MaybeT Action () 161 | exists f = lift (doesArtifactExist f) >>= guard 162 | 163 | -- Find the "hs-boot" file corresponding to a "hs" file. 164 | findBootFile :: Artifact -> Action (Maybe Artifact) 165 | findBootFile hs = do 166 | let hsBoot = replaceArtifactExtension hs "hs-boot" 167 | bootExists <- doesArtifactExist hsBoot 168 | return $ guard bootExists >> return hsBoot 169 | 170 | sourceDirArtifacts :: Artifact -> BuildInfo -> [Artifact] 171 | sourceDirArtifacts packageSourceDir bi 172 | = map (packageSourceDir />) $ ifNullDirs $ hsSourceDirs bi 173 | 174 | -- TODO: Organize the arguments to this function better. 175 | ifNullDirs :: [FilePath] -> [FilePath] 176 | ifNullDirs [] = [""] 177 | ifNullDirs xs = xs 178 | -------------------------------------------------------------------------------- /pier/src/Pier/Build/Package.hs: -------------------------------------------------------------------------------- 1 | module Pier.Build.Package 2 | ( getPackageSourceDir 3 | , configurePackage 4 | , parseCabalFileInDir 5 | ) where 6 | 7 | import Data.List.NonEmpty (NonEmpty(..)) 8 | import Data.Semigroup 9 | import Development.Shake 10 | import Development.Shake.FilePath 11 | import Distribution.Compiler 12 | import Distribution.Package 13 | import Distribution.PackageDescription 14 | import Distribution.PackageDescription.Parsec 15 | import Distribution.System (buildOS, buildArch) 16 | import Distribution.Text (display) 17 | import Distribution.Types.CondTree (CondBranch(..)) 18 | import Distribution.Version (withinRange) 19 | 20 | import qualified Data.HashMap.Strict as HM 21 | 22 | import Pier.Build.Stackage 23 | import Pier.Core.Artifact 24 | import Pier.Core.Download 25 | 26 | downloadCabalPackage :: PackageIdentifier -> Action Artifact 27 | downloadCabalPackage pkg = do 28 | let n = display pkg 29 | askDownload Download 30 | { downloadName = n <.> "tar.gz" 31 | , downloadUrlPrefix = "https://hackage.haskell.org/package/" ++ n 32 | } 33 | 34 | getPackageSourceDir :: PackageIdentifier -> Action Artifact 35 | getPackageSourceDir pkg = do 36 | tarball <- downloadCabalPackage pkg 37 | runCommandOutput outDir 38 | $ message ("Unpacking " ++ display pkg) 39 | <> prog "tar" ["-xzf", pathIn tarball, "-C", takeDirectory outDir] 40 | <> input tarball 41 | where 42 | outDir = "package/raw" display pkg 43 | 44 | configurePackage :: BuildPlan -> Flags -> Artifact -> Action (PackageDescription, Artifact) 45 | configurePackage plan flags packageSourceDir = do 46 | gdesc <- parseCabalFileInDir packageSourceDir 47 | let desc = flattenToDefaultFlags plan flags gdesc 48 | let name = display (packageName desc) 49 | case buildType desc of 50 | Configure -> do 51 | let configuredDir = name 52 | configuredPackage <- runCommandOutput configuredDir 53 | $ shadow packageSourceDir configuredDir 54 | <> message ("Configuring " ++ name) 55 | <> withCwd configuredDir (progTemp (configuredDir "configure") []) 56 | let buildInfoFile = configuredPackage /> 57 | (name <.> "buildinfo") 58 | buildInfoExists <- doesArtifactExist buildInfoFile 59 | desc' <- if buildInfoExists 60 | then do 61 | hookedBI <- readHookedBuildInfoA buildInfoFile 62 | return $ updatePackageDescription hookedBI desc 63 | else return desc 64 | return (desc', configuredPackage) 65 | -- Best effort: ignore custom setup scripts. 66 | _ -> return (desc, packageSourceDir) 67 | 68 | parseCabalFileInDir :: Artifact -> Action GenericPackageDescription 69 | parseCabalFileInDir dir = do 70 | cabalFile <- findCabalFile dir 71 | cabalContents <- readArtifactB cabalFile 72 | -- TODO: better error message when parse fails; and maybe warnings too? 73 | case runParseResult $ parseGenericPackageDescription cabalContents of 74 | (_, Right pkg) -> return pkg 75 | e -> error $ show e ++ "\n" ++ show cabalContents 76 | 77 | readHookedBuildInfoA :: Artifact -> Action HookedBuildInfo 78 | readHookedBuildInfoA file = do 79 | hookedBIParse <- parseHookedBuildInfo <$> readArtifactB file 80 | case runParseResult hookedBIParse of 81 | (_,Right hookedBI) -> return hookedBI 82 | e -> error $ "Error reading buildinfo " ++ show file 83 | ++ ": " ++ show e 84 | 85 | findCabalFile :: Artifact -> Action Artifact 86 | findCabalFile dir = do 87 | cabalFiles <- matchArtifactGlob dir "*.cabal" 88 | case cabalFiles of 89 | [f] -> return (dir /> f) 90 | [] -> error $ "No *.cabal files found in " ++ show dir 91 | _ -> error $ "Multiple *.cabal files found: " ++ show cabalFiles 92 | 93 | flattenToDefaultFlags 94 | :: BuildPlan -> Flags -> GenericPackageDescription -> PackageDescription 95 | flattenToDefaultFlags plan planFlags gdesc = let 96 | desc0 = packageDescription gdesc 97 | -- Bias towards plan flags (since they override the defaults) 98 | flags = planFlags `HM.union` HM.fromList [(flagName f, flagDefault f) 99 | | f <- genPackageFlags gdesc 100 | ] 101 | in desc0 102 | -- TODO: Nothing vs Nothing? 103 | { library = resolve plan flags <$> condLibrary gdesc 104 | , executables = map (\(n, e) -> (resolve plan flags e) { exeName = n }) 105 | $ condExecutables gdesc 106 | , testSuites = map (\(n, s) -> (resolve plan flags s) { testName = n }) 107 | $ condTestSuites gdesc 108 | } 109 | 110 | resolve 111 | :: Semigroup a 112 | => BuildPlan 113 | -> HM.HashMap FlagName Bool 114 | -> CondTree ConfVar [Dependency] a 115 | -> a 116 | resolve plan flags node 117 | = sconcat 118 | $ condTreeData node :| 119 | [ resolve plan flags t 120 | | CondBranch cond ifTrue ifFalse 121 | <- condTreeComponents node 122 | , Just t <- [if isTrue plan flags cond 123 | then Just ifTrue 124 | else ifFalse]] 125 | 126 | isTrue :: BuildPlan -> HM.HashMap FlagName Bool -> Condition ConfVar -> Bool 127 | isTrue plan flags = loop 128 | where 129 | loop (Var (Flag f)) 130 | | Just x <- HM.lookup f flags = x 131 | | otherwise = error $ "Unknown flag: " ++ show f 132 | loop (Var (Impl GHC range)) = withinRange (ghcVersion plan) range 133 | loop (Var (Impl _ _)) = False 134 | loop (Var (OS os)) = os == buildOS 135 | loop (Var (Arch arch)) = arch == buildArch 136 | loop (Lit x) = x 137 | loop (CNot x) = not $ loop x 138 | loop (COr x y) = loop x || loop y 139 | loop (CAnd x y) = loop x && loop y 140 | -------------------------------------------------------------------------------- /pier/src/Pier/Build/Stackage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Pier.Build.Stackage 4 | ( buildPlanRules 5 | , askBuildPlan 6 | , askInstalledGhc 7 | , installGhcRules 8 | , InstalledGhc(..) 9 | , GhcDistro(..) 10 | , ghcProg 11 | , ghcPkgProg 12 | , hsc2hsProg 13 | , parseGlobalPackagePath 14 | , PlanName(..) 15 | , BuildPlan(..) 16 | , PlanPackage(..) 17 | , Flags 18 | ) where 19 | 20 | import Control.Exception (throw) 21 | import Data.Binary.Orphans () 22 | import Data.Monoid ((<>)) 23 | import Data.Text (Text) 24 | import Data.Yaml 25 | import Development.Shake 26 | import Development.Shake.Classes 27 | import Development.Shake.FilePath 28 | import Distribution.Package 29 | import Distribution.PackageDescription (FlagName) 30 | import Distribution.System (buildPlatform, Platform(..), Arch(..), OS(..)) 31 | import Distribution.Version 32 | import GHC.Generics 33 | 34 | import qualified Data.HashMap.Strict as HM 35 | import qualified Data.List as List 36 | import qualified Data.Set as Set 37 | import qualified Data.Text as T 38 | import qualified Distribution.Text as Cabal 39 | 40 | import Pier.Core.Artifact 41 | import Pier.Core.Download 42 | import Pier.Core.Persistent 43 | import Pier.Orphans () 44 | 45 | newtype PlanName = PlanName { renderPlanName :: String } 46 | deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic) 47 | 48 | instance FromJSON PlanName where 49 | parseJSON = fmap PlanName . parseJSON 50 | 51 | data BuildPlan = BuildPlan 52 | { corePackageVersions :: HM.HashMap PackageName Version 53 | , planPackages :: HM.HashMap PackageName PlanPackage 54 | , ghcVersion :: Version 55 | } deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic) 56 | 57 | data PlanPackage = PlanPackage 58 | { planPackageVersion :: Version 59 | , planPackageFlags :: Flags 60 | } deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Generic) 61 | 62 | type Flags = HM.HashMap FlagName Bool 63 | 64 | instance FromJSON BuildPlan where 65 | parseJSON = withObject "Plan" $ \o -> do 66 | sys <- o .: "system-info" 67 | coreVersions <- sys .: "core-packages" 68 | ghcVers <- sys .: "ghc-version" 69 | pkgs <- o .: "packages" 70 | return BuildPlan { corePackageVersions = coreVersions 71 | , planPackages = pkgs 72 | , ghcVersion = ghcVers 73 | } 74 | 75 | instance FromJSON PlanPackage where 76 | parseJSON = withObject "PlanPackage" $ \o -> 77 | PlanPackage <$> (o .: "version") <*> ((o .: "constraints") >>= (.: "flags")) 78 | 79 | buildPlanRules :: Rules () 80 | buildPlanRules = addPersistent $ \(ReadPlan planName) -> do 81 | f <- askDownload Download 82 | { downloadName = renderPlanName planName <.> "yaml" 83 | , downloadUrlPrefix = planUrlPrefix planName 84 | } 85 | cs <- readArtifactB f 86 | case decodeEither' cs of 87 | Left err -> throw err 88 | Right x -> return x 89 | 90 | planUrlPrefix :: PlanName -> String 91 | planUrlPrefix (PlanName name) 92 | | "lts-" `List.isPrefixOf` name = ltsBuildPlansUrl 93 | | "nightly-" `List.isPrefixOf` name = nightlyBuildPlansUrl 94 | | otherwise = error $ "Unrecognized plan name " ++ show name 95 | where 96 | ltsBuildPlansUrl = "https://raw.githubusercontent.com/fpco/lts-haskell/master/" 97 | nightlyBuildPlansUrl = "https://raw.githubusercontent.com/fpco/stackage-nightly/master/" 98 | 99 | newtype ReadPlan = ReadPlan PlanName 100 | deriving (Typeable,Eq,Hashable,Binary,NFData,Generic) 101 | type instance RuleResult ReadPlan = BuildPlan 102 | 103 | instance Show ReadPlan where 104 | show (ReadPlan p) = "Read build plan: " ++ renderPlanName p 105 | 106 | askBuildPlan :: PlanName -> Action BuildPlan 107 | askBuildPlan = askPersistent . ReadPlan 108 | 109 | 110 | data InstalledGhcQ = InstalledGhcQ GhcDistro Version [PackageName] 111 | deriving (Typeable, Eq, Hashable, Binary, NFData, Generic) 112 | 113 | data GhcDistro 114 | = SystemGhc 115 | | StackageGhc 116 | deriving (Show, Typeable, Eq, Hashable, Binary, NFData, Generic) 117 | 118 | instance Show InstalledGhcQ where 119 | show (InstalledGhcQ d v pn) = "GHC" 120 | ++ " " ++ show d 121 | ++ ", version " ++ Cabal.display v 122 | ++ ", built-in packages " 123 | ++ List.intercalate ", " (map Cabal.display pn) 124 | 125 | -- | TODO: make the below functions that use Version take InstalledGhc directly instead 126 | data InstalledGhc = InstalledGhc 127 | { ghcLibRoot :: Artifact 128 | , ghcInstalledVersion :: Version 129 | } deriving (Show, Typeable, Eq, Generic) 130 | instance Hashable InstalledGhc 131 | instance Binary InstalledGhc 132 | instance NFData InstalledGhc 133 | 134 | type instance RuleResult InstalledGhcQ = InstalledGhc 135 | 136 | globalPackageDb :: InstalledGhc -> Artifact 137 | globalPackageDb ghc = ghcLibRoot ghc /> packageConfD 138 | 139 | packageConfD :: String 140 | packageConfD = "package.conf.d" 141 | 142 | askInstalledGhc :: BuildPlan -> GhcDistro -> Action InstalledGhc 143 | askInstalledGhc plan distro 144 | = askPersistent $ InstalledGhcQ distro (ghcVersion plan) 145 | $ HM.keys $ corePackageVersions plan 146 | 147 | -- | Convert @${pkgroot}@ prefixes, for utilities like hsc2hs that don't 148 | -- see packages directly 149 | -- 150 | parseGlobalPackagePath :: InstalledGhc -> FilePath -> Artifact 151 | parseGlobalPackagePath ghc f 152 | | Just f' <- List.stripPrefix "${pkgroot}/" f 153 | = ghcLibRoot ghc /> f' 154 | | otherwise = external f 155 | 156 | ghcBinDir :: InstalledGhc -> Artifact 157 | ghcBinDir ghc = ghcLibRoot ghc /> "bin" 158 | 159 | ghcProg :: InstalledGhc -> [String] -> Command 160 | ghcProg ghc args = 161 | progA (ghcBinDir ghc /> "ghc") 162 | (["-B" ++ pathIn (ghcLibRoot ghc) 163 | , "-clear-package-db" 164 | , "-hide-all-packages" 165 | , "-package-db=" ++ pathIn (globalPackageDb ghc) 166 | ] ++ args) 167 | <> input (ghcLibRoot ghc) 168 | <> input (globalPackageDb ghc) 169 | 170 | ghcPkgProg :: InstalledGhc -> [String] -> Command 171 | ghcPkgProg ghc args = 172 | progA (ghcBinDir ghc /> "ghc-pkg") 173 | ([ "--global-package-db=" ++ pathIn (globalPackageDb ghc) 174 | , "--no-user-package-db" 175 | , "--no-user-package-conf" 176 | ] ++ args) 177 | <> input (ghcLibRoot ghc) 178 | <> input (globalPackageDb ghc) 179 | 180 | hsc2hsProg :: InstalledGhc -> [String] -> Command 181 | hsc2hsProg ghc args = 182 | progA (ghcBinDir ghc /> "hsc2hs") 183 | (("--template=${TMPDIR}/" ++ pathIn template) : args) 184 | <> input template 185 | where 186 | template = ghcLibRoot ghc /> "template-hsc.h" 187 | 188 | installGhcRules :: Rules () 189 | installGhcRules = addPersistent installGhc 190 | 191 | installGhc :: InstalledGhcQ -> Action InstalledGhc 192 | installGhc (InstalledGhcQ distro version corePkgs) = do 193 | installed <- case distro of 194 | StackageGhc -> downloadAndInstallGHC version 195 | SystemGhc -> getSystemGhc version 196 | fixed <- makeRelativeGlobalDb corePkgs installed 197 | runCommand_ $ ghcPkgProg fixed ["check"] 198 | return fixed 199 | 200 | getSystemGhc :: Version -> Action InstalledGhc 201 | getSystemGhc version = do 202 | path <- fmap (head . words) . runCommandStdout 203 | $ prog (versionedGhc version) ["--print-libdir"] 204 | return $ InstalledGhc (external path) version 205 | 206 | data DownloadInfo = DownloadInfo 207 | { downloadUrl :: String 208 | -- TODO: use these 209 | , _contentLength :: Int 210 | , _sha1 :: String 211 | } 212 | 213 | instance FromJSON DownloadInfo where 214 | parseJSON = withObject "DownloadInfo" $ \o -> 215 | DownloadInfo <$> o .: "url" 216 | <*> o .: "content-length" 217 | <*> o .: "sha1" 218 | 219 | -- TODO: multiple OSes, configure-env 220 | 221 | newtype StackSetup = StackSetup { ghcVersions :: HM.HashMap Version DownloadInfo } 222 | 223 | instance FromJSON StackSetup where 224 | parseJSON = withObject "StackSetup" $ \o -> do 225 | ghc <- o .: "ghc" 226 | StackSetup <$> (ghc .: platformKey) 227 | 228 | -- TODO: make this more configurable (eventually, using 229 | -- `LocalBuildInfo.hostPlatform` to help support cross-compilation) 230 | platformKey :: Text 231 | platformKey = case buildPlatform of 232 | Platform I386 Linux -> "linux32" 233 | Platform X86_64 Linux -> "linux64" 234 | Platform I386 OSX -> "macosx" 235 | Platform X86_64 OSX -> "macosx" 236 | Platform I386 FreeBSD -> "freebsd32" 237 | Platform X86_64 FreeBSD -> "freebsd64" 238 | Platform I386 OpenBSD -> "openbsd32" 239 | Platform X86_64 OpenBSD -> "openbsd64" 240 | Platform I386 Windows -> "windows32" 241 | Platform X86_64 Windows -> "windows64" 242 | Platform Arm Linux -> "linux-armv7" 243 | _ -> error $ "Unrecognized platform: " ++ Cabal.display buildPlatform 244 | 245 | setupUrl :: String 246 | setupUrl = "https://raw.githubusercontent.com/fpco/stackage-content/master/stack" 247 | 248 | downloadAndInstallGHC 249 | :: Version -> Action InstalledGhc 250 | downloadAndInstallGHC version = do 251 | setupYaml <- askDownload Download 252 | { downloadName = "stack-setup-2.yaml" 253 | , downloadUrlPrefix = setupUrl 254 | } 255 | -- TODO: don't re-parse the yaml for every GHC version 256 | cs <- readArtifactB setupYaml 257 | download <- case decodeEither' cs of 258 | Left err -> throw err 259 | Right x 260 | | Just download <- HM.lookup version (ghcVersions x) 261 | -> pure download 262 | | otherwise -> fail $ "Couldn't find GHC version" ++ Cabal.display version 263 | -- TODO: reenable this once we've fixed the issue with nondetermistic 264 | -- temp file locations. 265 | -- rerunIfCleaned 266 | let (url, f) = splitFileName $ downloadUrl download 267 | tar <- askDownload Download 268 | { downloadName = f 269 | , downloadUrlPrefix = url 270 | } 271 | -- TODO: check file size and sha1 272 | -- GHC's configure step requires an absolute prefix. 273 | -- We'll install it explicitly in ${TMPDIR}, but that puts explicit references 274 | -- to those paths in the package DB. So we'll then generate a new DB with 275 | -- relative paths. 276 | let installDir = "ghc-install" 277 | let unpackedDir = versionedGhc version 278 | installed <- runCommand 279 | (output installDir) 280 | $ message "Unpacking GHC" 281 | <> input tar 282 | <> prog "tar" ["-xJf", pathIn tar] 283 | <> withCwd unpackedDir 284 | (message "Installing GHC locally" 285 | <> progTemp (unpackedDir "configure") 286 | ["--prefix=${TMPDIR}/" ++ installDir] 287 | <> prog "make" ["install"]) 288 | return InstalledGhc { ghcLibRoot = installed /> "lib" versionedGhc version 289 | , ghcInstalledVersion = version 290 | } 291 | 292 | versionedGhc :: Version -> String 293 | versionedGhc version = "ghc-" ++ Cabal.display version 294 | 295 | makeRelativeGlobalDb :: [PackageName] -> InstalledGhc -> Action InstalledGhc 296 | makeRelativeGlobalDb corePkgs ghc = do 297 | let corePkgsSet = Set.fromList corePkgs 298 | -- List all packages, excluding Cabal which stack doesn't consider a "core" 299 | -- package. 300 | -- TODO: if our package ids included a hash, this wouldn't be as big a problem 301 | -- because two versions of the same package could exist simultaneously. 302 | builtinPackages <- fmap (filter ((`Set.member` corePkgsSet) . mkPackageName) 303 | . words) 304 | . runCommandStdout 305 | $ ghcPkgProg ghc 306 | ["list", "--global", "--names-only", 307 | "--simple-output" ] 308 | let makePkgConf pkg = do 309 | desc <- runCommandStdout 310 | $ ghcPkgProg ghc ["describe", pkg] 311 | let tempRoot = parsePkgRoot desc 312 | let desc' = 313 | T.unpack 314 | . T.replace (T.pack tempRoot) 315 | (T.pack "${pkgroot}") 316 | . T.pack 317 | $ desc 318 | writeArtifact (pkg ++ ".conf") desc' 319 | confs <- mapM makePkgConf builtinPackages 320 | -- let globalRelativePackageDb = "global-packages/package-fixed.conf.d" 321 | let ghcFixed = "ghc-fixed" 322 | let db = ghcFixed packageConfD 323 | let ghcPkg = progTemp (ghcFixed "bin/ghc-pkg") 324 | ghcDir <- runCommandOutput ghcFixed 325 | $ shadow (ghcLibRoot ghc) ghcFixed 326 | <> inputList confs 327 | <> message "Building core package database" 328 | <> prog "rm" ["-rf", db] 329 | <> ghcPkg ["init", db] 330 | <> foldMap 331 | (\conf -> ghcPkg 332 | [ "register", pathIn conf 333 | , "--global-package-db=" ++ db 334 | , "--no-user-package-db" 335 | , "--no-user-package-conf" 336 | , "--no-expand-pkgroot" 337 | , "--force" 338 | ]) 339 | confs 340 | return ghc { ghcLibRoot = ghcDir } 341 | 342 | -- TODO: this gets the TMPDIR that was used when installing; consider allowing 343 | -- that to be captured explicitly. 344 | parsePkgRoot :: String -> String 345 | parsePkgRoot desc = loop $ lines desc 346 | where 347 | loop [] = error "Couldn't parse pkgRoot: " ++ show desc 348 | loop (l:ls) 349 | | take (length prefix) l == prefix = takeDirectory 350 | $ drop (length prefix) l 351 | | otherwise = loop ls 352 | prefix = "library-dirs: " 353 | -------------------------------------------------------------------------------- /pier/src/Pier/Build/TargetInfo.hs: -------------------------------------------------------------------------------- 1 | module Pier.Build.TargetInfo 2 | ( TargetInfo(..) 3 | , TargetResult(..) 4 | , TransitiveDeps(..) 5 | , getTargetInfo 6 | ) where 7 | 8 | import Control.Monad (filterM) 9 | import Data.List (nub) 10 | import Data.Maybe (catMaybes, fromMaybe) 11 | import Development.Shake 12 | import Development.Shake.FilePath (()) 13 | import Distribution.Compiler (CompilerFlavor(GHC)) 14 | import Distribution.ModuleName 15 | import Distribution.Package (packageName) 16 | import Distribution.PackageDescription 17 | import Distribution.Text (display) 18 | import Language.Haskell.Extension 19 | 20 | import Pier.Build.CFlags 21 | import Pier.Build.ConfiguredPackage 22 | import Pier.Build.Module 23 | import Pier.Build.Stackage 24 | import Pier.Core.Artifact 25 | 26 | data TargetInfo = TargetInfo 27 | { targetCFlags :: CFlags 28 | , targetSourceInputs :: [Artifact] 29 | -- ^ Source files to pass on command line 30 | , targetOtherInputs :: [Artifact] 31 | -- ^ Other files to pass on command line 32 | , targetOptions :: [String] 33 | , targetIncludeDirs :: [FilePath] 34 | -- ^ Directories in which GHC should look for includes 35 | -- TODO: merge with CFlags? Make Artifact? 36 | , targetSourceDirs :: [Artifact] 37 | -- ^ Directories in which GHC should look for boot files 38 | , targetOtherModules :: [ModuleName] 39 | } 40 | 41 | data TargetResult 42 | = TargetBinary { targetModulePath :: FilePath } 43 | | TargetLibrary 44 | { targetExposedModules :: [ModuleName] 45 | } 46 | 47 | getTargetInfo :: 48 | ConfiguredPackage 49 | -> BuildInfo 50 | -> TargetResult 51 | -> TransitiveDeps 52 | -> InstalledGhc 53 | -> Action TargetInfo 54 | getTargetInfo confd bi result deps ghc = do 55 | let packageSourceDir = confdSourceDir confd 56 | cflags <- getCFlags deps packageSourceDir bi 57 | let allOptions = map ("-X" ++) 58 | (display (fromMaybe Haskell98 $ defaultLanguage bi) 59 | : map display (defaultExtensions bi ++ oldExtensions bi)) 60 | ++ concat [opts | (GHC,opts) <- options bi] 61 | let srcDirs = sourceDirArtifacts packageSourceDir bi 62 | let fixDashes = map $ \c -> if c == '-' then '_' else c 63 | let pathsMod = fromString $ "Paths_" ++ fixDashes (display $ packageName confd) 64 | let allModules = otherModules bi ++ case result of 65 | TargetLibrary exposed -> exposed 66 | TargetBinary _ 67 | -- Add the Paths_ module automatically to other-modules 68 | -- of binaries. 69 | -- TODO: consider whether this is intended behavior of Cabal. 70 | -> [pathsMod | pathsMod `notElem` otherModules bi] 71 | moduleFiles <- mapM (findModule ghc confd cflags srcDirs) 72 | allModules 73 | moduleBootFiles <- catMaybes <$> mapM findBootFile moduleFiles 74 | let cFiles = map (packageSourceDir />) $ cSources bi 75 | cIncludes <- collectCIncludes (confdDesc confd) bi (packageSourceDir />) 76 | moduleMainFiles <- case result of 77 | TargetLibrary{} -> return [] 78 | TargetBinary f -> do 79 | path <- findMainFile ghc cflags srcDirs f 80 | return [path | path `notElem` moduleFiles] 81 | return TargetInfo 82 | { targetCFlags = cflags 83 | , targetSourceInputs = cFiles ++ moduleFiles ++ moduleMainFiles 84 | , targetOtherInputs = cIncludes ++ moduleBootFiles 85 | , targetOptions = allOptions 86 | , targetIncludeDirs = includeDirs bi 87 | , targetSourceDirs = srcDirs 88 | , targetOtherModules = otherModules bi 89 | } 90 | 91 | 92 | collectCIncludes :: PackageDescription -> BuildInfo -> (FilePath -> Artifact) -> Action [Artifact] 93 | collectCIncludes desc bi pkgDir = do 94 | includeInputs <- findIncludeInputs pkgDir bi 95 | extraTmps <- fmap catMaybes . mapM ((\f -> doesArtifactExist f >>= \case 96 | True -> return (Just f) 97 | False -> return Nothing) 98 | . pkgDir) 99 | $ extraTmpFiles desc 100 | return $ includeInputs ++ extraTmps 101 | 102 | findIncludeInputs :: (FilePath -> Artifact) -> BuildInfo -> Action [Artifact] 103 | findIncludeInputs pkgDir bi = filterM doesArtifactExist candidates 104 | where 105 | candidates = nub -- TODO: more efficient 106 | [ pkgDir $ d f 107 | -- TODO: maybe just installIncludes shouldn't be prefixed 108 | -- with include dir? 109 | | d <- "" : includeDirs bi 110 | , f <- includes bi ++ installIncludes bi 111 | ] 112 | -------------------------------------------------------------------------------- /pier/src/Pier/Orphans.hs: -------------------------------------------------------------------------------- 1 | -- | All-purpose module for defining orphan instances. 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | module Pier.Orphans () where 4 | 5 | import Data.Aeson.Types 6 | import Development.Shake.Classes 7 | import Distribution.Package 8 | import Distribution.PackageDescription 9 | import Distribution.Utils.ShortText 10 | import Distribution.Version 11 | 12 | import qualified Data.Map as Map 13 | import qualified Data.Set as Set 14 | import qualified Data.Text as T 15 | import qualified Distribution.Text as Cabal 16 | 17 | instance (Hashable k, Hashable v) => Hashable (Map.Map k v) where 18 | hashWithSalt k = hashWithSalt k . Map.toList 19 | 20 | instance Hashable a => Hashable (Set.Set a) where 21 | hashWithSalt k = hashWithSalt k . Set.toList 22 | 23 | instance Hashable FlagName 24 | instance Hashable PackageId 25 | instance Hashable PackageName 26 | instance Hashable ComponentId 27 | instance Hashable UnitId 28 | instance Hashable ShortText 29 | instance Hashable Version 30 | 31 | instance FromJSON Version where 32 | parseJSON = withText "Version" simpleParser 33 | 34 | instance FromJSONKey Version where 35 | fromJSONKey = cabalKeyTextParser 36 | 37 | instance FromJSON PackageName where 38 | parseJSON = withText "PackageName" simpleParser 39 | 40 | instance FromJSONKey PackageName where 41 | fromJSONKey = cabalKeyTextParser 42 | 43 | instance FromJSON FlagName where 44 | parseJSON = fmap mkFlagName . parseJSON 45 | 46 | instance FromJSONKey FlagName where 47 | fromJSONKey = FromJSONKeyText (mkFlagName . T.unpack) 48 | 49 | instance FromJSON PackageIdentifier where 50 | parseJSON = withText "PackageIdentifier" simpleParser 51 | 52 | simpleParser :: Cabal.Text a => T.Text -> Parser a 53 | simpleParser t = case Cabal.simpleParse (T.unpack t) of 54 | Just v -> pure v 55 | Nothing -> fail $ "Unable to parse: " 56 | ++ show t 57 | 58 | cabalKeyTextParser :: Cabal.Text a => FromJSONKeyFunction a 59 | cabalKeyTextParser = FromJSONKeyTextParser simpleParser 60 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | with import {}; 2 | 3 | stdenv.mkDerivation rec { 4 | name = "env"; 5 | 6 | env = buildEnv { 7 | name = name; 8 | paths = buildInputs; 9 | }; 10 | 11 | buildInputs = [ 12 | ghc 13 | zlib 14 | ]; 15 | 16 | shellHook = '' 17 | export LD_LIBRARY_PATH="${zlib}/lib/" 18 | ''; 19 | } 20 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.8 2 | 3 | nix: 4 | packages: [zlib] 5 | 6 | packages: 7 | - pier 8 | - pier-core 9 | 10 | ghc-options: 11 | "$locals": -Wall -Werror 12 | -------------------------------------------------------------------------------- /stackage/build-stackage.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -xueo pipefail 3 | 4 | IMAGE=snoyberg/stackage:nightly 5 | PLAN=lts-12.8 6 | LTSPATH=stackage/_pier/downloads/stackage/plan/$PLAN.yaml 7 | cat >stackage/pier.yaml < $PACKAGES 23 | 24 | ${PIER} build --keep-going -V $(cat $PACKAGES) 25 | -------------------------------------------------------------------------------- /stackage/list-packages.hs: -------------------------------------------------------------------------------- 1 | -- stack script --resolver lts-10.3 --package pier --package unordered-containers 2 | module Main (main) where 3 | 4 | import Control.Exception (throw) 5 | import qualified Data.HashMap.Strict as HM 6 | import Data.Yaml 7 | import Distribution.Text (display) 8 | import System.Environment (getArgs) 9 | import System.FilePath (()) 10 | 11 | import Pier.Build.Stackage 12 | 13 | main = do 14 | [path] <- getArgs 15 | decoded <- decodeFileEither path 16 | case decoded of 17 | Left e -> throw e 18 | Right plan -> 19 | putStrLn . unlines . map display . HM.keys $ planPackages plan 20 | -------------------------------------------------------------------------------- /stackage/pier.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.8 2 | system-ghc: true 3 | -------------------------------------------------------------------------------- /test-package-config.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.8 2 | 3 | # Older packages that we'd still like to test, but haven't made it 4 | # into the latest LTS. 5 | extra-deps: 6 | # Uses c2hs: 7 | - hsndfile-0.8.0 8 | # Has old `Cabal-version` and an executable with no explicit build-depends: 9 | - hsx2hs-0.14.1.3 10 | --------------------------------------------------------------------------------