diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,11 +1,83 @@ -## Unreleased changes +## 0.1.8.0 +Major changes: +* GHCJS can now be used with stackage snapshots via the new `compiler` field. +* Windows installers are now available: + [download them here](https://github.com/commercialhaskell/stack/blob/release/doc/install_and_upgrade.md#windows) + [#613](https://github.com/commercialhaskell/stack/issues/613) +* Docker integration works with non-FPComplete generated images + [#531](https://github.com/commercialhaskell/stack/issues/531) + +Other enhancements: + +* Added an `allow-newer` config option + [#922](https://github.com/commercialhaskell/stack/issues/922) + [#770](https://github.com/commercialhaskell/stack/issues/770) +* When a Hackage revision invalidates a build plan in a snapshot, trust the + snapshot [#770](https://github.com/commercialhaskell/stack/issues/770) +* Added a `stack config set resolver RESOLVER` command. Part of work on + [#115](https://github.com/commercialhaskell/stack/issues/115) +* `stack setup` can now install GHCJS on windows. See + [#1145](https://github.com/commercialhaskell/stack/issues/1145) and + [#749](https://github.com/commercialhaskell/stack/issues/749) +* `stack hpc report` command added, which generates reports for HPC tix files +* `stack ghci` now accepts all the flags accepted by `stack build`. See + [#1186](https://github.com/commercialhaskell/stack/issues/1186) +* `stack ghci` builds the project before launching GHCi. If the build fails, + optimistically launch GHCi anyway. Use `stack ghci --no-build` option to + disable [#1065](https://github.com/commercialhaskell/stack/issues/1065) +* `stack ghci` now detects and warns about various circumstances where it is + liable to fail. See + [#1270](https://github.com/commercialhaskell/stack/issues/1270) +* Added `require-docker-version` configuration option +* Packages will now usually be built along with their tests and benchmarks. See + [#1166](https://github.com/commercialhaskell/stack/issues/1166) +* Relative `local-bin-path` paths will be relative to the project's root + directory, not the current working directory. + [#1340](https://github.com/commercialhaskell/stack/issues/1340) +* `stack clean` now takes an optional `[PACKAGE]` argument for use in + multi-package projects. See + [#583](https://github.com/commercialhaskell/stack/issues/583) +* Ignore cabal_macros.h as a dependency + [#1195](https://github.com/commercialhaskell/stack/issues/1195) +* Pad timestamps and show local time in --verbose output + [#1226](https://github.com/commercialhaskell/stack/issues/1226) +* GHCi: Import all modules after loading them + [#995](https://github.com/commercialhaskell/stack/issues/995) +* Add subcommand aliases: `repl` for `ghci`, and `runhaskell` for `runghc` + [#1241](https://github.com/commercialhaskell/stack/issues/1241) +* Add typo recommendations for unknown package identifiers + [#158](https://github.com/commercialhaskell/stack/issues/158) +* Add `stack path --local-hpc-root` option +* Overhaul dependencies' haddocks copying + [#1231](https://github.com/commercialhaskell/stack/issues/1231) +* Support for extra-package-dbs in 'stack ghci' + [#1229](https://github.com/commercialhaskell/stack/pull/1229) +* `stack new` disallows package names with "words" consisting solely of numbers + [#1336](https://github.com/commercialhaskell/stack/issues/1336) +* `stack build --fast` turns off optimizations + +Bug fixes: + +* Fix: Haddocks not copied for dependencies + [#1105](https://github.com/commercialhaskell/stack/issues/1105) +* Fix: Global options did not work consistently after subcommand + [#519](https://github.com/commercialhaskell/stack/issues/519) +* Fix: 'stack ghci' doesn't notice that a module got deleted + [#1180](https://github.com/commercialhaskell/stack/issues/1180) +* Rebuild when cabal file is changed +* Fix: Paths in GHC warnings not canonicalized, nor those for packages in + subdirectories or outside the project root + [#1259](https://github.com/commercialhaskell/stack/issues/1259) +* Fix: unlisted files in tests and benchmarks trigger extraneous second build + [#838](https://github.com/commercialhaskell/stack/issues/838) + ## v0.1.6.0 Major changes: -* "stack setup" now supports building and booting GHCJS from source tarball. +* `stack setup` now supports building and booting GHCJS from source tarball. * On Windows, build directories no longer display "pretty" information (like x86_64-windows/Cabal-1.22.4.0), but rather a hash of that content. The reason is to avoid the 260 character path limitation on diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, stack +Copyright (c) 2015, Stack contributors All rights reserved. Redistribution and use in source and binary forms, with or without @@ -15,7 +15,7 @@ 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 BE LIABLE FOR ANY +DISCLAIMED. IN NO EVENT SHALL STACK 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ ## The Haskell Tool Stack [![Build Status](https://travis-ci.org/commercialhaskell/stack.svg?branch=master)](https://travis-ci.org/commercialhaskell/stack) -[![Windows build status](https://ci.appveyor.com/api/projects/status/github/commercialhaskell/stack)](https://ci.appveyor.com/project/snoyberg/stack) +[![Windows build status](https://ci.appveyor.com/api/projects/status/c1c7uvmw6x1dupcl?svg=true)](https://ci.appveyor.com/project/snoyberg/stack) [![Release](https://img.shields.io/github/release/commercialhaskell/stack.svg)](https://github.com/commercialhaskell/stack/releases) `stack` is a cross-platform program for developing Haskell @@ -22,7 +22,7 @@ Downloads are available by operating system: * [Windows](https://github.com/commercialhaskell/stack/blob/release/doc/install_and_upgrade.md#windows) -* [OS X](https://github.com/commercialhaskell/stack/blob/release/doc/install_and_upgrade.md#os-x) +* [Mac OS X](https://github.com/commercialhaskell/stack/blob/release/doc/install_and_upgrade.md#mac-os-x) * [Ubuntu](https://github.com/commercialhaskell/stack/blob/release/doc/install_and_upgrade.md#ubuntu) * [Debian](https://github.com/commercialhaskell/stack/blob/release/doc/install_and_upgrade.md#debian) * [CentOS / Red Hat / Amazon Linux](https://github.com/commercialhaskell/stack/blob/release/doc/install_and_upgrade.md#centos--red-hat--amazon-linux) diff --git a/doc/GUIDE.md b/doc/GUIDE.md --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -864,7 +864,7 @@ which contains the libraries and executables specified in the snapshot itself. Finally, GHC itself ships with a number of libraries and executables, which forms the *global* database. To get a quick idea of this, we can look at the -output of the `ghc-pkg list` command in our helloworld project: +output of the `stack exec ghc-pkg list` command in our helloworld project: ``` /home/michael/.stack/programs/x86_64-linux/ghc-7.10.2/lib/ghc-7.10.2/package.conf.d @@ -939,7 +939,7 @@ Let's look at a subset of the `stack --help` output: ``` -build Build the project(s) in this directory/configuration +build Build the package(s) in this directory/configuration install Shortcut for 'build --copy-bins' test Shortcut for 'build --test' bench Shortcut for 'build --bench' @@ -1603,7 +1603,7 @@ # Download and unpack the stack executable - mkdir -p ~/.local/bin - export PATH=$HOME/.local/bin:$PATH -- travis_retry curl -L https://github.com/commercialhaskell/stack/releases/download/v0.1.6.0/stack-0.1.6.0-linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' +- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' # This line does all of the work: installs GHC if necessary, build the library, # executables, and test suites, and runs the test suites. --no-terminal works diff --git a/doc/MAINTAINER_GUIDE.md b/doc/MAINTAINER_GUIDE.md --- a/doc/MAINTAINER_GUIDE.md +++ b/doc/MAINTAINER_GUIDE.md @@ -1,38 +1,135 @@ +## Pre-release checks + The following should be tested minimally before a release is considered good -to go. This list will likely expand over time: +to go: -* Run `etc/scripts/release.hs check` on Linux (32-bit and 64-bit), Windows (`--arch=i386` and `--arch=x86_64`), and OS X. See its - [README](../etc/scripts/README.md#release.hs) for build and invocation instructions. - This performs the following checks automatically: - * `stack install && stack clean && stack install --pedantic && stack test --flag stack:integration-tests` on Linux, Windows, and OS X, which covers: - * Self-hosting - * Unit tests - * Integration tests - * stack can install GHC - * Working tree is clean. -* Ensure that `stack --version` gives the correct version number and Git hash, and does not have a dirty tree +* Integration tests pass on a representative sample of platforms: `stack test + --flag stack:integration-tests`. The actual release script will perform a more + thorough test for every platform/variant prior to uploading, so this is just a + pre-check * stack can build the wai repo * Running `stack build` a second time on either stack or wai is a no-op -* Build something that depends on `happy` (suggestion: `hlint`), since `happy` has special logic for moving around the `dist` directory -* Make sure to bump the version number in the .cabal file and the ChangeLog appropriately -* Review man page and other documentation for any changes that need to be made. +* Build something that depends on `happy` (suggestion: `hlint`), since `happy` + has special logic for moving around the `dist` directory +* Make sure to bump the version number in the .cabal file and the ChangeLog + appropriately (check for any entries that snuck into the previous version's + changes) +* In release candidate, remove the Changelog's "unreleased changes" section +* Review documentation for any changes that need to be made + * Search for old Stack version and replace with new version +* Ensure all `doc/*.md` files are listed in `stack.cabal`'s 'extra-source-files` +* Check that any new Linux distribution versions added to + `etc/scripts/release.hs` and `etc/scripts/vagrant-releases.sh` +* Check that no new entries need to be added to + [releases.yaml](https://github.com/fpco/stackage-content/blob/master/stack/releases.yaml), + [install_and_upgrade.md](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md), + and + [README.md](https://github.com/commercialhaskell/stack/blob/master/README.md) -Release checklist after testing: +## Release process -* Create a draft Github release with tag `vX.Y.Z` (where X.Y.Z is the stack package's version). -* Run `etc/scripts/release.hs release` on Linux (Debian 7 32-bit [Vagrantfile](https://github.com/commercialhaskell/stack/tree/master/etc/vagrant/debian-7-i386)/64-bit [Vagrantfile](https://github.com/commercialhaskell/stack/tree/master/etc/vagrant/debian-7-amd64)), Windows (`--arch=i386` and `--arch=x86_64`), and OS X. This performs the following tasks automatically: - * Binaries for Linux, Windows, and OS X uploaded to draft Github release. -* Run `etc/scripts/release.hs --binary-variant=gmp4 release` on CentOS 6 32-bit [Vagrantfile](https://github.com/commercialhaskell/stack/tree/master/etc/vagrant/centos-6-i386)/64-bit [Vagrantfile](centos-6-x86_64)). -* Run `etc/scripts/release.hs ubuntu-upload debian-upload` in Linux (Ubuntu or Debian - [Vagrantfile](https://github.com/commercialhaskell/stack/tree/master/etc/vagrant/debian-7-amd64)) -* Run `etc/scripts/release.hs centos-upload fedora-upload` on Linux (CentOS or Fedora - [Vagrantfile](https://github.com/commercialhaskell/stack/tree/master/etc/vagrant/centos-7-x86_64)) -* Upload Arch Linux packages (manual process) -* Build new MinGHC distribution (See https://github.com/fpco/minghc/commit/51490f398e6722672364548a3855a0bfcba48ffe) +See +[stack-release-script's README](https://github.com/commercialhaskell/stack/blob/master/etc/scripts/README.md#prerequisites) +for requirements to perform the release, and more details about the tool. -After binaries uploaded: +* Create a + [new draft Github release](https://github.com/commercialhaskell/stack/releases/new) + with tag `vX.Y.Z` (where X.Y.Z is the stack package's version) -* Push signed Git tag (matching Github release tag name). -* Publish Github release. -* Upload package to Hackage. -* Announce to haskell-cafe, commercialhaskell, and haskell-stack mailing lists. +* On each machine you'll be releasing from, set environment variables: + `GITHUB_AUTHORIZATION_TOKEN`, `AWS_ACCESS_KEY_ID`, `AWS_SECRET_ACCESS_KEY` -For more information, see: https://github.com/commercialhaskell/stack/issues/324 +* On a machine with Vagrant installed: + * Run `etc/scripts/vagrant-releases.sh` + +* On Mac OS X: + * Run `etc/scripts/osx-release.sh` + +* On Windows: + * Ensure your working tree is in `C:\stack` (or a similarly short path) + * Run `etc\scripts\windows-releases.bat` + +* Push signed Git tag, matching Github release tag name, e.g.: `git tag -u + 9BEFB442 vX.Y.Z && git push origin vX.Y.Z` + +* Reset the `release` branch to the released commit, e.g.: `git merge --ff-only + vX.Y.Z && git push origin release` + +* Publish Github release + +* Edit + [stack-setup-2.yaml](https://github.com/fpco/stackage-content/blob/master/stack/stack-setup-2.yaml), + and add the new linux64 stack bindist + +* Upload package to Hackage: `stack upload . --pvp-bounds=both` + +* On a machine with Vagrant installed: + * Run `etc/scripts/vagrant-distros.sh` + +* Update in Arch Linux's + [haskell-stack.git](ssh+git://aur@aur.archlinux.org/haskell-stack.git): + `PKGBUILD` and `.SRCINFO` + * Be sure to reset `pkgrel` in both files, and update the SHA1 sum + +* Submit a PR for the + [haskell-stack Homebrew formula](https://github.com/Homebrew/homebrew/blob/master/Library/Formula/haskell-stack.rb). + The commit message should just be `haskell-stack ` + * Note: for v0.1.8.0, check if `pcre` should still be a dependency + * Also, update the homepage + +* Build Windows installers. See https://github.com/borsboom/stack-installer#readme + +* [Build new MinGHC distribution](#build_minghc) + +* [Upload haddocks to Hackage](#upload_haddocks), if hackage couldn't build on its own + +* Announce to haskell-cafe, commercialhaskell, and haskell-stack mailing lists + +# Extra steps + +## Upload haddocks to Hackage + +* Set `STACKVER` environment variable to the Stack version (e.g. `0.1.6.0`) +* Run: + +``` +STACKDOCDIR=stack-$STACKVER-docs +rm -rf _release/$STACKDOCDIR +mkdir -p _release +cp -r $(stack path --local-doc-root)/stack-$STACKVER _release/$STACKDOCDIR +sed -i '' 's/href="\.\.\/\([^/]*\)\//href="..\/..\/\1\/docs\//g' _release/$STACKDOCDIR/*.html +(cd _release && tar cvz --format=ustar -f $STACKDOCDIR.tar.gz $STACKDOCDIR) +curl -X PUT \ + -H 'Content-Type: application/x-tar' \ + -H 'Content-Encoding: gzip' \ + -u borsboom \ + --data-binary "@_release/$STACKDOCDIR.tar.gz" \ + "https://hackage.haskell.org/package/stack-$STACKVER/docs" +``` + +## Update MinGHC + +Full details of prerequisites and steps for building MinGHC are in its +[README](https://github.com/fpco/minghc#building-installers). What follows is an +abbreviated set specifically for including the latest stack version. + +* Ensure `makensis.exe` and `signtool.exe` are on your PATH. +* If you edit build-post-install.hs, run `stack exec -- cmd /c build-post-install.bat` +* Set `STACKVER` environment variable to latest Stack verion (e.g. `0.1.6.0`) +* Adjust commands below for new GHC versions +* Run: + +``` +stack build +stack exec -- minghc-generate 7.10.2 --stack=%STACKVER% +signtool sign /v /n "FP Complete, Corporation" /t "http://timestamp.verisign.com/scripts/timestamp.dll" .build\minghc-7.10.2-i386.exe +stack exec -- minghc-generate 7.10.2 --arch64 --stack=%STACKVER% +signtool sign /v /n "FP Complete, Corporation" /t "http://timestamp.verisign.com/scripts/timestamp.dll" .build\minghc-7.10.2-x86_64.exe +stack exec -- minghc-generate 7.8.4 --stack=%STACKVER% +signtool sign /v /n "FP Complete, Corporation" /t "http://timestamp.verisign.com/scripts/timestamp.dll" .build\minghc-7.8.4-i386.exe +stack exec -- minghc-generate 7.8.4 --arch64 --stack=%STACKVER% +signtool sign /v /n "FP Complete, Corporation" /t "http://timestamp.verisign.com/scripts/timestamp.dll" .build\minghc-7.8.4-x86_64.exe +``` + +* Upload the built binaries to a new Github release +* Edit [README.md](https://github.com/fpco/minghc/blob/master/README.md#using-the-installer) and update download links diff --git a/doc/dependency_visualization.md b/doc/dependency_visualization.md --- a/doc/dependency_visualization.md +++ b/doc/dependency_visualization.md @@ -1,4 +1,4 @@ -You can use stack to visualize the dependencies between your projects and optionally also external dependencies. +You can use stack to visualize the dependencies between your packages and optionally also external dependencies. As an example, let's look at `wreq`: @@ -39,5 +39,3 @@ $ stack dot --external --prune base,lens,wreq-examples,http-client,aeson,tls,http-client-tls,exceptions | twopi -Groot=wreq -Goverlap=false -Tpng -o wreq_pruned.png ``` [![wreq_pruned](https://cloud.githubusercontent.com/assets/591567/8495538/9fae1184-216e-11e5-9931-99e6147f8aed.png)](https://cloud.githubusercontent.com/assets/591567/8495538/9fae1184-216e-11e5-9931-99e6147f8aed.png) - - diff --git a/doc/docker_integration.md b/doc/docker_integration.md --- a/doc/docker_integration.md +++ b/doc/docker_integration.md @@ -203,6 +203,10 @@ # When the Docker Engine is remote (accessed by tcp), defaults to false. set-user: true + # Require the version of the Docker client to be within the specified + # Cabal-style version range (e.g., ">= 1.6.0 && < 1.9.0") + require-docker-version: "any" + Image Repositories ------------------------------------------------------------------------------- @@ -230,6 +234,11 @@ These images can also be used directory with `docker run` and provide a complete Haskell build environment. +In addition, most Docker images that contain the basics for running GHC can be +used with Stack's Docker integration. For example, the +[official Haskell image repository](https://hub.docker.com/_/haskell/) works. +See [Custom images](#custom-images) for more details. + Prerequisites ------------------------------------------------------------------------------- @@ -369,6 +378,26 @@ process. You could also use a Dockerfile to make this reusable. Consult the [Docker user guide](https://docs.docker.com/userguide/) for more on creating Docker images. + +### Custom images + +The easiest way to create your own custom image us by extending FP Complete's +images, but if you prefer to start from scratch, most images that include the +basics for building code with GHC will work. The image doesn't even, strictly +speaking, need to include GHC, but it does need to have libraries and tools that +GHC requires (e.g., libgmp, gcc, etc.). + +There are also a few ways to set up images that tightens the integration: + +* Create a user and group named `stack`, and create a `~/.stack` directory for + it. Any build plans and caches from it will be copied from the image by Stack, + meaning they don't need to be downloaded separately. +* Any packages in GHC's global package database will be available. This can be + used to add private libraries to the image, or the make available a set of + packages from an LTS release. +* The `DOCKER_SANDBOX_ID` environment variable (set via `ENV` in the Dockerfile) + introduces extra isolation between images, to ensure that parts of the home + directory and stack root are kept separate. Troubleshooting ------------------------------------------------------------------------------- diff --git a/doc/faq.md b/doc/faq.md --- a/doc/faq.md +++ b/doc/faq.md @@ -275,3 +275,7 @@ /home/philip/.stack/programs/x86_64-linux/ghc-7.10.1/bin/runghc-7.10.1 -package=Cabal-1.22.2.0 -clear-package-db -global-package-db /home/philip/tmp/Setup.hs --builddir=dist-stack/x86_64-linux/Cabal-1.22.2.0/ build Process exited with code: ExitFailure 1 ``` + +#### Where does the output from `--ghc-options=-ddump-splices` (and other `-ddump*` options) go? + +These are written to `*.dump-*` files inside the package's `.stack-work` directory. diff --git a/doc/install_and_upgrade.md b/doc/install_and_upgrade.md --- a/doc/install_and_upgrade.md +++ b/doc/install_and_upgrade.md @@ -1,24 +1,75 @@ -Distribution packages are available for [Ubuntu](#ubuntu), [Debian](#debian), [CentOS / Red Hat](#centos--red-hat), [Fedora](#fedora) and [Arch Linux](#arch-linux). Binaries for other operating systems are available on [the releases page](https://github.com/fpco/stack/releases). For the future, we have plans to support more OSes. +Distribution packages are available for [Ubuntu](#ubuntu), [Debian](#debian), +[CentOS / Red Hat](#centos--red-hat), [Fedora](#fedora) and +[Arch Linux](#arch-linux). Binaries for other operating systems are listed +below, and available on +[the Github releases page](https://github.com/fpco/stack/releases). For the +future, we are open to supporting more OSes (to request one, please +[submit an issue](https://github.com/commercialhaskell/stack/issues/new)). Binary packages are signed with this [signing key](SIGNING_KEY.md). +If you are writing a script that needs to download the latest binary, you can +find links that always point to the latest bindists +[here](https://www.stackage.org/stack). + ## Windows -*Note*: Due to specific Windows limitations, [some temporary workarounds](https://www.fpcomplete.com/blog/2015/08/stack-ghc-windows) may be required. It is strongly advised to set your `STACK_ROOT` environment variable similarly to your root (e.g., `set STACK_ROOT=c:\stack_root`) *before* running `stack`. +*Note*: Due to specific Windows limitations, + [some temporary workarounds](https://www.fpcomplete.com/blog/2015/08/stack-ghc-windows) + may be required. It is strongly advised to set your `STACK_ROOT` environment + variable similarly to your root (e.g., `set STACK_ROOT=c:\stack_root`) *before* + running `stack`. -* Download [the latest release](https://github.com/commercialhaskell/stack/releases/latest). Note: while generally i386/32-bit GHC is better tested on Windows, there are reports that recent versions of Windows only work with the 64-bit version of stack (see [issue #393](https://github.com/commercialhaskell/stack/issues/393)). -* Unpack the archive and place `stack.exe` somewhere on your `%PATH%` (see [Path section below](#path)) and you can then run `stack` on the command line. +*Note:* while generally 32-bit GHC is better tested on Windows, there are +reports that recent versions of Windows only work with the 64-bit version of +Stack (see +[issue #393](https://github.com/commercialhaskell/stack/issues/393)). + +### Installer + +We recommend installing to the default location with these installers, as that +will make `stack install` and `stack upgrade` work correctly out of the box. + + * [Windows 32-bit Installer](https://www.stackage.org/stack/windows-i386-installer) + * [Windows 64-bit Installer](https://www.stackage.org/stack/windows-x86_64-installer) + +### Manual download + +* Download the latest release: + + * [Windows 32-bit](https://www.stackage.org/stack/windows-i386) + * [Windows 64-bit](https://www.stackage.org/stack/windows-x86_64) + +* Unpack the archive and place `stack.exe` somewhere on your `%PATH%` (see + [Path section below](#path)) and you can then run `stack` on the command line. + * Now you can run `stack` from the terminal. -NOTE: These executables have been built and tested on a Windows 7, 8.1, and 10 64-bit machines. They should run on older Windows installs as well, but have not been tested. If you do test, please edit and update this page to indicate as such. +NOTE: These executables have been built and tested on a Windows 7, 8.1, and 10 +64-bit machines. They should run on older Windows installs as well, but have not +been tested. If you do test, please edit and update this page to indicate as +such. -## OS X +## Mac OS X -* Download [the latest release](https://github.com/commercialhaskell/stack/releases/latest) -* Extract the archive and place `stack` somewhere on your `$PATH` (see [Path section below](#path)) +### Using brew + +If you have a popular [brew](http://brew.sh/) tool installed, you can just do: + +``` +brew install haskell-stack +``` + +### Manual download + +* Download the latest release: + * [Mac OS X 64-bit](https://www.stackage.org/stack/osx-x86_64) +* Extract the archive and place `stack` somewhere on your `$PATH` (see + [Path section below](#path)) * Now you can run `stack` from the terminal. -We generally test on the current version of OS X, but stack is known to work on Mavericks as well, and may also work on older versions (YMMV). +We generally test on the current version of Mac OS X, but stack is known to work on +Yosemite and Mavericks as well, and may also work on older versions (YMMV). ## Ubuntu @@ -28,7 +79,7 @@ wget -q -O- https://s3.amazonaws.com/download.fpcomplete.com/ubuntu/fpco.key | sudo apt-key add - -2. Add the appropriate source repository: +2. Add the appropriate source repository (if not sure, run ``lsb_release -a`` to find out your Ubuntu version): * Ubuntu 15.10 (amd64): @@ -102,6 +153,10 @@ 1. Add the appropriate source repository: + * Fedora 23 (x86_64) + + curl -sSL https://s3.amazonaws.com/download.fpcomplete.com/fedora/23/fpco.repo | sudo tee /etc/yum.repos.d/fpco.repo + * Fedora 22 (x86_64) curl -sSL https://s3.amazonaws.com/download.fpcomplete.com/fedora/22/fpco.repo | sudo tee /etc/yum.repos.d/fpco.repo @@ -112,7 +167,7 @@ 2. Install: - * Fedora 22+ + * Fedora 22 and above sudo dnf -y install stack @@ -162,8 +217,18 @@ (64-bit and 32-bit options available) -* Download [the latest release](https://github.com/commercialhaskell/stack/releases/latest). Note: the `-gmp4` variants are for older distributions (such as CentOS 6.x) that only include libgmp4 (libgmp.so.3). +* Download the latest release: + + * [Linux 64-bit, standard](https://www.stackage.org/stack/linux-x86_64) + * [Linux 32-bit, standard](https://www.stackage.org/stack/linux-i386) + + If you are on an older distribution that only includes libgmp4 (libgmp.so.3), such as CentOS/RHEL/Amazon Linux 6.x, use one of these instead: + + * [Linux 64-bit, libgmp4](https://www.stackage.org/stack/linux-x86_64-gmp4) + * [Linux 32-bit, libgmp4](https://www.stackage.org/stack/linux-i386-gmp4) + * Extract the archive and place `stack` somewhere on your `$PATH` (see [Path section below](#path)) + * Now you can run `stack` from the terminal. Tested on Fedora 20: make sure to install the following packages `sudo yum install perl make automake gcc gmp-devel`. diff --git a/doc/nonstandard_project_init.md b/doc/nonstandard_project_init.md --- a/doc/nonstandard_project_init.md +++ b/doc/nonstandard_project_init.md @@ -1,15 +1,15 @@ # Introduction -The purpose of this page is to collect information about issues that arise when users either have an existing cabal project or another nonstandard setup such as a private hackage database. +The purpose of this page is to collect information about issues that arise when users either have an existing cabal project or another nonstandard setup such as a private hackage database. # Using a Cabal File -New users may be confused by the fact that you must add dependencies to the projects cabal file, even in the case when you have already listed the package in the `stack.yaml`. In most cases, dependencies for your project that are in the Stackage snapshot need *only* be added to the cabal file. stack makes heavy use of Cabal the library under the hood. In general, your stack packages should also end up being valid cabal-install packages. +New users may be confused by the fact that you must add dependencies to the package's cabal file, even in the case when you have already listed the package in the `stack.yaml`. In most cases, dependencies for your package that are in the Stackage snapshot need *only* be added to the cabal file. stack makes heavy use of Cabal the library under the hood. In general, your stack packages should also end up being valid cabal-install packages. ## Issues Referenced - https://github.com/commercialhaskell/stack/issues/105 # Passing Flags to Cabal -Any build command, `bench`, `install`, `haddock`, `test`, etc. takes a `--flag` option which passes flags to cabal. Another way to do this is using the flags field in a `stack.yaml`, with the option to specify flags on a per project basis. +Any build command, `bench`, `install`, `haddock`, `test`, etc. takes a `--flag` option which passes flags to cabal. Another way to do this is using the flags field in a `stack.yaml`, with the option to specify flags on a per package basis. As an example, in a `stack.yaml` for multi-package project with packages `foo`, `bar`, `baz`: @@ -25,7 +25,7 @@ It is also possible to pass the same flag to multiple packages, i.e. `stack build --flag *:necessary` -Currently one needs to list all of your modules that interpret flags in the `other-modules` section of a cabal file. `cabal-install` has a different behavior currently and doesn't require that the modules be listed. This may change in a future release. +Currently one needs to list all of your modules that interpret flags in the `other-modules` section of a cabal file. `cabal-install` has a different behavior currently and doesn't require that the modules be listed. This may change in a future release. ## Issues Referenced @@ -87,7 +87,7 @@ - https://github.com/commercialhaskell/stack/issues/137 # Intra-package Targets -stack supports intra-package targets, similar to `cabal build COMPONENTS` for situations when you don't want to build every target inside your package. +stack supports intra-package targets, similar to `cabal build COMPONENTS` for situations when you don't want to build every target inside your package. Example: ``` diff --git a/doc/shell_autocompletion.md b/doc/shell_autocompletion.md --- a/doc/shell_autocompletion.md +++ b/doc/shell_autocompletion.md @@ -4,7 +4,7 @@ file was automatically installed (you may need the `bash-completion` package to have it take effect). -The following adds support for shell tab completion for standard Stack arguments, although completion for filenames and executables etc. within stack is still lacking (see [issue 82](https://github.com/commercialhaskell/stack/issues/832)). +The following adds support for shell tab completion for standard Stack arguments, although completion for filenames and executables etc. within stack is still lacking (see [issue 823](https://github.com/commercialhaskell/stack/issues/832)). ### for bash users diff --git a/doc/stack_and_ghcjs.md b/doc/stack_and_ghcjs.md new file mode 100644 --- /dev/null +++ b/doc/stack_and_ghcjs.md @@ -0,0 +1,75 @@ +# Stack & GHCJS + +To set up and use GHCJS with stack, you should place GHCJS `resolver` in your project's `stack.yaml` (see instructions for [old base](#ghcjs-old-base) and [`master` - a.k.a. improved base](#ghcjs-master-aka-improved-base)). Once this has been done, Stack will use GHCJS for most commands, with the exception of `ghc`, `runghc` and `ide`. (Support for `ghc` and `runghc` will likely be added before the next release - see [#1054](https://github.com/commercialhaskell/stack/issues/1054)). + +After creating a `stack.yaml`, which specifies that ghcjs is to be used (see below), you can have Stack automatically set up and boot GHCJS. Stack must be newer than `0.1.6`: + +``` +$ stack setup +``` + +(this will take a long time) + +## Using a stackage snapshot + +The configurations below use a compiler resolver, which means that you can't use packages from a stackage snapshot. The latest development version (which will probably be released as `0.1.7`) also supports using GHCJS with a stackage snapshot, via a `compiler` field. To use the latest development version, do the following: + +``` +$ stack upgrade --git +``` + +For example, the old-base configuration looks like this: + +```yaml +resolver: lts-3.10 +compiler: ghcjs-0.1.0.20150924_ghc-7.10.2 +compiler-check: match-exact +``` + +You can also build existing stack projects which target GHC and instead build them with GHCJS. To do this, invoke stack like this: `stack build --compiler ghcjs-0.1.0.20150924_ghc-7.10.2` + +## Example Configurations + +### GHCJS (old base) + +You can use this resolver for GHCJS (old base) in your `stack.yaml`: + +```yaml +resolver: ghcjs-0.1.0.20150924_ghc-7.10.2 +compiler-check: match-exact +``` + +### GHCJS `master` (a.k.a. improved base) + +To use the master branch, a.k.a improved base, add the following to your `stack.yaml`: + +```yaml +resolver: ghcjs-0.2.0.20151001_ghc-7.10.2 +compiler-check: match-exact +setup-info: + ghcjs: + source: + ghcjs-0.2.0.20151001_ghc-7.10.2: + url: "https://github.com/fizruk/ghcjs/releases/download/v0.2.0.20151001/ghcjs-0.2.0.20151001.tar.gz" +``` + +or for the 2015-10-29 master branch +```yaml +resolver: ghcjs-0.2.0.20151029_ghc-7.10.2 +compiler-check: match-exact +setup-info: + ghcjs: + source: + ghcjs-0.2.0.20151029_ghc-7.10.2: + url: "https://github.com/nrolland/ghcjs/releases/download/v0.2.0.20151029/ghcjs-0.2.0.20151029.tar.gz" +``` + +### Custom installed GHCJS (development branch) + +In order to use a GHCJS installed on your path, just add the following to your `stack.yaml`: + +```yaml +resolver: ghcjs-0.2.0_ghc-7.10.2 +``` + +(Or, `ghcjs-0.1.0_ghc-7.10.2` if you are working with an older version) diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -102,7 +102,7 @@ Packages that come from the snapshot global database or are not affected. ### image -The image settings are used for the creation of container images using `stack container image`, e.g. +The image settings are used for the creation of container images using `stack image container`, e.g. ```yaml image: container: @@ -118,7 +118,7 @@ ### docker -See [Docker configuration](Docker#configuration). +See [Docker configuration](https://github.com/commercialhaskell/stack/blob/release/doc/docker_integration.md). ### connection-count @@ -222,6 +222,23 @@ * `match-exact`: the entire version number must match precisely * `newer-minor`: the third component can be increased, e.g. if your resolver is `ghc-7.10.1`, then 7.10.2 will also be allowed. This was the default up through stack 0.1.3 +### compiler + +(Since 0.1.7) + +Overrides the compiler version in the resolver. Note that the `compiler-check` +flag also applies to the version numbers. This uses the same syntax as compiler +resolvers like `ghc-7.10.2` or `ghcjs-0.1.0.20150924_ghc-7.10.2` (version used +for the 'old-base' version of GHCJS). While it's useful to override the +compiler for a variety of reasons, the main usecase is to use GHCJS with a +stackage snapshot, like this: + +```yaml +resolver: lts-3.10 +compiler: ghcjs-0.1.0.20150924_ghc-7.10.2 +compiler-check: match-exact +``` + ### ghc-options (Since 0.1.4) @@ -238,7 +255,7 @@ Caveat emptor: setting options like this will affect your snapshot packages, which can lead to unpredictable behavior versus official Stackage snapshots. This is in contrast to the `ghc-options` command line flag, which will only -affect local targets. +affect local packages. ### ghc-variant @@ -306,15 +323,14 @@ (Since 0.1.6) -Decide whether a custom `Setup.hs` script should be run with an explicit list -of dependencies based on the dependencies of the package itself, or simply -provided the global package database. This option is most often needed when -overriding packages in the global database, see [issue #1110](https://github.com/commercialhaskell/stack/issues/1110). - -Setting the list explicitly can help when a Setup.hs depends on packages in the -local package database. For more information on that case, see [issue #897](https://github.com/commercialhaskell/stack/issues/897). +Decide whether a custom `Setup.hs` script should be run with an explicit list of +dependencies, based on the dependencies of the package itself. It associates the +name of a local package with a boolean. When it's `true`, the `Setup.hs` script +is built with an explicit list of packages. When it's `false` (default), the +`Setup.hs` script is built without access to the local DB, but can access any +package in the snapshot / global DB. -Note that in the future, this should all disappear once Cabal provides full +Note that in the future, this will be unnecessary, once Cabal provides full support for explicit Setup.hs dependencies. ```yaml @@ -346,3 +362,46 @@ ``` Note that `everything` is a slightly dangerous value, as it can break invariants about your snapshot database. + +### allow-newer + +(Since 0.1.7) + +Ignore version bounds in .cabal files. Default is false. + +```yaml +allow-newer: true +``` + +Note that this also ignores lower bounds. The name "allow-newer" is chosen to +match the commonly used cabal option. + +### templates + +Templates used with `stack new` have a number of parameters that affect the generated code. These can be set for all new projects you create. The result of them can be observed in the generated LICENSE and cabal files. + +The 5 parameters are: `author-email`, `author-name`, `category`, `copyright` and `github-username`. + +* _author-email_ - sets the `maintainer` property in cabal +* _author-name_ - sets the `author` property in cabal and the name used in LICENSE +* _category_ - sets the `category` property in cabal. This is used in Hackage. For examples of categories see [Packages by category](https://hackage.haskell.org/packages/). It makes sense for `category` to be set on a per project basis because it is uncommon for all projects a user creates to belong to the same category. The category can be set per project by passing `-p "category:value"` to the `stack new` command. +* _copyright_ - sets the `copyright` property in cabal. It is typically the name of the holder of the copyright on the package and the year(s) from which copyright is claimed. For example: `Copyright: (c) 2006-2007 Joe Bloggs` +* _github-username_ - used to generate `homepage` and `source-repository` in cabal. For instance `github-username: myusername` and `stack new my-project new-template` would result: +```yaml +homepage: http://github.com/myusername/my-project#readme + +source-repository head + type: git + location: https://github.com/myusername/my-project +``` + +These properties can be set in `config.yaml` as follows: +```yaml +templates: + params: + author-name: Your Name + author-email: youremail@example.com + category: Your Projects Category + copyright: Copyright: (c) 2015 Your Name + github-username: yourusername +``` diff --git a/src/Control/Concurrent/Execute.hs b/src/Control/Concurrent/Execute.hs --- a/src/Control/Concurrent/Execute.hs +++ b/src/Control/Concurrent/Execute.hs @@ -24,6 +24,7 @@ data ActionType = ATBuild + | ATBuildFinal | ATFinal deriving (Show, Eq, Ord) data ActionId = ActionId !PackageIdentifier !ActionType @@ -94,7 +95,7 @@ if null as then return $ return () else inner as - loop = join $ atomically $ breakOnErrs $ withActions $ \as -> do + loop = join $ atomically $ breakOnErrs $ withActions $ \as -> case break (Set.null . actionDeps) as of (_, []) -> do inAction <- readTVar esInAction diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs --- a/src/Data/Aeson/Extended.hs +++ b/src/Data/Aeson/Extended.hs @@ -67,7 +67,7 @@ do a <- fmap snd p fmap (, a) (fmap fst p .!= d) --- | Tell warning parser about about an expected field, so it doesn't warn about it. +-- | Tell warning parser about an expected field, so it doesn't warn about it. tellJSONField :: Text -> WarningParser () tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key}) diff --git a/src/Data/Attoparsec/Args.hs b/src/Data/Attoparsec/Args.hs --- a/src/Data/Attoparsec/Args.hs +++ b/src/Data/Attoparsec/Args.hs @@ -31,7 +31,7 @@ -- | Parse arguments using 'argsParser'. parseArgs :: EscapingMode -> Text -> Either String [String] -parseArgs mode t = P.parseOnly (argsParser mode) t +parseArgs mode = P.parseOnly (argsParser mode) -- | A basic argument parser. It supports space-separated text, and -- string quotation with identity escaping: \x -> x. diff --git a/src/Data/Binary/VersionTagged.hs b/src/Data/Binary/VersionTagged.hs --- a/src/Data/Binary/VersionTagged.hs +++ b/src/Data/Binary/VersionTagged.hs @@ -25,53 +25,55 @@ import Data.Binary.Get (ByteOffset) import Data.Binary.Tagged (HasStructuralInfo, HasSemanticVersion) import qualified Data.Binary.Tagged as BinaryTagged +import Data.Monoid ((<>)) import Data.Typeable (Typeable) import Control.Exception.Enclosed (tryAnyDeep) -import System.FilePath (takeDirectory) -import System.Directory (createDirectoryIfMissing) +import Path +import Path.IO (createTree) import qualified Data.Text as T type BinarySchema a = (Binary a, NFData a, HasStructuralInfo a, HasSemanticVersion a) -- | Write to the given file, with a binary-tagged tag. taggedEncodeFile :: (BinarySchema a, MonadIO m) - => FilePath + => Path Abs File -> a -> m () taggedEncodeFile fp x = liftIO $ do - createDirectoryIfMissing True $ takeDirectory fp - BinaryTagged.taggedEncodeFile fp x + createTree (parent fp) + BinaryTagged.taggedEncodeFile (toFilePath fp) x -- | Read from the given file. If the read fails, run the given action and -- write that back to the file. Always starts the file off with the version -- tag. taggedDecodeOrLoad :: (BinarySchema a, MonadIO m, MonadLogger m) - => FilePath + => Path Abs File -> m a -> m a taggedDecodeOrLoad fp mx = do - $logDebug $ T.pack $ "Trying to decode " ++ fp + let fpt = T.pack (toFilePath fp) + $logDebug $ "Trying to decode " <> fpt eres <- decodeFileOrFailDeep fp case eres of Left _ -> do - $logDebug $ T.pack $ "Failure decoding " ++ fp + $logDebug $ "Failure decoding " <> fpt x <- mx taggedEncodeFile fp x return x Right x -> do - $logDebug $ T.pack $ "Success decoding " ++ fp + $logDebug $ "Success decoding " <> fpt return x -- | Ensure that there are no lurking exceptions deep inside the parsed -- value... because that happens unfortunately. See -- https://github.com/commercialhaskell/stack/issues/554 decodeFileOrFailDeep :: (BinarySchema a, MonadIO m, MonadThrow n) - => FilePath + => Path loc File -> m (n a) decodeFileOrFailDeep fp = liftIO $ fmap (either throwM return) $ tryAnyDeep $ do - eres <- BinaryTagged.taggedDecodeFileOrFail fp + eres <- BinaryTagged.taggedDecodeFileOrFail (toFilePath fp) case eres of - Left (offset, str) -> throwM $ DecodeFileFailure fp offset str + Left (offset, str) -> throwM $ DecodeFileFailure (toFilePath fp) offset str Right x -> return x data DecodeFileFailure = DecodeFileFailure FilePath ByteOffset String diff --git a/src/Data/Maybe/Extra.hs b/src/Data/Maybe/Extra.hs --- a/src/Data/Maybe/Extra.hs +++ b/src/Data/Maybe/Extra.hs @@ -2,9 +2,24 @@ module Data.Maybe.Extra where +import Control.Applicative import Control.Monad +import Data.Traversable hiding (mapM) import Data.Maybe +import Prelude -- Silence redundant import warnings +-- | Applicative 'mapMaybe'. +mapMaybeA :: Applicative f => (a -> f (Maybe b)) -> [a] -> f [b] +mapMaybeA f = fmap catMaybes . traverse f + +-- | @'forMaybeA' '==' 'flip' 'mapMaybeA'@ +forMaybeA :: Applicative f => [a] -> (a -> f (Maybe b)) -> f [b] +forMaybeA = flip mapMaybeA + -- | Monadic 'mapMaybe'. -mapMaybeM :: Monad f => (a -> f (Maybe b)) -> [a] -> f [b] +mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM f = liftM catMaybes . mapM f + +-- | @'forMaybeM' '==' 'flip' 'mapMaybeM'@ +forMaybeM :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b] +forMaybeM = flip mapMaybeM diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs --- a/src/Network/HTTP/Download.hs +++ b/src/Network/HTTP/Download.hs @@ -24,6 +24,7 @@ import Control.Exception (Exception) import Control.Exception.Enclosed (handleIO) +import Control.Monad (void) import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (MonadReader, ReaderT, ask, @@ -52,8 +53,8 @@ removeFile, renameFile) import System.FilePath (takeDirectory, (<.>)) -import System.IO (IOMode (ReadMode)) -import System.IO (IOMode (WriteMode), +import System.IO (IOMode (ReadMode), + IOMode (WriteMode), withBinaryFile) -- | Download the given URL to the given location. If the file already exists, @@ -123,7 +124,7 @@ return True | responseStatus res == status304 -> return False - | otherwise -> throwM $ RedownloadFailed req2 dest $ fmap (const ()) res + | otherwise -> throwM $ RedownloadFailed req2 dest $ void res -- | Download a JSON value and parse it using a 'FromJSON' instance. downloadJSON :: (FromJSON a, MonadReader env m, HasHttpManager env, MonadIO m, MonadThrow m) diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs --- a/src/Network/HTTP/Download/Verified.hs +++ b/src/Network/HTTP/Download/Verified.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -157,7 +158,7 @@ -- https://github.com/commercialhaskell/stack/issues/240 || b == actualDigestHexByteString - when (not passedCheck) $ + unless passedCheck $ throwM $ WrongDigest req (show hashCheckAlgorithm) hashCheckHexDigest actualDigestString assertLengthSink :: MonadThrow m @@ -200,8 +201,12 @@ env <- ask liftIO $ whenM' getShouldDownload $ do createDirectoryIfMissing True dir - withBinaryFile fptmp WriteMode $ \h -> do + withBinaryFile fptmp WriteMode $ \h -> +#if MIN_VERSION_retry(0,7,0) + recovering drRetryPolicy handlers $ const $ +#else recovering drRetryPolicy handlers $ +#endif flip runReaderT env $ withResponse req (go h) renameFile fptmp fp @@ -254,7 +259,7 @@ when (fileSize /= expectedFileSize) $ throwM $ WrongFileSize expectedFileSize fileSizeInteger - checkContentLengthHeader headers expectedContentLength = do + checkContentLengthHeader headers expectedContentLength = case List.lookup hContentLength headers of Just lengthBS -> do let lengthStr = displayByteString lengthBS diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs --- a/src/Options/Applicative/Builder/Extra.hs +++ b/src/Options/Applicative/Builder/Extra.hs @@ -20,30 +20,57 @@ import Data.Text (Text) import qualified Data.Text as T --- | Enable/disable flags for a @Bool@. -boolFlags :: Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool +-- | Enable/disable flags for a 'Bool'. +boolFlags :: Bool -- ^ Default value + -> String -- ^ Flag name + -> String -- ^ Help suffix + -> Mod FlagFields Bool + -> Parser Bool boolFlags defaultValue = enableDisableFlags defaultValue True False --- | Enable/disable flags for a @Bool@, without a default case (to allow chaining @<|>@s). -boolFlagsNoDefault :: (Maybe Bool) -> String -> String -> Mod FlagFields Bool -> Parser Bool +-- | Enable/disable flags for a 'Bool', without a default case (to allow chaining with '<|>'). +boolFlagsNoDefault :: Maybe Bool -- ^ Hide the enabling or disabling flag from the + -- brief description? + -> String -- ^ Flag name + -> String -- ^ Help suffix + -> Mod FlagFields Bool + -> Parser Bool boolFlagsNoDefault = enableDisableFlagsNoDefault True False --- | Enable/disable flags for a @(Maybe Bool)@. -maybeBoolFlags :: String -> String -> Mod FlagFields (Maybe Bool) -> Parser (Maybe Bool) +-- | Enable/disable flags for a @('Maybe' 'Bool')@. +maybeBoolFlags :: String -- ^ Flag name + -> String -- ^ Help suffix + -> Mod FlagFields (Maybe Bool) + -> Parser (Maybe Bool) maybeBoolFlags = enableDisableFlags Nothing (Just True) (Just False) -- | Enable/disable flags for any type. -enableDisableFlags :: (Eq a) => a -> a -> a -> String -> String -> Mod FlagFields a -> Parser a +enableDisableFlags :: (Eq a) + => a -- ^ Default value + -> a -- ^ Enabled value + -> a -- ^ Disabled value + -> String -- ^ Name + -> String -- ^ Help suffix + -> Mod FlagFields a + -> Parser a enableDisableFlags defaultValue enabledValue disabledValue name helpSuffix mods = enableDisableFlagsNoDefault enabledValue disabledValue (Just defaultValue) name helpSuffix mods <|> pure defaultValue --- | Enable/disable flags for any type, without a default (to allow chaining @<|>@s) -enableDisableFlagsNoDefault :: (Eq a) => a -> a -> (Maybe a) -> String -> String -> Mod FlagFields a -> Parser a +-- | Enable/disable flags for any type, without a default (to allow chaining with '<|>') +enableDisableFlagsNoDefault :: (Eq a) + => a -- ^ Enabled value + -> a -- ^ Disabled value + -> Maybe a -- ^ Hide the enabling or disabling flag + -- from the brief description?? + -> String -- ^ Name + -> String -- ^ Help suffix + -> Mod FlagFields a + -> Parser a enableDisableFlagsNoDefault enabledValue disabledValue maybeHideValue name helpSuffix mods = last <$> some (enableDisableFlagsNoDefault' enabledValue disabledValue maybeHideValue name helpSuffix mods) -enableDisableFlagsNoDefault' :: (Eq a) => a -> a -> (Maybe a) -> String -> String -> Mod FlagFields a -> Parser a +enableDisableFlagsNoDefault' :: (Eq a) => a -> a -> Maybe a -> String -> String -> Mod FlagFields a -> Parser a enableDisableFlagsNoDefault' enabledValue disabledValue maybeHideValue name helpSuffix mods = let hideEnabled = Just enabledValue == maybeHideValue hideDisabled = Just disabledValue == maybeHideValue @@ -70,24 +97,36 @@ help (concat $ concat [ ["Disable ", helpSuffix] - , [" (--no-" ++ name ++ " to enable)" | hideEnabled]]) <> + , [" (--" ++ name ++ " to enable)" | hideEnabled]]) <> mods) <|> flag' disabledValue (hidden <> internal <> long ("disable-" ++ name) <> mods) -- | Show an extra help option (e.g. @--docker-help@ shows help for all @--docker*@ args). --- To actually show have that help appear, use 'execExtraHelp' before executing the main parser. -extraHelpOption :: String -> String -> String -> Parser (a -> a) -extraHelpOption progName fakeName helpName = +-- +-- To actually have that help appear, use 'execExtraHelp' before executing the main parser. +extraHelpOption :: Bool -- ^ Hide from the brief description? + -> String -- ^ Program name, e.g. @"stack"@ + -> String -- ^ Option glob expression, e.g. @"docker*"@ + -> String -- ^ Help option name, e.g. @"docker-help"@ + -> Parser (a -> a) +extraHelpOption hide progName fakeName helpName = infoOption (optDesc' ++ ".") (long helpName <> hidden <> internal) <*> - infoOption (optDesc' ++ ".") (long fakeName <> help optDesc') + infoOption (optDesc' ++ ".") (long fakeName <> + help optDesc' <> + (if hide then hidden <> internal else idm)) where optDesc' = concat ["Run '", takeBaseName progName, " --", helpName, "' for details"] --- | Display extra help if extea help option passed in arguments. --- Since optparse-applicative doesn't allow an arbirary IO action for an 'abortOption', this +-- | Display extra help if extra help option passed in arguments. +-- +-- Since optparse-applicative doesn't allow an arbitrary IO action for an 'abortOption', this -- was the best way I found that doesn't require manually formatting the help. -execExtraHelp :: [String] -> String -> Parser a -> String -> IO () +execExtraHelp :: [String] -- ^ Command line arguments + -> String -- ^ Extra help option name, e.g. @"docker-help"@ + -> Parser a -- ^ Option parser for the relevant command + -> String -- ^ Option description + -> IO () execExtraHelp args helpOpt parser pd = when (args == ["--" ++ helpOpt]) $ withArgs ["--help"] $ do @@ -99,8 +138,10 @@ return () where hiddenHelper = abortOption ShowHelpText (long "help" <> hidden <> internal) +-- | 'option', specialized to 'Text'. textOption :: Mod OptionFields Text -> Parser Text textOption = option (T.pack <$> readerAsk) +-- | 'argument', specialized to 'Text'. textArgument :: Mod ArgumentFields Text -> Parser Text textArgument = argument (T.pack <$> readerAsk) diff --git a/src/Options/Applicative/Complicated.hs b/src/Options/Applicative/Complicated.hs new file mode 100644 --- /dev/null +++ b/src/Options/Applicative/Complicated.hs @@ -0,0 +1,141 @@ +-- | Simple interface to complicated program arguments. +-- +-- This is a "fork" of the @optparse-simple@ package that has some workarounds for +-- optparse-applicative issues that become problematic with programs that have many options and +-- subcommands. Because it makes the interface more complex, these workarounds are not suitable for +-- pushing upstream to optparse-applicative. + +module Options.Applicative.Complicated + ( addCommand + , addSubCommands + , complicatedOptions + , complicatedParser + ) where + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Either +import Control.Monad.Trans.Writer +import Data.Monoid +import Data.Version +import Options.Applicative +import Options.Applicative.Types +import Options.Applicative.Builder.Internal +import System.Environment + +-- | Generate and execute a complicated options parser. +complicatedOptions + :: Monoid a + => Version + -- ^ numeric version + -> Maybe String + -- ^ version string + -> String + -- ^ header + -> String + -- ^ program description + -> Parser a + -- ^ common settings + -> EitherT b (Writer (Mod CommandFields (b,a))) () + -- ^ commands (use 'addCommand') + -> IO (a,b) +complicatedOptions numericVersion versionString h pd commonParser commandParser = + do args <- getArgs + (a,(b,c)) <- case execParserPure (prefs noBacktrack) parser args of + Failure _ | null args -> withArgs ["--help"] (execParser parser) + parseResult -> handleParseResult parseResult + return (mappend c a,b) + where parser = info (helpOption <*> versionOptions <*> complicatedParser commonParser commandParser) desc + desc = fullDesc <> header h <> progDesc pd + versionOptions = + case versionString of + Nothing -> versionOption (showVersion numericVersion) + Just s -> versionOption s <*> numericVersionOption + versionOption s = + infoOption + s + (long "version" <> + help "Show version") + numericVersionOption = + infoOption + (showVersion numericVersion) + (long "numeric-version" <> + help "Show only version number") + +-- | Add a command to the options dispatcher. +addCommand :: String -- ^ command string + -> String -- ^ title of command + -> String -- ^ footer of command help + -> (a -> b) -- ^ constructor to wrap up command in common data type + -> Parser c -- ^ common parser + -> Parser a -- ^ command parser + -> EitherT b (Writer (Mod CommandFields (b,c))) () +addCommand cmd title footerStr constr = + addCommand' cmd title footerStr (\a c -> (constr a,c)) + +-- | Add a command that takes sub-commands to the options dispatcher. +addSubCommands + :: Monoid c + => String + -- ^ command string + -> String + -- ^ title of command + -> String + -- ^ footer of command help + -> Parser c + -- ^ common parser + -> EitherT b (Writer (Mod CommandFields (b,c))) () + -- ^ sub-commands (use 'addCommand') + -> EitherT b (Writer (Mod CommandFields (b,c))) () +addSubCommands cmd title footerStr commonParser commandParser = + addCommand' cmd + title + footerStr + (\(c1,(a,c2)) c3 -> (a,mconcat [c3, c2, c1])) + commonParser + (complicatedParser commonParser commandParser) + +-- | Add a command to the options dispatcher. +addCommand' :: String -- ^ command string + -> String -- ^ title of command + -> String -- ^ footer of command help + -> (a -> c -> (b,c)) -- ^ constructor to wrap up command in common data type + -> Parser c -- ^ common parser + -> Parser a -- ^ command parser + -> EitherT b (Writer (Mod CommandFields (b,c))) () +addCommand' cmd title footerStr constr commonParser inner = + lift (tell (command cmd + (info (constr <$> inner <*> commonParser) + (progDesc title <> footer footerStr)))) + +-- | Generate a complicated options parser. +complicatedParser + :: Monoid a + => Parser a + -- ^ common settings + -> EitherT b (Writer (Mod CommandFields (b,a))) () + -- ^ commands (use 'addCommand') + -> Parser (a,(b,a)) +complicatedParser commonParser commandParser = + (,) <$> + commonParser <*> + case runWriter (runEitherT commandParser) of + (Right (),d) -> hsubparser' d + (Left b,_) -> pure (b,mempty) + +-- way to do in 'addCommand' | Subparser with @--help@ argument. Borrowed with slight modification +-- from Options.Applicative.Extra. +hsubparser' :: Mod CommandFields a -> Parser a +hsubparser' m = mkParser d g rdr + where + Mod _ d g = m `mappend` metavar "COMMAND" + (cmds, subs) = mkCommand m + rdr = CmdReader cmds (fmap add_helper . subs) + add_helper pinfo = pinfo + { infoParser = infoParser pinfo <**> helpOption } + +-- | Non-hidden help option. +helpOption :: Parser (a -> a) +helpOption = + abortOption ShowHelpText $ + long "help" <> + help "Show this help text" diff --git a/src/Path/Extra.hs b/src/Path/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Path/Extra.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE ViewPatterns #-} + +-- | Extra Path utilities. + +module Path.Extra + (toFilePathNoTrailingSep + ,dropRoot + ,parseCollapsedAbsDir + ,parseCollapsedAbsFile + ) where + +import Control.Monad.Catch +import Path +import Path.Internal (Path(..)) +import qualified System.FilePath as FP + +-- | Convert to FilePath but don't add a trailing slash. +toFilePathNoTrailingSep :: Path loc Dir -> FilePath +toFilePathNoTrailingSep = FP.dropTrailingPathSeparator . toFilePath + +-- | Collapse intermediate "." and ".." directories from path, then parse +-- it with 'parseAbsDir'. +-- (probably should be moved to the Path module) +parseCollapsedAbsDir :: MonadThrow m => FilePath -> m (Path Abs Dir) +parseCollapsedAbsDir = parseAbsDir . collapseFilePath + +-- | Collapse intermediate "." and ".." directories from path, then parse +-- it with 'parseAbsFile'. +-- (probably should be moved to the Path module) +parseCollapsedAbsFile :: MonadThrow m => FilePath -> m (Path Abs File) +parseCollapsedAbsFile = parseAbsFile . collapseFilePath + +-- | Collapse intermediate "." and ".." directories from a path. +-- +-- > collapseFilePath "./foo" == "foo" +-- > collapseFilePath "/bar/../baz" == "/baz" +-- > collapseFilePath "/../baz" == "/../baz" +-- > collapseFilePath "parent/foo/baz/../bar" == "parent/foo/bar" +-- > collapseFilePath "parent/foo/baz/../../bar" == "parent/bar" +-- > collapseFilePath "parent/foo/.." == "parent" +-- > collapseFilePath "/parent/foo/../../bar" == "/bar" +-- +-- (borrowed from @Text.Pandoc.Shared@) +collapseFilePath :: FilePath -> FilePath +collapseFilePath = FP.joinPath . reverse . foldl go [] . FP.splitDirectories + where + go rs "." = rs + go r@(p:rs) ".." = case p of + ".." -> "..":r + (checkPathSeperator -> Just True) -> "..":r + _ -> rs + go _ (checkPathSeperator -> Just True) = [[FP.pathSeparator]] + go rs x = x:rs + isSingleton [] = Nothing + isSingleton [x] = Just x + isSingleton _ = Nothing + checkPathSeperator = fmap FP.isPathSeparator . isSingleton + +-- | Drop the root (either @\/@ on POSIX or @C:\\@, @D:\\@, etc. on +-- Windows). +dropRoot :: Path Abs t -> Path Rel t +dropRoot (Path l) = Path (FP.dropDrive l) diff --git a/src/Path/Find.hs b/src/Path/Find.hs --- a/src/Path/Find.hs +++ b/src/Path/Find.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -- | Finding files. @@ -23,7 +22,7 @@ -> (Path Abs File -> Bool) -- ^ Predicate to match the file. -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. -> m (Maybe (Path Abs File)) -- ^ Absolute file path. -findFileUp s p d = findPathUp snd s p d +findFileUp = findPathUp snd -- | Find the location of a directory matching the given predicate. findDirUp :: (MonadIO m,MonadThrow m) @@ -31,7 +30,7 @@ -> (Path Abs Dir -> Bool) -- ^ Predicate to match the directory. -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. -> m (Maybe (Path Abs Dir)) -- ^ Absolute directory path. -findDirUp s p d = findPathUp fst s p d +findDirUp = findPathUp fst -- | Find the location of a path matching the given predicate. findPathUp :: (MonadIO m,MonadThrow m) @@ -45,15 +44,9 @@ do entries <- listDirectory dir case find p (pathType entries) of Just path -> return (Just path) - Nothing -> - if Just dir == upperBound - then return Nothing - else if parent dir == dir - then return Nothing - else findPathUp pathType - (parent dir) - p - upperBound + Nothing | Just dir == upperBound -> return Nothing + | parent dir == dir -> return Nothing + | otherwise -> findPathUp pathType (parent dir) p upperBound -- | Find files matching predicate below a root directory. findFiles :: Path Abs Dir -- ^ Root directory to begin with. diff --git a/src/Path/IO.hs b/src/Path/IO.hs --- a/src/Path/IO.hs +++ b/src/Path/IO.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ViewPatterns #-} -- | IO actions that might be put in a package at some point. @@ -31,9 +30,6 @@ ,copyFileIfExists ,copyDirectoryRecursive ,createTree - ,dropRoot - ,parseCollapsedAbsFile - ,parseCollapsedAbsDir ,withCanonicalizedSystemTempDirectory ,withCanonicalizedTempDirectory) where @@ -43,10 +39,9 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Data.Either -import Data.Maybe +import Data.Maybe.Extra import Data.Typeable import Path -import Path.Internal (Path(..)) import qualified System.Directory as D import qualified System.FilePath as FP import System.IO.Error @@ -68,11 +63,17 @@ -- | Parse a directory path. If it's relative, then the absolute version -- is yielded, based off the working directory. +-- +-- NOTE that this only works if the directory exists, but does not +-- ensure that it's a directory. parseRelAsAbsDir :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs Dir) parseRelAsAbsDir fp = parseAbsDir =<< liftIO (D.canonicalizePath fp) -- | Parse a file path. If it's relative, then the absolute version is -- yielded, based off the working directory. +-- +-- NOTE that this only works if the file exists, but does not ensure +-- that it's a file. parseRelAsAbsFile :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs File) parseRelAsAbsFile fp = parseAbsFile =<< liftIO (D.canonicalizePath fp) @@ -129,50 +130,12 @@ => Path Abs Dir -> FilePath -> m (Maybe (Path Abs File)) resolveFileMaybe = resolveCheckParse D.doesFileExist parseAbsFile --- | Collapse intermediate "." and ".." directories from path, then parse --- it with 'parseAbsFile'. --- (probably should be moved to the Path module) -parseCollapsedAbsFile :: MonadThrow m => FilePath -> m (Path Abs File) -parseCollapsedAbsFile = parseAbsFile . collapseFilePath - --- | Collapse intermediate "." and ".." directories from path, then parse --- it with 'parseAbsDir'. --- (probably should be moved to the Path module) -parseCollapsedAbsDir :: MonadThrow m => FilePath -> m (Path Abs Dir) -parseCollapsedAbsDir = parseAbsDir . collapseFilePath - --- | Collapse intermediate "." and ".." directories from a path. --- --- > collapseFilePath "./foo" == "foo" --- > collapseFilePath "/bar/../baz" == "/baz" --- > collapseFilePath "/../baz" == "/../baz" --- > collapseFilePath "parent/foo/baz/../bar" == "parent/foo/bar" --- > collapseFilePath "parent/foo/baz/../../bar" == "parent/bar" --- > collapseFilePath "parent/foo/.." == "parent" --- > collapseFilePath "/parent/foo/../../bar" == "/bar" --- --- (borrowed from @Text.Pandoc.Shared@) -collapseFilePath :: FilePath -> FilePath -collapseFilePath = FP.joinPath . reverse . foldl go [] . FP.splitDirectories - where - go rs "." = rs - go r@(p:rs) ".." = case p of - ".." -> ("..":r) - (checkPathSeperator -> Just True) -> ("..":r) - _ -> rs - go _ (checkPathSeperator -> Just True) = [[FP.pathSeparator]] - go rs x = x:rs - isSingleton [] = Nothing - isSingleton [x] = Just x - isSingleton _ = Nothing - checkPathSeperator = fmap FP.isPathSeparator . isSingleton - -- | List objects in a directory, excluding "@.@" and "@..@". Entries are not sorted. listDirectory :: (MonadIO m,MonadThrow m) => Path Abs Dir -> m ([Path Abs Dir],[Path Abs File]) listDirectory dir = do entriesFP <- liftIO (D.getDirectoryContents dirFP) - maybeEntries <- - forM (map (dirFP ++) entriesFP) + entries <- + forMaybeM (map (dirFP ++) entriesFP) (\entryFP -> do isDir <- liftIO (D.doesDirectoryExist entryFP) if isDir @@ -185,7 +148,6 @@ else case parseAbsFile entryFP of Nothing -> return Nothing Just entryFile -> return (Just (Right entryFile))) - let entries = catMaybes maybeEntries return (lefts entries,rights entries) where dirFP = toFilePath dir @@ -281,12 +243,6 @@ case stripDir srcDir srcSubDir of Nothing -> return () Just relSubDir -> copyDirectoryRecursive srcSubDir (destDir relSubDir)) - - --- | Drop the root (either @\/@ on POSIX or @C:\\@, @D:\\@, etc. on --- Windows). -dropRoot :: Path Abs t -> Path Rel t -dropRoot (Path l) = Path (FP.dropDrive l) -- Utility function for a common pattern of ignoring does-not-exist errors. ignoreDoesNotExist :: MonadIO m => IO () -> m () diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -10,11 +10,10 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} --- | Build project(s). +-- | Build the project. module Stack.Build (build - ,clean ,withLoadPackage ,mkBaseConfigOpts ,queryBuildInfo) @@ -29,20 +28,20 @@ import Data.Aeson (Value (Object, Array), (.=), object) import Data.Function import qualified Data.HashMap.Strict as HM +import Data.IORef.RunOnce (runOnce) import qualified Data.Map as Map import Data.Map.Strict (Map) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.IO as TIO import Data.Text.Encoding (decodeUtf8) +import qualified Data.Text.IO as TIO import Data.Text.Read (decimal) import qualified Data.Vector as V import qualified Data.Yaml as Yaml import Network.HTTP.Client.Conduit (HasHttpManager) import Path -import Path.IO import Prelude hiding (FilePath, writeFile) import Stack.Build.ConstructPlan import Stack.Build.Execute @@ -50,7 +49,6 @@ import Stack.Build.Installed import Stack.Build.Source import Stack.Build.Target -import Stack.Constants import Stack.Fetch as Fetch import Stack.GhcPkg import Stack.Package @@ -87,7 +85,7 @@ $ Set.unions $ map lpFiles locals - (installedMap, globallyRegistered, locallyRegistered) <- + (installedMap, globalDumpPkgs, snapshotDumpPkgs, localDumpPkgs) <- getInstalled menv GetInstalledOpts { getInstalledProfiling = profiling @@ -96,7 +94,7 @@ baseConfigOpts <- mkBaseConfigOpts bopts plan <- withLoadPackage menv $ \loadPackage -> - constructPlan mbp baseConfigOpts locals extraToBuild locallyRegistered loadPackage sourceMap installedMap + constructPlan mbp baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap -- If our work to do is all local, let someone else have a turn with the snapshot. -- They won't damage what's already in there. @@ -114,8 +112,9 @@ if boptsDryrun bopts then printPlan plan else executePlan menv bopts baseConfigOpts locals - globallyRegistered - sourceMap + globalDumpPkgs + snapshotDumpPkgs + localDumpPkgs installedMap plan where @@ -160,7 +159,7 @@ -> m a withLoadPackage menv inner = do econfig <- asks getEnvConfig - withCabalLoader menv $ \cabalLoader -> + withCabalLoader' <- runOnce $ withCabalLoader menv $ \cabalLoader -> inner $ \name version flags -> do bs <- cabalLoader $ PackageIdentifier name version -- TODO automatically update index the first time this fails @@ -169,6 +168,7 @@ -- resolving the package index. (_warnings,pkg) <- readPackageBS (depPackageConfig econfig flags) bs return pkg + withCabalLoader' where -- | Package config to be used for dependencies depPackageConfig :: EnvConfig -> Map FlagName Bool -> PackageConfig @@ -180,14 +180,6 @@ , packageConfigPlatform = configPlatform (getConfig econfig) } --- | Reset the build (remove Shake database and .gen files). -clean :: (M env m) => m () -clean = do - econfig <- asks getEnvConfig - forM_ - (Map.keys (envConfigPackages econfig)) - (distDirFromDir >=> removeTreeIfExists) - -- | Set the code page for this process as necessary. Only applies to Windows. -- See: https://github.com/commercialhaskell/stack/issues/738 fixCodePage :: (MonadIO m, MonadMask m, MonadLogger m) => m a -> m a @@ -242,7 +234,7 @@ queryBuildInfo :: M env m => [Text] -- ^ selectors -> m () -queryBuildInfo selectors0 = do +queryBuildInfo selectors0 = rawBuildInfo >>= select id selectors0 >>= liftIO . TIO.putStrLn . decodeUtf8 . Yaml.encode diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -21,12 +21,6 @@ , setTestSuccess , unsetTestSuccess , checkTestSuccess - , setTestBuilt - , unsetTestBuilt - , checkTestBuilt - , setBenchBuilt - , unsetBenchBuilt - , checkBenchBuilt , writePrecompiledCache , readPrecompiledCache ) where @@ -121,7 +115,9 @@ => (Path Abs Dir -> m (Path Abs File)) -> Path Abs Dir -> m (Maybe a) -tryGetCache get' dir = get' dir >>= decodeFileOrFailDeep . toFilePath +tryGetCache get' dir = do + fp <- get' dir + decodeFileOrFailDeep fp -- | Write the dirtiness cache for this package's files. writeBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env) @@ -130,9 +126,9 @@ writeCache dir buildCacheFile - (BuildCache + BuildCache { buildCacheTimes = times - }) + } -- | Write the dirtiness cache for this package's configuration. writeConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env) @@ -167,7 +163,7 @@ -> m () writeCache dir get' content = do fp <- get' dir - taggedEncodeFile (toFilePath fp) content + taggedEncodeFile fp content flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) => Installed @@ -184,8 +180,9 @@ tryGetFlagCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) => Installed -> m (Maybe ConfigCache) -tryGetFlagCache gid = - flagCacheFile gid >>= decodeFileOrFailDeep . toFilePath +tryGetFlagCache gid = do + fp <- flagCacheFile gid + decodeFileOrFailDeep fp writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m) => Installed @@ -195,7 +192,7 @@ file <- flagCacheFile gid liftIO $ do createTree (parent file) - taggedEncodeFile (toFilePath file) cache + taggedEncodeFile file cache -- | Mark a test suite as having succeeded setTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env) @@ -226,64 +223,6 @@ (fromMaybe False) (tryGetCache testSuccessFile dir) --- | Mark a test suite as having built -setTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env) - => Path Abs Dir - -> m () -setTestBuilt dir = - writeCache - dir - testBuiltFile - True - --- | Mark a test suite as not having built -unsetTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env) - => Path Abs Dir - -> m () -unsetTestBuilt dir = - writeCache - dir - testBuiltFile - False - --- | Check if the test suite already built -checkTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env) - => Path Abs Dir - -> m Bool -checkTestBuilt dir = - liftM - (fromMaybe False) - (tryGetCache testBuiltFile dir) - --- | Mark a bench suite as having built -setBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env) - => Path Abs Dir - -> m () -setBenchBuilt dir = - writeCache - dir - benchBuiltFile - True - --- | Mark a bench suite as not having built -unsetBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env) - => Path Abs Dir - -> m () -unsetBenchBuilt dir = - writeCache - dir - benchBuiltFile - False - --- | Check if the bench suite already built -checkBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env) - => Path Abs Dir - -> m Bool -checkBenchBuilt dir = - liftM - (fromMaybe False) - (tryGetCache benchBuiltFile dir) - -------------------------------------- -- Precompiled Cache -- @@ -342,7 +281,7 @@ -> PackageIdentifier -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies - -> Maybe GhcPkgId -- ^ library + -> Installed -- ^ library -> Set Text -- ^ executables -> m () writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do @@ -350,14 +289,14 @@ createTree $ parent file mlibpath <- case mghcPkgId of - Nothing -> return Nothing - Just ipid -> liftM Just $ do + Executable _ -> return Nothing + Library _ ipid -> liftM Just $ do ipid' <- parseRelFile $ ghcPkgIdString ipid ++ ".conf" return $ toFilePath $ bcoSnapDB baseConfigOpts ipid' exes' <- forM (Set.toList exes) $ \exe -> do name <- parseRelFile $ T.unpack exe return $ toFilePath $ bcoSnapInstallRoot baseConfigOpts bindirSuffix name - liftIO $ taggedEncodeFile (toFilePath file) PrecompiledCache + liftIO $ taggedEncodeFile file PrecompiledCache { pcLibrary = mlibpath , pcExes = exes' } @@ -371,4 +310,4 @@ -> m (Maybe PrecompiledCache) readPrecompiledCache pkgident copts depIDs = do file <- precompiledCacheFile pkgident copts depIDs - decodeFileOrFailDeep $ toFilePath file + decodeFileOrFailDeep file diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -3,17 +3,20 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} -- | Construct a @Plan@ for how to build module Stack.Build.ConstructPlan ( constructPlan ) where +import Control.Arrow ((&&&)) import Control.Exception.Lifted import Control.Monad import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class -import Control.Monad.Logger (MonadLogger) +import Control.Monad.Logger (MonadLogger, logWarn) import Control.Monad.RWS.Strict import Control.Monad.Trans.Resource import qualified Data.ByteString.Char8 as S8 @@ -31,7 +34,7 @@ import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Distribution.Package (Dependency (..)) -import Distribution.Version (anyVersion) +import Distribution.Version (anyVersion) import Network.HTTP.Client.Conduit (HasHttpManager) import Prelude hiding (pi, writeFile) import Stack.Build.Cache @@ -40,25 +43,24 @@ import Stack.Build.Source import Stack.Types.Build import Stack.BuildPlan - import Stack.Package -import Stack.PackageIndex +import Stack.PackageDump import Stack.Types data PackageInfo - = PIOnlyInstalled Version InstallLocation Installed + = PIOnlyInstalled InstallLocation Installed | PIOnlySource PackageSource | PIBoth PackageSource Installed combineSourceInstalled :: PackageSource - -> (Version, InstallLocation, Installed) + -> (InstallLocation, Installed) -> PackageInfo -combineSourceInstalled ps (version, location, installed) = - assert (piiVersion ps == version) $ +combineSourceInstalled ps (location, installed) = + assert (piiVersion ps == installedVersion installed) $ assert (piiLocation ps == location) $ case location of -- Always trust something in the snapshot - Snap -> PIOnlyInstalled version location installed + Snap -> PIOnlyInstalled location installed Local -> PIBoth ps installed type CombinedMap = Map PackageName PackageInfo @@ -67,25 +69,27 @@ combineMap = Map.mergeWithKey (\_ s i -> Just $ combineSourceInstalled s i) (fmap PIOnlySource) - (fmap (\(v, l, i) -> PIOnlyInstalled v l i)) + (fmap (uncurry PIOnlyInstalled)) data AddDepRes = ADRToInstall Task - | ADRFound InstallLocation Version Installed + | ADRFound InstallLocation Installed deriving Show data W = W - { wFinals :: !(Map PackageName (Either ConstructPlanException (Task, LocalPackageTB))) + { wFinals :: !(Map PackageName (Either ConstructPlanException Task)) , wInstall :: !(Map Text InstallLocation) -- ^ executable to be installed, and location where the binary is placed , wDirty :: !(Map PackageName Text) -- ^ why a local package is considered dirty , wDeps :: !(Set PackageName) -- ^ Packages which count as dependencies + , wWarnings :: !([Text] -> [Text]) + -- ^ Warnings } instance Monoid W where - mempty = W mempty mempty mempty mempty - mappend (W a b c d) (W w x y z) = W (mappend a w) (mappend b x) (mappend c y) (mappend d z) + mempty = W mempty mempty mempty mempty mempty + mappend (W a b c d e) (W w x y z z') = W (mappend a w) (mappend b x) (mappend c y) (mappend d z) (mappend e z') type M = RWST Ctx @@ -104,6 +108,7 @@ , extraToBuild :: !(Set PackageName) , latestVersions :: !(Map PackageName Version) , wanted :: !(Set PackageName) + , localNames :: !(Set PackageName) } instance HasStackRoot Ctx @@ -121,29 +126,27 @@ -> BaseConfigOpts -> [LocalPackage] -> Set PackageName -- ^ additional packages that must be built - -> Map GhcPkgId PackageIdentifier -- ^ locally registered + -> [DumpPackage () ()] -- ^ locally registered -> (PackageName -> Version -> Map FlagName Bool -> IO Package) -- ^ load upstream package -> SourceMap -> InstalledMap -> m Plan -constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 locallyRegistered loadPackage0 sourceMap installedMap = do - menv <- getMinimalEnvOverride - caches <- getPackageCaches menv - let latest = Map.fromListWith max $ map toTuple $ Map.keys caches +constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap = do + let locallyRegistered = Map.fromList $ map (dpGhcPkgId &&& dpPackageIdent) localDumpPkgs + bconfig <- asks getBuildConfig + let latest = + Map.fromListWith max $ + map toTuple $ + Map.keys (bcPackageCaches bconfig) econfig <- asks getEnvConfig - let onWanted lp = do - case lpExeComponents lp of - Nothing -> return () - Just _ -> void $ addDep False $ packageName $ lpPackage lp - - case lpTestBench lp of - Just tb -> addFinal lp tb - Nothing -> return () + let onWanted = void . addDep False . packageName . lpPackage let inner = do mapM_ onWanted $ filter lpWanted locals mapM_ (addDep False) $ Set.toList extraToBuild0 - ((), m, W efinals installExes dirtyReason deps) <- liftIO $ runRWST inner (ctx econfig latest) M.empty + ((), m, W efinals installExes dirtyReason deps warnings) <- + liftIO $ runRWST inner (ctx econfig latest) M.empty + mapM_ $logWarn (warnings []) let toEither (_, Left e) = Left e toEither (k, Right v) = Right (k, v) (errlibs, adrs) = partitionEithers $ map toEither $ M.toList m @@ -151,7 +154,7 @@ errs = errlibs ++ errfinals if null errs then do - let toTask (_, ADRFound _ _ _) = Nothing + let toTask (_, ADRFound _ _) = Nothing toTask (name, ADRToInstall task) = Just (name, task) tasks = M.fromList $ mapMaybe toTask adrs takeSubset = @@ -176,13 +179,14 @@ , loadPackage = loadPackage0 , combinedMap = combineMap sourceMap installedMap , toolToPackages = \ (Dependency name _) -> - maybe Map.empty (Map.fromSet (\_ -> anyVersion)) $ + maybe Map.empty (Map.fromSet (const anyVersion)) $ Map.lookup (S8.pack . packageNameString . fromCabalPackageName $ name) toolMap , ctxEnvConfig = econfig , callStack = [] , extraToBuild = extraToBuild0 , latestVersions = latest , wanted = wantedLocalPackages locals + , localNames = Set.fromList $ map (packageName . lpPackage) locals } -- TODO Currently, this will only consider and install tools from the -- snapshot. It will not automatically install build tools from extra-deps @@ -215,14 +219,14 @@ where name = packageIdentifierName ident -addFinal :: LocalPackage -> LocalPackageTB -> M () -addFinal lp lptb = do +addFinal :: LocalPackage -> Package -> Bool -> M () +addFinal lp package isAllInOne = do depsRes <- addPackageDeps False package res <- case depsRes of Left e -> return $ Left e Right (missing, present, _minLoc) -> do ctx <- ask - return $ Right (Task + return $ Right Task { taskProvides = PackageIdentifier (packageName package) (packageVersion package) @@ -238,13 +242,13 @@ package , taskPresent = present , taskType = TTLocal lp - }, lptb) + , taskAllInOne = isAllInOne + } tell mempty { wFinals = Map.singleton (packageName package) res } - where - package = lptbPackage lptb addDep :: Bool -- ^ is this being used by a dependency? - -> PackageName -> M (Either ConstructPlanException AddDepRes) + -> PackageName + -> M (Either ConstructPlanException AddDepRes) addDep treatAsDep' name = do ctx <- ask let treatAsDep = treatAsDep' || name `Set.notMember` wanted ctx @@ -253,46 +257,31 @@ case Map.lookup name m of Just res -> return res Nothing -> do - res <- addDep' treatAsDep name + res <- if name `elem` callStack ctx + then return $ Left $ DependencyCycleDetected $ name : callStack ctx + else local (\ctx' -> ctx' { callStack = name : callStack ctx' }) $ + case Map.lookup name $ combinedMap ctx of + -- TODO look up in the package index and see if there's a + -- recommendation available + Nothing -> return $ Left $ UnknownPackage name + Just (PIOnlyInstalled loc installed) -> do + -- slightly hacky, no flags since they likely won't affect executable names + tellExecutablesUpstream name (installedVersion installed) loc Map.empty + return $ Right $ ADRFound loc installed + Just (PIOnlySource ps) -> do + tellExecutables name ps + installPackage treatAsDep name ps Nothing + Just (PIBoth ps installed) -> do + tellExecutables name ps + installPackage treatAsDep name ps (Just installed) modify $ Map.insert name res return res -addDep' :: Bool -- ^ is this being used by a dependency? - -> PackageName -> M (Either ConstructPlanException AddDepRes) -addDep' treatAsDep name = do - ctx <- ask - if name `elem` callStack ctx - then return $ Left $ DependencyCycleDetected $ name : callStack ctx - else local - (\ctx' -> ctx' { callStack = name : callStack ctx' }) $ do - (addDep'' treatAsDep name) - -addDep'' :: Bool -- ^ is this being used by a dependency? - -> PackageName -> M (Either ConstructPlanException AddDepRes) -addDep'' treatAsDep name = do - ctx <- ask - case Map.lookup name $ combinedMap ctx of - -- TODO look up in the package index and see if there's a - -- recommendation available - Nothing -> return $ Left $ UnknownPackage name - Just (PIOnlyInstalled version loc installed) -> do - tellExecutablesUpstream name version loc Map.empty -- slightly hacky, no flags since they likely won't affect executable names - return $ Right $ ADRFound loc version installed - Just (PIOnlySource ps) -> do - tellExecutables name ps - installPackage treatAsDep name ps - Just (PIBoth ps installed) -> do - tellExecutables name ps - needInstall <- checkNeedInstall treatAsDep name ps installed (wanted ctx) - if needInstall - then installPackage treatAsDep name ps - else return $ Right $ ADRFound (piiLocation ps) (piiVersion ps) installed - -tellExecutables :: PackageName -> PackageSource -> M () -- TODO merge this with addFinal above? +tellExecutables :: PackageName -> PackageSource -> M () tellExecutables _ (PSLocal lp) | lpWanted lp = tellExecutablesPackage Local $ lpPackage lp | otherwise = return () -tellExecutables name (PSUpstream version loc flags) = do +tellExecutables name (PSUpstream version loc flags) = tellExecutablesUpstream name version loc flags tellExecutablesUpstream :: PackageName -> Version -> InstallLocation -> Map FlagName Bool -> M () @@ -309,75 +298,127 @@ let myComps = case Map.lookup (packageName p) cm of Nothing -> assert False Set.empty - Just (PIOnlyInstalled _ _ _) -> Set.empty + Just (PIOnlyInstalled _ _) -> Set.empty Just (PIOnlySource ps) -> goSource ps Just (PIBoth ps _) -> goSource ps - goSource (PSLocal lp) = fromMaybe Set.empty $ lpExeComponents lp - goSource (PSUpstream _ _ _) = Set.empty + goSource (PSLocal lp) + | lpWanted lp = exeComponents (lpComponents lp) + | otherwise = Set.empty + goSource (PSUpstream{}) = Set.empty - tell mempty { wInstall = m myComps } + tell mempty { wInstall = Map.fromList $ map (, loc) $ Set.toList $ filterComps myComps $ packageExes p } where - m myComps = Map.fromList $ map (, loc) $ Set.toList - $ filterComps myComps $ packageExes p - filterComps myComps x | Set.null myComps = x - | otherwise = Set.intersection x $ Set.map toExe myComps - - toExe x = fromMaybe x $ T.stripPrefix "exe:" x - --- TODO There are a lot of duplicated computations below. I've kept that for --- simplicity right now + | otherwise = Set.intersection x myComps installPackage :: Bool -- ^ is this being used by a dependency? - -> PackageName -> PackageSource -> M (Either ConstructPlanException AddDepRes) -installPackage treatAsDep name ps = do + -> PackageName + -> PackageSource + -> Maybe Installed + -> M (Either ConstructPlanException AddDepRes) +installPackage treatAsDep name ps minstalled = do ctx <- ask - package <- psPackage name ps - depsRes <- addPackageDeps treatAsDep package - case depsRes of - Left e -> return $ Left e - Right (missing, present, minLoc) -> do - return $ Right $ ADRToInstall Task - { taskProvides = PackageIdentifier - (packageName package) - (packageVersion package) - , taskConfigOpts = TaskConfigOpts missing $ \missing' -> - let allDeps = Map.union present missing' - destLoc = piiLocation ps <> minLoc - in configureOpts - (getEnvConfig ctx) - (baseConfigOpts ctx) - allDeps - (psWanted ps) - (psLocal ps) - -- An assertion to check for a recurrence of - -- https://github.com/commercialhaskell/stack/issues/345 - (assert (destLoc == piiLocation ps) destLoc) - package - , taskPresent = present - , taskType = - case ps of - PSLocal lp -> TTLocal lp - PSUpstream _ loc _ -> TTUpstream package $ loc <> minLoc - } + case ps of + PSUpstream version _ flags -> do + package <- liftIO $ loadPackage ctx name version flags + resolveDepsAndInstall False treatAsDep ps package minstalled + PSLocal lp -> + case lpTestBench lp of + Nothing -> resolveDepsAndInstall False treatAsDep ps (lpPackage lp) minstalled + Just tb -> do + -- Attempt to find a plan which performs an all-in-one + -- build. Ignore the writer action + reset the state if + -- it fails. + s <- get + res <- pass $ do + res <- addPackageDeps treatAsDep tb + let writerFunc w = case res of + Left _ -> mempty + _ -> w + return (res, writerFunc) + case res of + Right deps -> do + adr <- installPackageGivenDeps True ps tb minstalled deps + -- FIXME: this redundantly adds the deps (but + -- they'll all just get looked up in the map) + addFinal lp tb True + return $ Right adr + Left _ -> do + -- Reset the state to how it was before + -- attempting to find an all-in-one build + -- plan. + put s + -- Otherwise, fall back on building the + -- tests / benchmarks in a separate step. + res' <- resolveDepsAndInstall False treatAsDep ps (lpPackage lp) minstalled + when (isRight res') $ do + -- Insert it into the map so that it's + -- available for addFinal. + modify $ Map.insert name res' + addFinal lp tb False + return res' -checkNeedInstall :: Bool - -> PackageName -> PackageSource -> Installed -> Set PackageName -> M Bool -checkNeedInstall treatAsDep name ps installed wanted = assert (piiLocation ps == Local) $ do - package <- psPackage name ps - depsRes <- addPackageDeps treatAsDep package - case depsRes of - Left _e -> return True -- installPackage will find the error again - Right (missing, present, _loc) - | Set.null missing -> checkDirtiness ps installed package present wanted - | otherwise -> do - tell mempty { wDirty = Map.singleton name $ - let t = T.intercalate ", " $ map (T.pack . packageNameString . packageIdentifierName) (Set.toList missing) - in T.append "missing dependencies: " $ addEllipsis t } - return True +resolveDepsAndInstall :: Bool + -> Bool + -> PackageSource + -> Package + -> Maybe Installed + -> M (Either ConstructPlanException AddDepRes) +resolveDepsAndInstall isAllInOne treatAsDep ps package minstalled = do + res <- addPackageDeps treatAsDep package + case res of + Left err -> return $ Left err + Right deps -> liftM Right $ installPackageGivenDeps isAllInOne ps package minstalled deps +installPackageGivenDeps :: Bool + -> PackageSource + -> Package + -> Maybe Installed + -> ( Set PackageIdentifier + , Map PackageIdentifier GhcPkgId + , InstallLocation ) + -> M AddDepRes +installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minLoc) = do + let name = packageName package + ctx <- ask + mRightVersionInstalled <- case (minstalled, Set.null missing) of + (Just installed, True) -> do + shouldInstall <- checkDirtiness ps installed package present (wanted ctx) + return $ if shouldInstall then Nothing else Just installed + (Just _, False) -> do + let t = T.intercalate ", " $ map (T.pack . packageNameString . packageIdentifierName) (Set.toList missing) + tell mempty { wDirty = Map.singleton name $ "missing dependencies: " <> addEllipsis t } + return Nothing + (Nothing, _) -> return Nothing + return $ case mRightVersionInstalled of + Just installed -> ADRFound (piiLocation ps) installed + Nothing -> ADRToInstall Task + { taskProvides = PackageIdentifier + (packageName package) + (packageVersion package) + , taskConfigOpts = TaskConfigOpts missing $ \missing' -> + let allDeps = Map.union present missing' + destLoc = piiLocation ps <> minLoc + in configureOpts + (getEnvConfig ctx) + (baseConfigOpts ctx) + allDeps + (psWanted ps) + (psLocal ps) + -- An assertion to check for a recurrence of + -- https://github.com/commercialhaskell/stack/issues/345 + (assert (destLoc == piiLocation ps) destLoc) + package + , taskPresent = present + , taskType = + case ps of + PSLocal lp -> TTLocal lp + PSUpstream _ loc _ -> TTUpstream package $ loc <> minLoc + , taskAllInOne = isAllInOne + } + addEllipsis :: Text -> Text addEllipsis t | T.length t < 100 = t @@ -398,14 +439,45 @@ UnknownPackage name -> assert (name == depname) NotInBuildPlan _ -> Couldn'tResolveItsDependencies in return $ Left (depname, (range, mlatest, bd)) - Right adr | not $ adrVersion adr `withinRange` range -> - return $ Left (depname, (range, mlatest, DependencyMismatch $ adrVersion adr)) - Right (ADRToInstall task) -> return $ Right - (Set.singleton $ taskProvides task, Map.empty, taskLocation task) - Right (ADRFound loc _ (Executable _)) -> return $ Right - (Set.empty, Map.empty, loc) - Right (ADRFound loc _ (Library ident gid)) -> return $ Right - (Set.empty, Map.singleton ident gid, loc) + Right adr -> do + inRange <- if adrVersion adr `withinRange` range + then return True + else do + let warn reason = + tell mempty { wWarnings = (msg:) } + where + msg = T.concat + [ "WARNING: Ignoring out of range dependency" + , reason + , ": " + , T.pack $ packageIdentifierString $ PackageIdentifier depname (adrVersion adr) + , ". " + , T.pack $ packageNameString $ packageName package + , " requires: " + , versionRangeText range + ] + allowNewer <- asks $ configAllowNewer . getConfig + if allowNewer + then do + warn " (allow-newer enabled)" + return True + else do + x <- inSnapshot (packageName package) (packageVersion package) + y <- inSnapshot depname (adrVersion adr) + if x && y + then do + warn " (trusting snapshot over Hackage revisions)" + return True + else return False + if inRange + then case adr of + ADRToInstall task -> return $ Right + (Set.singleton $ taskProvides task, Map.empty, taskLocation task) + ADRFound loc (Executable _) -> return $ Right + (Set.empty, Map.empty, loc) + ADRFound loc (Library ident gid) -> return $ Right + (Set.empty, Map.singleton ident gid, loc) + else return $ Left (depname, (range, mlatest, DependencyMismatch $ adrVersion adr)) case partitionEithers deps of ([], pairs) -> return $ Right $ mconcat pairs (errs, _) -> return $ Left $ DependencyPlanFailures @@ -415,7 +487,7 @@ (Map.fromList errs) where adrVersion (ADRToInstall task) = packageIdentifierVersion $ taskProvides task - adrVersion (ADRFound _ v _) = v + adrVersion (ADRFound _ installed) = installedVersion installed checkDirtiness :: PackageSource -> Installed @@ -441,7 +513,7 @@ , configCacheComponents = case ps of PSLocal lp -> Set.map renderComponent $ lpComponents lp - PSUpstream _ _ _ -> Set.empty + PSUpstream{} -> Set.empty , configCacheHaddock = shouldHaddockPackage buildOpts wanted (packageName package) || -- Disabling haddocks when old config had haddocks doesn't make dirty. @@ -497,17 +569,26 @@ go where go [] = [] - go ("--ghc-option":_:xs) = go xs - go ("--ghc-options":_:xs) = go xs - go (x:xs) - | isPrefixed x = go xs - | otherwise = x : go xs + go ("--ghc-option":x:xs) = go' x xs + go ("--ghc-options":x:xs) = go' x xs + go ((T.stripPrefix "--ghc-option=" -> Just x):xs) = go' x xs + go ((T.stripPrefix "--ghc-options=" -> Just x):xs) = go' x xs + go (x:xs) = x : go xs - isPrefixed t = any (`T.isPrefixOf` t) - [ "--ghc-option=" - , "--ghc-options=" - ] + go' x xs = checkKeepers x $ go xs + checkKeepers x xs = + case filter isKeeper $ T.words x of + [] -> xs + keepers -> "--ghc-options" : T.unwords keepers : xs + + -- GHC options which affect build results and therefore should always + -- force a rebuild + -- + -- For the most part, we only care about options generated by Stack + -- itself + isKeeper = (== "-fhpc") -- more to be added later + userOpts = filter (not . isStackOpt) . (if configRebuildGhcOptions config then id @@ -526,21 +607,15 @@ psDirty :: PackageSource -> Maybe (Set FilePath) psDirty (PSLocal lp) = lpDirtyFiles lp -psDirty (PSUpstream _ _ _) = Nothing -- files never change in an upstream package +psDirty (PSUpstream {}) = Nothing -- files never change in an upstream package psWanted :: PackageSource -> Bool psWanted (PSLocal lp) = lpWanted lp -psWanted (PSUpstream _ _ _) = False +psWanted (PSUpstream {}) = False psLocal :: PackageSource -> Bool psLocal (PSLocal _) = True -psLocal (PSUpstream _ _ _) = False - -psPackage :: PackageName -> PackageSource -> M Package -psPackage _ (PSLocal lp) = return $ lpPackage lp -psPackage name (PSUpstream version _ flags) = do - ctx <- ask - liftIO $ loadPackage ctx name version flags +psLocal (PSUpstream {}) = False -- | Get all of the dependencies for a given package, including guessed build -- tool dependencies. @@ -577,3 +652,13 @@ markAsDep :: PackageName -> M () markAsDep name = tell mempty { wDeps = Set.singleton name } + +-- | Is the given package/version combo defined in the snapshot? +inSnapshot :: PackageName -> Version -> M Bool +inSnapshot name version = do + p <- asks mbp + ls <- asks localNames + return $ fromMaybe False $ do + guard $ not $ name `Set.member` ls + mpi <- Map.lookup name (mbpPackages p) + return $ mpiVersion mpi == version diff --git a/src/Stack/Build/Coverage.hs b/src/Stack/Build/Coverage.hs deleted file mode 100644 --- a/src/Stack/Build/Coverage.hs +++ /dev/null @@ -1,259 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} --- | Generate HPC (Haskell Program Coverage) reports -module Stack.Build.Coverage - ( updateTixFile - , generateHpcReport - , generateHpcUnifiedReport - , generateHpcMarkupIndex - ) where - -import Control.Applicative -import Control.Exception.Lifted -import Control.Monad (liftM, when, void) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class -import Control.Monad.Logger -import Control.Monad.Reader (MonadReader, asks) -import Control.Monad.Trans.Resource -import qualified Data.ByteString.Char8 as S8 -import Data.Foldable (forM_) -import Data.Function -import Data.List -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T -import qualified Data.Text.Lazy as LT -import Data.Traversable (forM) -import Trace.Hpc.Tix -import Path -import Path.IO -import Prelude hiding (FilePath, writeFile) -import Stack.Constants -import Stack.Package -import Stack.Types -import System.Process.Read -import Text.Hastache (htmlEscape) - --- | Move a tix file into a sub-directory of the hpc report directory. --- Deletes the old one if one is present. -updateTixFile :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) - => Path Abs File -> String -> m () -updateTixFile tixSrc pkgId = do - exists <- fileExists tixSrc - when exists $ do - outputDir <- hpcReportDir - pkgIdRel <- parseRelDir pkgId - let tixDest = outputDir pkgIdRel filename tixSrc - removeFileIfExists tixDest - createTree (parent tixDest) - renameFile tixSrc tixDest - --- | Get the tix file location, given the name of the file (without --- extension), and the package identifier string. -tixFilePath :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) - => String -> String -> m (Path Abs File) -tixFilePath pkgId tixName = do - outputDir <- hpcReportDir - pkgIdRel <- parseRelDir pkgId - tixRel <- parseRelFile (tixName ++ ".tix") - return (outputDir pkgIdRel tixRel) - --- | Generates the HTML coverage report and shows a textual coverage --- summary for a package. -generateHpcReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) - => Package -> [Text] -> (PackageName -> m (Maybe Text)) -> m () -generateHpcReport package tests getGhcPkgKey = do - -- If we're using > GHC 7.10, the hpc 'include' parameter must specify a - -- ghc package key. See - -- https://github.com/commercialhaskell/stack/issues/785 - let pkgName = packageNameText (packageName package) - pkgId = packageIdentifierString (packageIdentifier package) - compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig) - includeName <- - if getGhcVersion compilerVersion < $(mkVersion "7.10") - then return pkgId - else do - mghcPkgKey <- getGhcPkgKey (packageName package) - case mghcPkgKey of - Nothing -> fail $ "Before computing test coverage report, failed to find GHC package key for " ++ T.unpack pkgName - Just ghcPkgKey -> return $ T.unpack ghcPkgKey - forM_ tests $ \testName -> do - tixSrc <- tixFilePath pkgId (T.unpack testName) - subdir <- parseRelDir (T.unpack testName) - let report = "coverage report for " <> pkgName <> "'s test-suite \"" <> testName <> "\"" - -- Restrict to just the current library code (see #634 - - -- this will likely be customizable in the future) - extraArgs = ["--include", includeName ++ ":"] - generateHpcReportInternal tixSrc subdir report extraArgs extraArgs - -generateHpcReportInternal :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) - => Path Abs File -> Path Rel Dir -> Text -> [String] -> [String] -> m () -generateHpcReportInternal tixSrc subdir report extraMarkupArgs extraReportArgs = do - -- If a .tix file exists, move it to the HPC output directory - -- and generate a report for it. - tixFileExists <- fileExists tixSrc - if not tixFileExists - then $logError $ T.concat - [ "Didn't find .tix for " - , report - , " - expected to find it at " - , T.pack (toFilePath tixSrc) - , "." - ] - else (`onException` $logError ("Error occurred while producing " <> report)) $ do - -- Directories for .mix files. - hpcRelDir <- ( dotHpc) <$> hpcRelativeDir - -- Compute arguments used for both "hpc markup" and "hpc report". - pkgDirs <- Map.keys . envConfigPackages <$> asks getEnvConfig - let args = - -- Use index files from all packages (allows cross-package - -- coverage results). - concatMap (\x -> ["--srcdir", toFilePath x]) pkgDirs ++ - -- Look for index files in the correct dir (relative to - -- each pkgdir). - ["--hpcdir", toFilePath hpcRelDir, "--reset-hpcdirs"] - reportDest = parent tixSrc subdir - menv <- getMinimalEnvOverride - $logInfo $ "Generating " <> report - outputLines <- liftM S8.lines $ readProcessStdout Nothing menv "hpc" - ( "report" - : toFilePath tixSrc - : (args ++ extraReportArgs) - ) - if all ("(0/0)" `S8.isSuffixOf`) outputLines - then $logError $ T.concat - [ "Error: The " - , report - , " did not consider any code. One possible cause of this is" - , " if your test-suite builds the library code (see stack" - , " issue #1008). It may also indicate a bug in stack or" - , " the hpc program. Please report this issue if you think" - , " your coverage report should have meaningful results." - ] - else do - -- Print output, stripping @\r@ characters because - -- Windows. - forM_ outputLines ($logInfo . T.decodeUtf8 . S8.filter (not . (=='\r'))) - $logInfo - ("The " <> report <> " is available at " <> - T.pack (toFilePath (reportDest $(mkRelFile "hpc_index.html")))) - -- Generate the markup. - void $ readProcessStdout Nothing menv "hpc" - ( "markup" - : toFilePath tixSrc - : ("--destdir=" ++ toFilePath reportDest) - : (args ++ extraMarkupArgs) - ) - -generateHpcUnifiedReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) - => m () -generateHpcUnifiedReport = do - outputDir <- hpcReportDir - createTree outputDir - (dirs, _) <- listDirectory outputDir - tixFiles <- liftM concat $ forM dirs $ \dir -> do - (_, files) <- listDirectory dir - return (filter ((".tix" `isSuffixOf`) . toFilePath) files) - if length tixFiles < 2 - then $logInfo $ T.concat $ - [ if null tixFiles then "No tix files" else "Only one tix file" - , " found in " - , T.pack (toFilePath outputDir) - , ", so not generating a unified coverage report." - ] - else do - tixes <- mapM (liftM (fmap removeExeModules) . readTixOrLog) tixFiles - let (errs, tix) = unionTixes (catMaybes tixes) - when (not (null errs)) $ $logWarn $ T.concat $ - "The following modules are left out of the unified report due to version mismatches: " : - intersperse ", " (map T.pack errs) - let tixDest = outputDir $(mkRelFile "unified/unified.tix") - createTree (parent tixDest) - liftIO $ writeTix (toFilePath tixDest) tix - generateHpcReportInternal tixDest $(mkRelDir "unified") "unified report" [] [] - -readTixOrLog :: (MonadLogger m, MonadIO m) => Path b File -> m (Maybe Tix) -readTixOrLog path = do - mtix <- liftIO $ readTix (toFilePath path) - when (isNothing mtix) $ - $logError $ "Failed to read tix file " <> T.pack (toFilePath path) - return mtix - --- | Module names which contain '/' have a package name, and so they --- weren't built into the executable. -removeExeModules :: Tix -> Tix -removeExeModules (Tix ms) = Tix (filter (\(TixModule name _ _ _) -> '/' `elem` name) ms) - -unionTixes :: [Tix] -> ([String], Tix) -unionTixes tixes = (Map.keys errs, Tix (Map.elems outputs)) - where - (errs, outputs) = Map.mapEither id $ Map.unionsWith merge $ map toMap tixes - toMap (Tix ms) = Map.fromList (map (\x@(TixModule k _ _ _) -> (k, Right x)) ms) - merge (Right (TixModule k hash1 len1 tix1)) - (Right (TixModule _ hash2 len2 tix2)) - | hash1 == hash2 && len1 == len2 = Right (TixModule k hash1 len1 (zipWith (+) tix1 tix2)) - merge _ _ = Left () - -generateHpcMarkupIndex :: (MonadIO m,MonadReader env m,MonadLogger m,MonadCatch m,HasEnvConfig env) - => m () -generateHpcMarkupIndex = do - outputDir <- hpcReportDir - let outputFile = outputDir $(mkRelFile "index.html") - createTree outputDir - (dirs, _) <- listDirectory outputDir - rows <- liftM (catMaybes . concat) $ forM dirs $ \dir -> do - (subdirs, _) <- listDirectory dir - forM subdirs $ \subdir -> do - let indexPath = subdir $(mkRelFile "hpc_index.html") - exists' <- fileExists indexPath - if not exists' then return Nothing else do - relPath <- stripDir outputDir indexPath - let package = dirname dir - testsuite = dirname subdir - return $ Just $ T.concat - [ "" - , pathToHtml package - , "" - , pathToHtml testsuite - , "" - ] - liftIO $ T.writeFile (toFilePath outputFile) $ T.concat $ - [ "" - -- Part of the css from HPC's output HTML - , "" - , "" - , "" - ] ++ - (if null rows - then - [ "No hpc_index.html files found in \"" - , pathToHtml outputDir - , "\"." - ] - else - [ "" - , "

NOTE: This is merely a listing of the html files found in the coverage reports directory. Some of these reports may be old.

" - , "" - ] ++ - rows ++ - ["
PackageTestSuite
"]) ++ - [""] - $logInfo $ "\nAn index of the generated HTML coverage reports is available at " <> - T.pack (toFilePath outputFile) - -pathToHtml :: Path b t -> Text -pathToHtml = T.dropWhileEnd (=='/') . LT.toStrict . htmlEscape . LT.pack . toFilePath diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -18,80 +18,83 @@ import Control.Applicative import Control.Arrow ((&&&)) +import Control.Concurrent.Async (withAsync, wait) import Control.Concurrent.Execute -import Control.Concurrent.Async (withAsync, wait) import Control.Concurrent.MVar.Lifted import Control.Concurrent.STM -import Control.Exception.Enclosed (catchIO, tryIO) +import Control.Exception.Enclosed (catchIO, tryIO) import Control.Exception.Lifted -import Control.Monad (liftM, when, unless, void, join, guard, filterM, (<=<)) -import Control.Monad.Catch (MonadCatch, MonadMask) +import Control.Monad (liftM, when, unless, void, join, guard, filterM, (<=<)) +import Control.Monad.Catch (MonadCatch, MonadMask) import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (MonadReader, asks) -import Control.Monad.Trans.Control (liftBaseWith) +import Control.Monad.Reader (MonadReader, asks) +import Control.Monad.Trans.Control (liftBaseWith) import Control.Monad.Trans.Resource -import qualified Data.ByteString as S -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as S8 +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import Data.Conduit -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.List as CL -import Data.Foldable (forM_) +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Foldable (forM_, any) import Data.Function -import Data.IORef.RunOnce (runOnce) -import Data.List -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.IORef.RunOnce (runOnce) +import Data.List hiding (any) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import Data.Maybe -import Data.Monoid ((<>)) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Streaming.Process hiding (callProcess, env) -import qualified Data.Streaming.Process as Process -import Data.Traversable (forM) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (getCurrentTime) -import Data.Word8 (_colon) +import Data.Maybe.Extra (forMaybeM) +import Data.Monoid ((<>)) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Streaming.Process as Process +import Data.Streaming.Process hiding (callProcess, env) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import Data.Time.Clock (getCurrentTime) +import Data.Traversable (forM) +import Data.Word8 (_colon) import Distribution.System (OS (Windows), Platform (Platform)) import qualified Distribution.Text -import Language.Haskell.TH as TH (location) -import Network.HTTP.Client.Conduit (HasHttpManager) +import Language.Haskell.TH as TH (location) +import Network.HTTP.Client.Conduit (HasHttpManager) import Path +import Path.Extra (toFilePathNoTrailingSep) import Path.IO -import Prelude hiding (FilePath, writeFile) +import Prelude hiding (FilePath, writeFile, any) import Stack.Build.Cache -import Stack.Build.Coverage import Stack.Build.Haddock import Stack.Build.Installed import Stack.Build.Source -import Stack.Types.Build -import Stack.Fetch as Fetch +import Stack.Constants +import Stack.Coverage +import Stack.Fetch as Fetch import Stack.GhcPkg import Stack.Package import Stack.PackageDump -import Stack.Constants import Stack.Types -import Stack.Types.StackT import Stack.Types.Internal -import qualified System.Directory as D -import System.Environment (getExecutablePath) -import System.Exit (ExitCode (ExitSuccess)) -import qualified System.FilePath as FP +import Stack.Types.StackT +import qualified System.Directory as D +import System.Environment (getExecutablePath) +import System.Exit (ExitCode (ExitSuccess)) +import qualified System.FilePath as FP import System.IO -import System.PosixCompat.Files (createLink) +import System.PosixCompat.Files (createLink) +import System.Process.Log (showProcessArgDebug) import System.Process.Read import System.Process.Run -import System.Process.Log (showProcessArgDebug) #if !MIN_VERSION_process(1,2,1) -import System.Process.Internals (createProcess_) +import System.Process.Internals (createProcess_) #endif type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env) +-- | Fetch the packages necessary for a build, for example in combination with a dry run. preFetch :: M env m => Plan -> m () preFetch plan | Set.null idents = $logDebug "Nothing to fetch" @@ -111,6 +114,7 @@ name (packageVersion package) +-- | Print a description of build plan for human consumption. printPlan :: M env m => Plan -> m () @@ -138,10 +142,10 @@ $logInfo "Would build:" mapM_ ($logInfo . displayTask) xs - let hasTests = not . Set.null . lptbTests - hasBenches = not . Set.null . lptbBenches - tests = Map.elems $ fmap fst $ Map.filter (hasTests . snd) $ planFinals plan - benches = Map.elems $ fmap fst $ Map.filter (hasBenches . snd) $ planFinals plan + let hasTests = not . Set.null . testComponents . taskComponents + hasBenches = not . Set.null . benchComponents . taskComponents + tests = Map.elems $ Map.filter hasTests $ planFinals plan + benches = Map.elems $ Map.filter hasBenches $ planFinals plan unless (null tests) $ do $logInfo "" @@ -204,9 +208,10 @@ , eeTotalWanted :: !Int , eeWanted :: !(Set PackageName) , eeLocals :: ![LocalPackage] - , eeSourceMap :: !SourceMap , eeGlobalDB :: !(Path Abs Dir) - , eeGlobalPackages :: ![DumpPackage () ()] + , eeGlobalDumpPkgs :: !(Map GhcPkgId (DumpPackage () ())) + , eeSnapshotDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () ()))) + , eeLocalDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () ()))) } -- | Get a compiled Setup exe @@ -273,16 +278,18 @@ renameFile tmpExePath exePath return $ Just exePath +-- | Execute a callback that takes an 'ExecuteEnv'. withExecuteEnv :: M env m => EnvOverride -> BuildOpts -> BaseConfigOpts -> [LocalPackage] -> [DumpPackage () ()] -- ^ global packages - -> SourceMap + -> [DumpPackage () ()] -- ^ snapshot packages + -> [DumpPackage () ()] -- ^ local packages -> (ExecuteEnv -> m a) -> m a -withExecuteEnv menv bopts baseConfigOpts locals globals sourceMap inner = do +withExecuteEnv menv bopts baseConfigOpts locals globalPackages snapshotPackages localPackages inner = do withCanonicalizedSystemTempDirectory stackProgName $ \tmpdir -> do configLock <- newMVar () installLock <- newMVar () @@ -292,6 +299,8 @@ setupExe <- getSetupExe setupHs tmpdir cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig) globalDB <- getGlobalDB menv =<< getWhichCompiler + snapshotPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages) + localPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId localPackages) inner ExecuteEnv { eeEnvOverride = menv , eeBuildOpts = bopts @@ -310,10 +319,13 @@ , eeTotalWanted = length $ filter lpWanted locals , eeWanted = wantedLocalPackages locals , eeLocals = locals - , eeSourceMap = sourceMap , eeGlobalDB = globalDB - , eeGlobalPackages = globals + , eeGlobalDumpPkgs = toDumpPackagesByGhcPkgId globalPackages + , eeSnapshotDumpPkgs = snapshotPackagesTVar + , eeLocalDumpPkgs = localPackagesTVar } + where + toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dpGhcPkgId dp, dp)) -- | Perform the actual plan executePlan :: M env m @@ -321,13 +333,14 @@ -> BuildOpts -> BaseConfigOpts -> [LocalPackage] - -> [DumpPackage () ()] -- ^ globals - -> SourceMap + -> [DumpPackage () ()] -- ^ global packages + -> [DumpPackage () ()] -- ^ snapshot packages + -> [DumpPackage () ()] -- ^ local packages -> InstalledMap -> Plan -> m () -executePlan menv bopts baseConfigOpts locals globals sourceMap installedMap plan = do - withExecuteEnv menv bopts baseConfigOpts locals globals sourceMap (executePlan' installedMap plan) +executePlan menv bopts baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap plan = do + withExecuteEnv menv bopts baseConfigOpts locals globalPackages snapshotPackages localPackages (executePlan' installedMap plan) unless (Map.null $ planInstallExes plan) $ do snapBin <- ( bindirSuffix) `liftM` installationRootDeps @@ -352,7 +365,7 @@ currExe <- liftIO getExecutablePath -- needed for windows, see below - installed <- forM (Map.toList $ planInstallExes plan) $ \(name, loc) -> do + installed <- forMaybeM (Map.toList $ planInstallExes plan) $ \(name, loc) -> do let bindir = case loc of Snap -> snapBin @@ -382,7 +395,7 @@ _ -> D.copyFile (toFilePath file) destFile return $ Just (destDir', [T.append name (T.pack ext)]) - let destToInstalled = Map.fromListWith (++) (catMaybes installed) + let destToInstalled = Map.fromListWith (++) installed unless (Map.null destToInstalled) $ $logInfo "" forM_ (Map.toList destToInstalled) $ \(dest, executables) -> do $logInfo $ T.concat @@ -419,7 +432,8 @@ -> Plan -> ExecuteEnv -> m () -executePlan' installedMap plan ee@ExecuteEnv {..} = do +executePlan' installedMap0 plan ee@ExecuteEnv {..} = do + when (toCoverage $ boptsTestOpts eeBuildOpts) deleteHpcReports wc <- getWhichCompiler cv <- asks $ envConfigCompilerVersion . getEnvConfig case Map.toList $ planUnregisterLocal plan of @@ -440,6 +454,9 @@ ] unregisterGhcPkgId eeEnvOverride wc cv localDB id' ident + liftIO $ atomically $ modifyTVar' eeLocalDumpPkgs $ \initMap -> + foldl' (flip Map.delete) initMap $ Map.keys (planUnregisterLocal plan) + -- Yes, we're explicitly discarding result values, which in general would -- be bad. monad-unlift does this all properly at the type system level, -- but I don't want to pull it in for this one use case, when we know that @@ -482,16 +499,18 @@ if total > 1 then loop 0 else return () - unless (null errs) $ throwM $ ExecutionFailure errs - when (boptsHaddock eeBuildOpts) $ do - generateLocalHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeLocals - generateDepsHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeLocals - generateSnapHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDB when (toCoverage $ boptsTestOpts eeBuildOpts) $ do generateHpcUnifiedReport generateHpcMarkupIndex + unless (null errs) $ throwM $ ExecutionFailure errs + when (boptsHaddock eeBuildOpts) $ do + snapshotDumpPkgs <- liftIO (readTVarIO eeSnapshotDumpPkgs) + localDumpPkgs <- liftIO (readTVarIO eeLocalDumpPkgs) + generateLocalHaddockIndex eeEnvOverride wc eeBaseConfigOpts localDumpPkgs eeLocals + generateDepsHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs localDumpPkgs eeLocals + generateSnapHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs where - installedMap' = Map.difference installedMap + installedMap' = Map.difference installedMap0 $ Map.fromList $ map (\(ident, _) -> (packageIdentifierName ident, ())) $ Map.elems @@ -501,7 +520,7 @@ => InstalledMap -> (m () -> IO ()) -> ExecuteEnv - -> (Maybe Task, Maybe (Task, LocalPackageTB)) -- build and final + -> (Maybe Task, Maybe Task) -- build and final -> [Action] toActions installedMap runInBase ee (mbuild, mfinal) = abuild ++ afinal @@ -514,39 +533,60 @@ { actionId = ActionId taskProvides ATBuild , actionDeps = (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)) - , actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap + , actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap False } ] afinal = case mfinal of Nothing -> [] - Just (task@Task {..}, lptb) -> + Just task@Task {..} -> + (if taskAllInOne then [] else + [Action + { actionId = ActionId taskProvides ATBuildFinal + , actionDeps = addBuild ATBuild + (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)) + , actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap True + }]) ++ [ Action { actionId = ActionId taskProvides ATFinal - , actionDeps = addBuild taskProvides $ - (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)) + , actionDeps = addBuild (if taskAllInOne then ATBuild else ATBuildFinal) Set.empty , actionDo = \ac -> runInBase $ do - unless (Set.null $ lptbTests lptb) $ do - singleTest runInBase topts lptb ac ee task installedMap - unless (Set.null $ lptbBenches lptb) $ do - singleBench runInBase beopts lptb ac ee task installedMap + let comps = taskComponents task + tests = testComponents comps + benches = benchComponents comps + unless (Set.null tests) $ do + singleTest runInBase topts (Set.toList tests) ac ee task installedMap + unless (Set.null benches) $ do + -- FIXME: shouldn't this use the list of benchmarks to run? + singleBench runInBase beopts ac ee task installedMap } ] - where - addBuild ident = - case mbuild of - Nothing -> id - Just _ -> Set.insert $ ActionId ident ATBuild - + where + addBuild aty = + case mbuild of + Nothing -> id + Just _ -> Set.insert $ ActionId taskProvides aty bopts = eeBuildOpts ee topts = boptsTestOpts bopts beopts = boptsBenchmarkOpts bopts -- | Generate the ConfigCache getConfigCache :: MonadIO m - => ExecuteEnv -> Task -> [Text] + => ExecuteEnv -> Task -> InstalledMap -> Bool -> Bool -> m (Map PackageIdentifier GhcPkgId, ConfigCache) -getConfigCache ExecuteEnv {..} Task {..} extra = do +getConfigCache ExecuteEnv {..} Task {..} installedMap enableTest enableBench = do + let extra = + -- We enable tests if the test suite dependencies are already + -- installed, so that we avoid unnecessary recompilation based on + -- cabal_macros.h changes when switching between 'stack build' and + -- 'stack test'. See: + -- https://github.com/commercialhaskell/stack/issues/805 + case taskType of + TTLocal lp -> concat + [ ["--enable-tests" | enableTest || (depsPresent installedMap $ lpTestDeps lp)] + , ["--enable-benchmarks" | enableBench || (depsPresent installedMap $ lpBenchDeps lp)] + ] + _ -> [] idMap <- liftIO $ readTVarIO eeGhcPkgIds let getMissing ident = case Map.lookup ident idMap of @@ -601,7 +641,9 @@ announce menv <- getMinimalEnvOverride let programNames = - if eeCabalPkgVer < $(mkVersion "1.22") then ["ghc"] else ["ghc", "ghcjs"] + if eeCabalPkgVer < $(mkVersion "1.22") + then ["ghc", "ghc-pkg"] + else ["ghc", "ghc-pkg", "ghcjs", "ghcjs-pkg"] exes <- forM programNames $ \name -> do mpath <- findExecutable menv name return $ case mpath of @@ -688,14 +730,18 @@ withCabal package pkgDir mlogFile inner = do config <- asks getConfig - menv <- liftIO $ configEnvOverride config EnvSettings - { esIncludeLocals = taskLocation task == Local - , esIncludeGhcPackagePath = False - , esStackExe = False - , esLocaleUtf8 = True - } - getGhcPath <- runOnce $ liftIO $ join $ findExecutable menv "ghc" - getGhcjsPath <- runOnce $ liftIO $ join $ findExecutable menv "ghcjs" + let envSettings = EnvSettings + { esIncludeLocals = taskLocation task == Local + , esIncludeGhcPackagePath = False + , esStackExe = False + , esLocaleUtf8 = True + } + menv <- liftIO $ configEnvOverride config envSettings + -- When looking for ghc to build Setup.hs we want to ignore local binaries, see: + -- https://github.com/commercialhaskell/stack/issues/1052 + menvWithoutLocals <- liftIO $ configEnvOverride config envSettings { esIncludeLocals = False } + getGhcPath <- runOnce $ liftIO $ join $ findExecutable menvWithoutLocals "ghc" + getGhcjsPath <- runOnce $ liftIO $ join $ findExecutable menvWithoutLocals "ghcjs" distRelativeDir' <- distRelativeDir esetupexehs <- -- Avoid broken Setup.hs files causing problems for simple build @@ -711,25 +757,31 @@ eeCabalPkgVer) packageArgs = case mdeps of + -- This branch is taken when + -- 'explicit-setup-deps' is requested in your + -- stack.yaml file. Just deps | explicitSetupDeps (packageName package) config -> -- Stack always builds with the global Cabal for various -- reproducibility issues. let depsMinusCabal = map ghcPkgIdString $ Set.toList - $ addGlobalPackages deps eeGlobalPackages + $ addGlobalPackages deps (Map.elems eeGlobalDumpPkgs) in ( "-clear-package-db" : "-global-package-db" - : map (("-package-db=" ++) . toFilePath) (bcoExtraDBs eeBaseConfigOpts) + : map (("-package-db=" ++) . toFilePathNoTrailingSep) (bcoExtraDBs eeBaseConfigOpts) ) ++ - ( ("-package-db=" ++ toFilePath (bcoSnapDB eeBaseConfigOpts)) - : ("-package-db=" ++ toFilePath (bcoLocalDB eeBaseConfigOpts)) + ( ("-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)) + : ("-package-db=" ++ toFilePathNoTrailingSep (bcoLocalDB eeBaseConfigOpts)) : "-hide-all-packages" : cabalPackageArg : map ("-package-id=" ++) depsMinusCabal ) - -- This branch is debatable. It adds access to the + -- This branch is usually taken for builds, and + -- is always taken for `stack sdist`. + -- + -- This approach is debatable. It adds access to the -- snapshot package database for Cabal. There are two -- possible objections: -- @@ -747,10 +799,10 @@ cabalPackageArg : "-clear-package-db" : "-global-package-db" - : map (("-package-db=" ++) . toFilePath) (bcoExtraDBs eeBaseConfigOpts) - ++ ["-package-db=" ++ toFilePath (bcoSnapDB eeBaseConfigOpts)] + : map (("-package-db=" ++) . toFilePathNoTrailingSep) (bcoExtraDBs eeBaseConfigOpts) + ++ ["-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)] - setupArgs = ("--builddir=" ++ toFilePath distRelativeDir') : args + setupArgs = ("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args runExe exeName fullArgs = do $logProcessRun (toFilePath exeName) fullArgs @@ -761,8 +813,8 @@ ec <- liftIO $ - withAsync (runInBase $ maybePrintBuildOutput stripTHLoading makeAbsolute LevelInfo mlogFile moutH) $ \outThreadID -> - withAsync (runInBase $ maybePrintBuildOutput False makeAbsolute LevelWarn mlogFile merrH) $ \errThreadID -> do + withAsync (runInBase $ maybePrintBuildOutput stripTHLoading makeAbsolute pkgDir LevelInfo mlogFile moutH) $ \outThreadID -> + withAsync (runInBase $ maybePrintBuildOutput False makeAbsolute pkgDir LevelWarn mlogFile merrH) $ \errThreadID -> do ec <- waitForProcess ph wait errThreadID wait outThreadID @@ -819,8 +871,8 @@ Ghcjs -> getGhcjsPath runExe compilerPath $ [ "--make" - , "-odir", toFilePath setupDir - , "-hidir", toFilePath setupDir + , "-odir", toFilePathNoTrailingSep setupDir + , "-hidir", toFilePathNoTrailingSep setupDir , "-i", "-i." ] ++ packageArgs ++ [ toFilePath setuphs @@ -832,12 +884,12 @@ return (outputFile, setupArgs) runExe exeName $ (if boptsCabalVerbose eeBuildOpts then ("--verbose":) else id) fullArgs - maybePrintBuildOutput stripTHLoading makeAbsolute level mlogFile mh = + maybePrintBuildOutput stripTHLoading makeAbsolute pkgDir level mlogFile mh = case mh of Just h -> case mlogFile of Just{} -> return () - Nothing -> printBuildOutput stripTHLoading makeAbsolute level h + Nothing -> printBuildOutput stripTHLoading makeAbsolute pkgDir level h Nothing -> return () singleBuild :: M env m @@ -846,9 +898,10 @@ -> ExecuteEnv -> Task -> InstalledMap + -> Bool -- ^ Is this a final build? -> m () -singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap = do - (allDepsMap, cache) <- getCache +singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap isFinalBuild = do + (allDepsMap, cache) <- getConfigCache ee task installedMap enableTests enableBenchmarks mprecompiled <- getPrecompiled cache minstalled <- case mprecompiled of @@ -863,25 +916,29 @@ pname = packageIdentifierName taskProvides shouldHaddockPackage' = shouldHaddockPackage eeBuildOpts eeWanted pname doHaddock package = shouldHaddockPackage' && + not isFinalBuild && -- Works around haddock failing on bytestring-builder since it has no modules -- when bytestring is new enough. packageHasExposedModules package - getCache = do - let extra = - -- We enable tests if the test suite dependencies are already - -- installed, so that we avoid unnecessary recompilation based on - -- cabal_macros.h changes when switching between 'stack build' and - -- 'stack test'. See: - -- https://github.com/commercialhaskell/stack/issues/805 - case taskType of - TTLocal lp -> concat - [ ["--enable-tests" | depsPresent installedMap $ lpTestDeps lp] - , ["--enable-benchmarks" | depsPresent installedMap $ lpBenchDeps lp] - ] - _ -> [] - getConfigCache ee task extra + buildingFinals = isFinalBuild || taskAllInOne + enableTests = buildingFinals && any isCTest (taskComponents task) + enableBenchmarks = buildingFinals && any isCBench (taskComponents task) + annSuffix = if result == "" then "" else " (" <> result <> ")" + where + result = T.intercalate " + " $ concat $ + [ ["lib" | taskAllInOne && hasLib] + , ["exe" | taskAllInOne && hasExe] + , ["test" | enableTests] + , ["bench" | enableBenchmarks] + ] + (hasLib, hasExe) = case taskType of + TTLocal lp -> (packageHasLibrary (lpPackage lp), not (Set.null (exesToBuild lp))) + -- This isn't true, but we don't want to have this info for + -- upstream deps. + TTUpstream{} -> (False, False) + getPrecompiled cache = case taskLocation task of Snap | not shouldHaddockPackage' -> do @@ -890,7 +947,15 @@ (configCacheDeps cache) case mpc of Nothing -> return Nothing - Just pc -> do + Just pc | maybe False + (bcoSnapInstallRoot eeBaseConfigOpts `isParentOf`) + (parseAbsFile =<< (pcLibrary pc)) -> + -- If old precompiled cache files are left around but snapshots are deleted, + -- it is possible for the precompiled file to refer to the very library + -- we're building, and if flags are changed it may try to copy the library + -- to itself. This check prevents that from happening. + return Nothing + Just pc | otherwise -> do let allM _ [] = return True allM f (x:xs) = do b <- f x @@ -912,7 +977,18 @@ menv' <- modifyEnvOverride menv $ Map.insert "GHC_PACKAGE_PATH" - (T.pack $ toFilePath $ bcoSnapDB eeBaseConfigOpts) + (T.pack $ toFilePathNoTrailingSep $ bcoSnapDB eeBaseConfigOpts) + + -- In case a build of the library with different flags already exists, unregister it + -- before copying. + catch + (readProcessNull Nothing menv' "ghc-pkg" + [ "unregister" + , "--force" + , packageIdentifierString taskProvides + ]) + (\(ReadProcessException _ _ _ _) -> return ()) + readProcessNull Nothing menv' "ghc-pkg" [ "register" , "--force" @@ -929,18 +1005,22 @@ -- Find the package in the database wc <- getWhichCompiler let pkgDbs = [bcoSnapDB eeBaseConfigOpts] - mpkgid <- findGhcPkgId eeEnvOverride wc pkgDbs pname - return $ Just $ - case mpkgid of - Nothing -> Executable taskProvides - Just pkgid -> Library taskProvides pkgid + case mlib of + Nothing -> return $ Just $ Executable taskProvides + Just _ -> do + mpkgid <- loadInstalledPkg eeEnvOverride wc pkgDbs eeSnapshotDumpPkgs pname + + return $ Just $ + case mpkgid of + Nothing -> assert False $ Executable taskProvides + Just pkgid -> Library taskProvides pkgid where bindir = toFilePath $ bcoSnapInstallRoot eeBaseConfigOpts bindirSuffix realConfigAndBuild cache allDepsMap = withSingleContext runInBase ac ee task (Just allDepsMap) Nothing $ \package cabalfp pkgDir cabal announce console _mlogFile -> do - _neededConfig <- ensureConfig cache pkgDir ee (announce "configure") cabal cabalfp + _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix)) cabal cabalfp if boptsOnlyConfigure eeBuildOpts then return Nothing @@ -951,45 +1031,23 @@ markExeNotInstalled (taskLocation task) taskProvides case taskType of - TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp + TTLocal lp -> do + when enableTests $ unsetTestSuccess pkgDir + writeBuildCache pkgDir $ lpNewBuildCache lp TTUpstream _ _ -> return () - () <- announce "build" + () <- announce ("build" <> annSuffix) config <- asks getConfig extraOpts <- extraBuildOptions eeBuildOpts preBuildTime <- modTime <$> liftIO getCurrentTime - cabal (console && configHideTHLoading config) $ - (case taskType of - TTLocal lp -> concat - [ ["build"] - , ["lib:" ++ packageNameString (packageName package) - -- TODO: get this information from target parsing instead, - -- which will allow users to turn off library building if - -- desired - | packageHasLibrary package] - , map (T.unpack . T.append "exe:") $ Set.toList $ - case lpExeComponents lp of - Just exes -> exes - -- Build all executables in the event that no - -- specific list is provided (as happens with - -- extra-deps). - Nothing -> packageExes package - ] - TTUpstream _ _ -> ["build"]) ++ extraOpts - - case taskType of - TTLocal lp -> do - (addBuildCache,warnings) <- - addUnlistedToBuildCache - preBuildTime - (lpPackage lp) - (lpCabalFile lp) - (lpNewBuildCache lp) - mapM_ ($logWarn . ("Warning: " <>) . T.pack . show) warnings - unless (null addBuildCache) $ - writeBuildCache pkgDir $ - Map.unions (lpNewBuildCache lp : addBuildCache) - TTUpstream _ _ -> return () + cabal (console && configHideTHLoading config) $ ("build" :) $ (++ extraOpts) $ + case (taskType, taskAllInOne, isFinalBuild) of + (_, True, True) -> fail "Invariant violated: cannot have an all-in-one build that also has a final build step." + (TTLocal lp, False, False) -> primaryComponentOptions lp + (TTLocal lp, False, True) -> finalComponentOptions lp + (TTLocal lp, True, False) -> primaryComponentOptions lp ++ finalComponentOptions lp + (TTUpstream{}, _, _) -> [] + checkForUnlistedFiles taskType preBuildTime pkgDir when (doHaddock package) $ do announce "haddock" @@ -1009,36 +1067,30 @@ cabal False (concat [["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"] ,sourceFlag]) - withMVar eeInstallLock $ \() -> do - announce "install" - cabal False ["install"] + unless isFinalBuild $ withMVar eeInstallLock $ \() -> do + announce "copy/register" + cabal False ["copy"] + when (packageHasLibrary package) $ cabal False ["register"] - let pkgDbs = + let (installedPkgDb, installedDumpPkgsTVar) = case taskLocation task of - Snap -> [bcoSnapDB eeBaseConfigOpts] + Snap -> + ( bcoSnapDB eeBaseConfigOpts + , eeSnapshotDumpPkgs ) Local -> - [ bcoSnapDB eeBaseConfigOpts - , bcoLocalDB eeBaseConfigOpts - ] - mpkgid <- findGhcPkgId eeEnvOverride wc pkgDbs (packageName package) + ( bcoLocalDB eeBaseConfigOpts + , eeLocalDumpPkgs ) let ident = PackageIdentifier (packageName package) (packageVersion package) - mpkgid' <- case (packageHasLibrary package, mpkgid) of - (False, _) -> assert (isNothing mpkgid) $ do + mpkgid <- if packageHasLibrary package + then do + mpkgid <- loadInstalledPkg eeEnvOverride wc [installedPkgDb] installedDumpPkgsTVar (packageName package) + case mpkgid of + Nothing -> throwM $ Couldn'tFindPkgId $ packageName package + Just pkgid -> return $ Library ident pkgid + else do markExeInstalled (taskLocation task) taskProvides -- TODO unify somehow with writeFlagCache? return $ Executable ident - (True, Nothing) -> throwM $ Couldn'tFindPkgId $ packageName package - (True, Just pkgid) -> return $ Library ident pkgid - when (doHaddock package && shouldHaddockDeps eeBuildOpts) $ - withMVar eeInstallLock $ \() -> - copyDepHaddocks - eeEnvOverride - wc - eeBaseConfigOpts - (pkgDbs ++ [eeGlobalDB]) - (PackageIdentifier (packageName package) (packageVersion package)) - Set.empty - case taskLocation task of Snap -> writePrecompiledCache eeBaseConfigOpts taskProvides (configCacheOpts cache) @@ -1046,65 +1098,57 @@ mpkgid (packageExes package) Local -> return () - return mpkgid' + return mpkgid + loadInstalledPkg menv wc pkgDbs tvar name = do + dps <- ghcPkgDescribe name menv wc pkgDbs $ conduitDumpPackage =$ CL.consume + case dps of + [] -> return Nothing + [dp] -> do + liftIO $ atomically $ modifyTVar' tvar (Map.insert (dpGhcPkgId dp) dp) + return $ Just (dpGhcPkgId dp) + _ -> error "singleBuild: invariant violated: multiple results when describing installed package" + +-- | Check if any unlisted files have been found, and add them to the build cache. +checkForUnlistedFiles :: M env m => TaskType -> ModTime -> Path Abs Dir -> m () +checkForUnlistedFiles (TTLocal lp) preBuildTime pkgDir = do + (addBuildCache,warnings) <- + addUnlistedToBuildCache + preBuildTime + (lpPackage lp) + (lpCabalFile lp) + (lpNewBuildCache lp) + mapM_ ($logWarn . ("Warning: " <>) . T.pack . show) warnings + unless (null addBuildCache) $ + writeBuildCache pkgDir $ + Map.unions (lpNewBuildCache lp : addBuildCache) +checkForUnlistedFiles (TTUpstream _ _) _ _ = return () + -- | Determine if all of the dependencies given are installed depsPresent :: InstalledMap -> Map PackageName VersionRange -> Bool depsPresent installedMap deps = all (\(name, range) -> case Map.lookup name installedMap of - Just (version, _, _) -> version `withinRange` range + Just (_, installed) -> installedVersion installed `withinRange` range Nothing -> False) (Map.toList deps) singleTest :: M env m => (m () -> IO ()) -> TestOpts - -> LocalPackageTB + -> [Text] -> ActionContext -> ExecuteEnv -> Task -> InstalledMap -> m () -singleTest runInBase topts lptb ac ee task installedMap = do - (allDepsMap, cache) <- getConfigCache ee task $ - case taskType task of - TTLocal lp -> concat - [ ["--enable-tests"] - , ["--enable-benchmarks" | depsPresent installedMap $ lpBenchDeps lp] - ] - _ -> [] - withSingleContext runInBase ac ee task (Just allDepsMap) (Just "test") $ \package cabalfp pkgDir cabal announce console mlogFile -> do - neededConfig <- ensureConfig cache pkgDir ee (announce "configure (test)") cabal cabalfp +singleTest runInBase topts testsToRun ac ee task installedMap = do + -- FIXME: Since this doesn't use cabal, we should be able to avoid using a + -- fullblown 'withSingleContext'. + (allDepsMap, _cache) <- getConfigCache ee task installedMap True False + withSingleContext runInBase ac ee task (Just allDepsMap) (Just "test") $ \package _cabalfp pkgDir _cabal announce _console mlogFile -> do config <- asks getConfig - - testBuilt <- checkTestBuilt pkgDir - - let needBuild = neededConfig || - (case taskType task of - TTLocal lp -> - case lpDirtyFiles lp of - Just _ -> True - Nothing -> False - _ -> assert False True) || - not testBuilt - - needHpc = toCoverage topts - - testsToRun = Set.toList $ lptbTests lptb - components = map (T.unpack . T.append "test:") testsToRun - - when needBuild $ do - announce "build (test)" - unsetTestBuilt pkgDir - unsetTestSuccess pkgDir - case taskType task of - TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp - TTUpstream _ _ -> assert False $ return () - extraOpts <- extraBuildOptions (eeBuildOpts ee) - cabal (console && configHideTHLoading config) $ - "build" : (components ++ extraOpts) - setTestBuilt pkgDir + let needHpc = toCoverage topts toRun <- if toDisableRun topts @@ -1179,7 +1223,7 @@ -- directory into the hpc work dir, for -- tidiness. when needHpc $ - updateTixFile nameTix (packageIdentifierString (packageIdentifier package)) + updateTixFile (packageName package) nameTix return $ case ec of ExitSuccess -> Map.empty _ -> Map.singleton testName $ Just ec @@ -1192,13 +1236,7 @@ ] return $ Map.singleton testName Nothing - when needHpc $ do - wc <- getWhichCompiler - let pkgDbs = - [ bcoSnapDB (eeBaseConfigOpts ee) - , bcoLocalDB (eeBaseConfigOpts ee) - ] - generateHpcReport package testsToRun (findGhcPkgKey (eeEnvOverride ee) wc pkgDbs) + when needHpc $ generateHpcReport pkgDir package testsToRun bs <- liftIO $ case mlogFile of @@ -1213,48 +1251,19 @@ (fmap fst mlogFile) bs - setTestSuccess pkgDir - singleBench :: M env m => (m () -> IO ()) -> BenchmarkOpts - -> LocalPackageTB -> ActionContext -> ExecuteEnv -> Task -> InstalledMap -> m () -singleBench runInBase beopts _lptb ac ee task installedMap = do - (allDepsMap, cache) <- getConfigCache ee task $ - case taskType task of - TTLocal lp -> concat - [ ["--enable-tests" | depsPresent installedMap $ lpTestDeps lp] - , ["--enable-benchmarks"] - ] - _ -> [] - withSingleContext runInBase ac ee task (Just allDepsMap) (Just "bench") $ \_package cabalfp pkgDir cabal announce console _mlogFile -> do - neededConfig <- ensureConfig cache pkgDir ee (announce "configure (benchmarks)") cabal cabalfp - - benchBuilt <- checkBenchBuilt pkgDir - - let needBuild = neededConfig || - (case taskType task of - TTLocal lp -> - case lpDirtyFiles lp of - Just _ -> True - Nothing -> False - _ -> assert False True) || - not benchBuilt - when needBuild $ do - announce "build (benchmarks)" - unsetBenchBuilt pkgDir - case taskType task of - TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp - TTUpstream _ _ -> assert False $ return () - config <- asks getConfig - extraOpts <- extraBuildOptions (eeBuildOpts ee) - cabal (console && configHideTHLoading config) ("build" : extraOpts) - setBenchBuilt pkgDir +singleBench runInBase beopts ac ee task installedMap = do + -- FIXME: Since this doesn't use cabal, we should be able to avoid using a + -- fullblown 'withSingleContext'. + (allDepsMap, _cache) <- getConfigCache ee task installedMap False True + withSingleContext runInBase ac ee task (Just allDepsMap) (Just "bench") $ \_package _cabalfp _pkgDir cabal announce _console _mlogFile -> do let args = maybe [] ((:[]) . ("--benchmark-options=" <>)) (beoAdditionalArgs beopts) @@ -1276,10 +1285,11 @@ printBuildOutput :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => Bool -- ^ exclude TH loading? -> Bool -- ^ convert paths to absolute? + -> Path Abs Dir -- ^ package's root directory -> LogLevel -> Handle -> m () -printBuildOutput excludeTHLoading makeAbsolute level outH = void $ - CB.sourceHandle outH +printBuildOutput excludeTHLoading makeAbsolute pkgDir level outH = void $ + CB.sourceHandle outH $$ CB.lines =$ CL.map stripCarriageReturn =$ CL.filter (not . isTHLoading) @@ -1301,10 +1311,10 @@ mabs <- if isValidSuffix y then do - efp <- liftIO $ tryIO $ D.canonicalizePath $ S8.unpack x + efp <- liftIO $ tryIO $ resolveFile pkgDir (S8.unpack x) case efp of Left _ -> return Nothing - Right fp -> return $ Just $ S8.pack fp + Right fp -> return $ Just $ S8.pack (toFilePath fp) else return Nothing case mabs of Nothing -> return bs @@ -1320,7 +1330,7 @@ guard $ S.head bs1 == _colon (_, bs2) <- S8.readInt $ S.drop 1 bs1 - guard $ bs2 == ":" + guard $ (bs2 == ":" || bs2 == ": Warning:") -- | Strip @\r@ characters from the byte vector. Used because Windows. stripCarriageReturn :: ByteString -> ByteString @@ -1351,9 +1361,47 @@ let ddumpOpts = " -ddump-hi -ddump-to-file" case toCoverage (boptsTestOpts bopts) of True -> do - hpcIndexDir <- toFilePath . ( dotHpc) <$> hpcRelativeDir + hpcIndexDir <- toFilePathNoTrailingSep <$> hpcRelativeDir return ["--ghc-options", "-hpcdir " ++ hpcIndexDir ++ ddumpOpts] False -> return ["--ghc-options", ddumpOpts] + +-- Library and executable build components. +primaryComponentOptions :: LocalPackage -> [String] +primaryComponentOptions lp = concat + [ ["lib:" ++ packageNameString (packageName (lpPackage lp)) + -- TODO: get this information from target parsing instead, + -- which will allow users to turn off library building if + -- desired + | packageHasLibrary (lpPackage lp)] + , map (T.unpack . T.append "exe:") $ Set.toList $ exesToBuild lp + ] + +exesToBuild :: LocalPackage -> Set Text +exesToBuild lp = packageExes (lpPackage lp) + -- NOTE: Ideally we'd do something like the following code, allowing + -- the user to control which executables get built. However, due to + -- https://github.com/haskell/cabal/issues/2780 we must build all + -- exes... + -- + -- if lpWanted lp + -- then exeComponents (lpComponents lp) + -- -- Build all executables in the event that no + -- -- specific list is provided (as happens with + -- -- extra-deps). + -- else packageExes (lpPackage lp) + +-- Test-suite and benchmark build components. +finalComponentOptions :: LocalPackage -> [String] +finalComponentOptions lp = + map (T.unpack . decodeUtf8 . renderComponent) $ + Set.toList $ + Set.filter (\c -> isCTest c || isCBench c) (lpComponents lp) + +taskComponents :: Task -> Set NamedComponent +taskComponents task = + case taskType task of + TTLocal lp -> lpComponents lp + TTUpstream{} -> Set.empty -- | Take the given list of package dependencies and the contents of the global -- package database, and construct a set of installed package IDs that: diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -3,39 +3,44 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -- | Generate haddocks module Stack.Build.Haddock - ( copyDepHaddocks - , generateLocalHaddockIndex + ( generateLocalHaddockIndex , generateDepsHaddockIndex , generateSnapHaddockIndex , shouldHaddockPackage , shouldHaddockDeps ) where -import Control.Exception (tryJust) +import Control.Exception (tryJust, onException) import Control.Monad import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Trans.Resource -import Control.Monad.Writer +import qualified Data.Foldable as F import Data.Function +import qualified Data.HashSet as HS import Data.List +import Data.List.Extra (nubOrd) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import Data.Maybe +import Data.Maybe.Extra (mapMaybeM) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T +import Data.Time (UTCTime) import Path +import Path.Extra import Path.IO import Prelude -import Safe (maximumMay) import Stack.Types.Build -import Stack.GhcPkg -import Stack.Package +import Stack.PackageDump import Stack.Types import System.Directory (getModificationTime) import qualified System.FilePath as FP @@ -43,7 +48,12 @@ import System.Process.Read -- | Determine whether we should haddock for a package. -shouldHaddockPackage :: BuildOpts -> Set PackageName -> PackageName -> Bool +shouldHaddockPackage :: BuildOpts + -> Set PackageName -- ^ Packages that we want to generate haddocks for + -- in any case (whether or not we are going to generate + -- haddocks for dependencies) + -> PackageName + -> Bool shouldHaddockPackage bopts wanted name = if Set.member name wanted then boptsHaddock bopts @@ -53,119 +63,90 @@ shouldHaddockDeps :: BuildOpts -> Bool shouldHaddockDeps bopts = fromMaybe (boptsHaddock bopts) (boptsHaddockDeps bopts) --- | Copy dependencies' haddocks to documentation directory. This way, relative @../$pkg-$ver@ --- links work and it's easy to upload docs to a web server or otherwise view them in a --- non-local-filesystem context. We copy instead of symlink for two reasons: (1) symlinks aren't --- reliably supported on Windows, and (2) the filesystem containing dependencies' docs may not be --- available where viewing the docs (e.g. if building in a Docker container). -copyDepHaddocks :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadBaseControl IO m) - => EnvOverride - -> WhichCompiler - -> BaseConfigOpts - -> [Path Abs Dir] - -> PackageIdentifier - -> Set (Path Abs Dir) - -> m () -copyDepHaddocks envOverride wc bco pkgDbs pkgId extraDestDirs = do - mpkgHtmlDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs $ packageIdentifierString pkgId - case mpkgHtmlDir of - Nothing -> return () - Just (_pkgId, pkgHtmlDir) -> do - depGhcIds <- findGhcPkgDepends envOverride wc pkgDbs $ packageIdentifierString pkgId - forM_ depGhcIds $ copyDepWhenNeeded pkgHtmlDir - where - copyDepWhenNeeded pkgHtmlDir depGhcId = do - mDepOrigDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs $ ghcPkgIdString depGhcId - case mDepOrigDir of - Nothing -> return () - Just (depId, depOrigDir) -> do - let extraDestDirs' = - -- Parent test ensures we don't try to copy docs to global locations - if bcoSnapInstallRoot bco `isParentOf` pkgHtmlDir || - bcoLocalInstallRoot bco `isParentOf` pkgHtmlDir - then Set.insert (parent pkgHtmlDir) extraDestDirs - else extraDestDirs - copyWhenNeeded extraDestDirs' depId depOrigDir - copyWhenNeeded destDirs depId depOrigDir = do - depRelDir <- parseRelDir (packageIdentifierString depId) - copied <- forM (Set.toList destDirs) $ \destDir -> do - let depCopyDir = destDir depRelDir - if depCopyDir == depOrigDir - then return False - else do - needCopy <- getNeedCopy depOrigDir depCopyDir - when needCopy $ doCopy depOrigDir depCopyDir - return needCopy - when (or copied) $ - copyDepHaddocks envOverride wc bco pkgDbs depId destDirs - getNeedCopy depOrigDir depCopyDir = do - let depOrigIndex = haddockIndexFile depOrigDir - depCopyIndex = haddockIndexFile depCopyDir - depOrigExists <- fileExists depOrigIndex - depCopyExists <- fileExists depCopyIndex - case (depOrigExists, depCopyExists) of - (False, _) -> return False - (True, False) -> return True - (True, True) -> do - copyMod <- liftIO $ getModificationTime (toFilePath depCopyIndex) - origMod <- liftIO $ getModificationTime (toFilePath depOrigIndex) - return (copyMod <= origMod) - doCopy depOrigDir depCopyDir = do - removeTreeIfExists depCopyDir - createTree depCopyDir - copyDirectoryRecursive depOrigDir depCopyDir - -- | Generate Haddock index and contents for local packages. generateLocalHaddockIndex :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m) - => EnvOverride -> WhichCompiler -> BaseConfigOpts -> [LocalPackage] -> m () -generateLocalHaddockIndex envOverride wc bco locals = do - let packageIDs = - map + => EnvOverride + -> WhichCompiler + -> BaseConfigOpts + -> Map GhcPkgId (DumpPackage () ()) -- ^ Local package dump + -> [LocalPackage] + -> m () +generateLocalHaddockIndex envOverride wc bco localDumpPkgs locals = do + let dumpPackages = + mapMaybe (\LocalPackage{lpPackage = Package{..}} -> - PackageIdentifier packageName packageVersion) + F.find + (\dp -> dpPackageIdent dp == PackageIdentifier packageName packageVersion) + localDumpPkgs) locals generateHaddockIndex "local packages" envOverride wc - packageIDs + dumpPackages "." (localDocDir bco) -- | Generate Haddock index and contents for local packages and their dependencies. generateDepsHaddockIndex :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m) - => EnvOverride -> WhichCompiler -> BaseConfigOpts -> [LocalPackage] -> m () -generateDepsHaddockIndex envOverride wc bco locals = do - depSets <- - mapM - (\LocalPackage{lpPackage = Package{..}} -> - findTransitiveGhcPkgDepends - envOverride - wc - [bcoSnapDB bco, bcoLocalDB bco] - (PackageIdentifier packageName packageVersion)) - locals + => EnvOverride + -> WhichCompiler + -> BaseConfigOpts + -> Map GhcPkgId (DumpPackage () ()) -- ^ Global dump information + -> Map GhcPkgId (DumpPackage () ()) -- ^ Snapshot dump information + -> Map GhcPkgId (DumpPackage () ()) -- ^ Local dump information + -> [LocalPackage] + -> m () +generateDepsHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do + let deps = (mapMaybe (`lookupDumpPackage` allDumpPkgs) . nubOrd . findTransitiveDepends . mapMaybe getGhcPkgId) locals + depDocDir = localDocDir bco $(mkRelDir "all") generateHaddockIndex "local packages and dependencies" envOverride wc - (Set.toList (Set.unions depSets)) + deps ".." - (localDocDir bco $(mkRelDir "all")) + depDocDir + where + getGhcPkgId :: LocalPackage -> Maybe GhcPkgId + getGhcPkgId LocalPackage{lpPackage = Package{..}} = + let pkgId = PackageIdentifier packageName packageVersion + mdpPkg = F.find (\dp -> dpPackageIdent dp == pkgId) localDumpPkgs + in fmap dpGhcPkgId mdpPkg + findTransitiveDepends :: [GhcPkgId] -> [GhcPkgId] + findTransitiveDepends = (`go` HS.empty) . HS.fromList + where + go todo checked = + case HS.toList todo of + [] -> HS.toList checked + (ghcPkgId:_) -> + let deps = + case lookupDumpPackage ghcPkgId allDumpPkgs of + Nothing -> HS.empty + Just pkgDP -> HS.fromList (dpDepends pkgDP) + deps' = deps `HS.difference` checked + todo' = HS.delete ghcPkgId (deps' `HS.union` todo) + checked' = HS.insert ghcPkgId checked + in go todo' checked' + allDumpPkgs = [localDumpPkgs, snapshotDumpPkgs, globalDumpPkgs] -- | Generate Haddock index and contents for all snapshot packages. generateSnapHaddockIndex :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m) - => EnvOverride -> WhichCompiler -> BaseConfigOpts -> Path Abs Dir -> m () -generateSnapHaddockIndex envOverride wc bco globalDB = do - pkgIds <- listGhcPkgDbs envOverride wc [globalDB, bcoSnapDB bco] + => EnvOverride + -> WhichCompiler + -> BaseConfigOpts + -> Map GhcPkgId (DumpPackage () ()) -- ^ Global package dump + -> Map GhcPkgId (DumpPackage () ()) -- ^ Snapshot package dump + -> m () +generateSnapHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs = generateHaddockIndex "snapshot packages" envOverride wc - pkgIds + (Map.elems snapshotDumpPkgs ++ Map.elems globalDumpPkgs) "." (snapDocDir bco) @@ -175,56 +156,89 @@ => Text -> EnvOverride -> WhichCompiler - -> [PackageIdentifier] + -> [DumpPackage () ()] -> FilePath -> Path Abs Dir -> m () -generateHaddockIndex descr envOverride wc packageIDs docRelDir destDir = do +generateHaddockIndex descr envOverride wc dumpPackages docRelFP destDir = do createTree destDir - interfaceOpts <- liftIO $ fmap catMaybes (mapM toInterfaceOpt packageIDs) - case maximumMay (map snd interfaceOpts) of - Nothing -> return () - Just maxInterfaceModTime -> do - eindexModTime <- - liftIO $ - tryJust (guard . isDoesNotExistError) $ - getModificationTime (toFilePath (haddockIndexFile destDir)) - let needUpdate = - case eindexModTime of - Left _ -> True - Right indexModTime -> - indexModTime < maxInterfaceModTime - when - needUpdate $ - do $logInfo - ("Updating Haddock index for " <> descr <> " in\n" <> - T.pack (toFilePath (haddockIndexFile destDir))) - readProcessNull - (Just destDir) - envOverride - (haddockExeName wc) - (["--gen-contents", "--gen-index"] ++ concatMap fst interfaceOpts) + interfaceOpts <- (liftIO . fmap nubOrd . mapMaybeM toInterfaceOpt) dumpPackages + unless (null interfaceOpts) $ do + let destIndexFile = toFilePath (haddockIndexFile destDir) + eindexModTime <- liftIO (tryGetModificationTime destIndexFile) + let needUpdate = + case eindexModTime of + Left _ -> True + Right indexModTime -> + or [mt > indexModTime | (_,mt,_,_) <- interfaceOpts] + when needUpdate $ do + $logInfo + (T.concat ["Updating Haddock index for ", descr, " in\n", + T.pack destIndexFile]) + liftIO (mapM_ copyPkgDocs interfaceOpts) + readProcessNull + (Just destDir) + envOverride + (haddockExeName wc) + (["--gen-contents", "--gen-index"] ++ [x | (xs,_,_,_) <- interfaceOpts, x <- xs]) where - toInterfaceOpt pid@(PackageIdentifier name _) = do - let interfaceRelFile = - docRelDir FP. packageIdentifierString pid FP. - packageNameString name FP.<.> - "haddock" - interfaceAbsFile = toFilePath destDir FP. interfaceRelFile - einterfaceModTime <- - tryJust (guard . isDoesNotExistError) $ - getModificationTime interfaceAbsFile - return $ - case einterfaceModTime of - Left _ -> Nothing - Right interfaceModTime -> - Just - ( [ "-i" - , concat - [ docRelDir FP. packageIdentifierString pid - , "," - , interfaceRelFile]] - , interfaceModTime) + toInterfaceOpt :: DumpPackage a b -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File)) + toInterfaceOpt DumpPackage {..} = do + case dpHaddockInterfaces of + [] -> return Nothing + srcInterfaceFP:_ -> do + srcInterfaceAbsFile <- parseCollapsedAbsFile srcInterfaceFP + let (PackageIdentifier name _) = dpPackageIdent + destInterfaceRelFP = + docRelFP FP. + packageIdentifierString dpPackageIdent FP. + (packageNameString name FP.<.> "haddock") + destInterfaceAbsFile <- parseCollapsedAbsFile (toFilePath destDir FP. destInterfaceRelFP) + esrcInterfaceModTime <- tryGetModificationTime (toFilePath srcInterfaceAbsFile) + return $ + case esrcInterfaceModTime of + Left _ -> Nothing + Right srcInterfaceModTime -> + Just + ( [ "-i" + , concat + [ docRelFP FP. packageIdentifierString dpPackageIdent + , "," + , destInterfaceRelFP ]] + , srcInterfaceModTime + , srcInterfaceAbsFile + , destInterfaceAbsFile ) + tryGetModificationTime :: FilePath -> IO (Either () UTCTime) + tryGetModificationTime = tryJust (guard . isDoesNotExistError) . getModificationTime + copyPkgDocs :: (a, UTCTime, Path Abs File, Path Abs File) -> IO () + copyPkgDocs (_,srcInterfaceModTime,srcInterfaceAbsFile,destInterfaceAbsFile) = do + -- Copy dependencies' haddocks to documentation directory. This way, relative @../$pkg-$ver@ + -- links work and it's easy to upload docs to a web server or otherwise view them in a + -- non-local-filesystem context. We copy instead of symlink for two reasons: (1) symlinks + -- aren't reliably supported on Windows, and (2) the filesystem containing dependencies' + -- docs may not be available where viewing the docs (e.g. if building in a Docker + -- container). + edestInterfaceModTime <- tryGetModificationTime (toFilePath destInterfaceAbsFile) + case edestInterfaceModTime of + Left _ -> doCopy + Right destInterfaceModTime + | destInterfaceModTime < srcInterfaceModTime -> doCopy + | otherwise -> return () + where + doCopy = do + removeTreeIfExists destHtmlAbsDir + createTree destHtmlAbsDir + onException + (copyDirectoryRecursive (parent srcInterfaceAbsFile) destHtmlAbsDir) + (removeTreeIfExists destHtmlAbsDir) + destHtmlAbsDir = parent destInterfaceAbsFile + +-- | Find first DumpPackage matching the GhcPkgId +lookupDumpPackage :: GhcPkgId + -> [Map GhcPkgId (DumpPackage () ())] + -> Maybe (DumpPackage () ()) +lookupDumpPackage ghcPkgId dumpPkgs = + listToMaybe $ mapMaybe (Map.lookup ghcPkgId) dumpPkgs -- | Path of haddock index file. haddockIndexFile :: Path Abs Dir -> Path Abs File diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -12,7 +12,6 @@ ) where import Control.Applicative -import Control.Arrow ((&&&)) import Control.Monad import Control.Monad.Catch (MonadCatch, MonadMask) import Control.Monad.IO.Class @@ -28,11 +27,15 @@ import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map import Data.Maybe +import Data.Maybe.Extra (mapMaybeM) +import Data.Monoid +import qualified Data.Text as T import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Prelude hiding (FilePath, writeFile) import Stack.Build.Cache import Stack.Types.Build +import Stack.Types.Version import Stack.Constants import Stack.GhcPkg import Stack.PackageDump @@ -41,13 +44,6 @@ type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasEnvConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env) -data LoadHelper = LoadHelper - { lhId :: !GhcPkgId - , lhDeps :: ![GhcPkgId] - , lhPair :: !(PackageName, (Version, InstallLocation, Installed)) -- TODO Version is now redundant and can be gleaned from Installed - } - deriving Show - -- | Options for 'getInstalled'. data GetInstalledOpts = GetInstalledOpts { getInstalledProfiling :: !Bool @@ -63,7 +59,8 @@ -> Map PackageName pii -- ^ does not contain any installed information -> m ( InstalledMap , [DumpPackage () ()] -- globally installed - , Map GhcPkgId PackageIdentifier -- locally installed + , [DumpPackage () ()] -- snapshot installed + , [DumpPackage () ()] -- locally installed ) getInstalled menv opts sourceMap = do snapDBPath <- packageDatabaseDeps @@ -79,14 +76,14 @@ let loadDatabase' = loadDatabase menv opts mcache sourceMap - (installedLibs0, globalInstalled) <- loadDatabase' Nothing [] + (installedLibs0, globalDumpPkgs) <- loadDatabase' Nothing [] (installedLibs1, _extraInstalled) <- - (foldM (\lhs' pkgdb -> do - lhs'' <- loadDatabase' (Just (ExtraGlobal, pkgdb)) (fst lhs') - return lhs'') ((installedLibs0, globalInstalled)) extraDBPaths) - (installedLibs2, _snapInstalled) <- + (foldM (\lhs' pkgdb -> + loadDatabase' (Just (ExtraGlobal, pkgdb)) (fst lhs') + ) (installedLibs0, globalDumpPkgs) extraDBPaths) + (installedLibs2, snapshotDumpPkgs) <- loadDatabase' (Just (InstalledTo Snap, snapDBPath)) installedLibs1 - (installedLibs3, localInstalled) <- + (installedLibs3, localDumpPkgs) <- loadDatabase' (Just (InstalledTo Local, localDBPath)) installedLibs2 let installedLibs = M.fromList $ map lhPair installedLibs3 @@ -107,7 +104,7 @@ | otherwise -> m where - m = Map.singleton name (version, loc, Executable $ PackageIdentifier name version) + m = Map.singleton name (loc, Executable $ PackageIdentifier name version) exesSnap <- getInstalledExes Snap exesLocal <- getInstalledExes Local let installedMap = Map.unions @@ -117,8 +114,9 @@ ] return ( installedMap - , globalInstalled - , Map.fromList $ map (dpGhcPkgId &&& dpPackageIdent) localInstalled + , globalDumpPkgs + , snapshotDumpPkgs + , localDumpPkgs ) -- | Outputs both the modified InstalledMap and the Set of all installed packages in this database @@ -136,9 +134,10 @@ -> m ([LoadHelper], [DumpPackage () ()]) loadDatabase menv opts mcache sourceMap mdb lhs0 = do wc <- getWhichCompiler - (lhs1, dps) <- ghcPkgDump menv wc (fmap snd (maybeToList mdb)) + (lhs1', dps) <- ghcPkgDump menv wc (fmap snd (maybeToList mdb)) $ conduitDumpPackage =$ sink - + let ghcjsHack = wc == Ghcjs && isNothing mdb + lhs1 <- mapMaybeM (processLoadResult mdb ghcjsHack) lhs1' let lhs = pruneDeps id lhId @@ -159,14 +158,65 @@ -- Just an optimization to avoid calculating the haddock -- values when they aren't necessary _ -> CL.map (\dp -> dp { dpHaddock = False }) + mloc = fmap fst mdb sinkDP = conduitProfilingCache =$ conduitHaddockCache - =$ CL.mapMaybe (isAllowed opts mcache sourceMap (fmap fst mdb)) + =$ CL.map (\dp -> (isAllowed opts mcache sourceMap mloc dp, toLoadHelper mloc dp)) =$ CL.consume sink = getZipSink $ (,) <$> ZipSink sinkDP <*> ZipSink CL.consume +processLoadResult :: MonadLogger m + => Maybe (InstalledPackageLocation, Path Abs Dir) + -> Bool + -> (Allowed, LoadHelper) + -> m (Maybe LoadHelper) +processLoadResult _ _ (Allowed, lh) = return (Just lh) +processLoadResult _ True (WrongVersion actual wanted, lh) + -- Allow some packages in the ghcjs global DB to have the wrong + -- versions. Treat them as wired-ins by setting deps to []. + | fst (lhPair lh) `HashSet.member` ghcjsBootPackages = do + $logWarn $ T.concat + [ "Ignoring that the GHCJS boot package \"" + , packageNameText (fst (lhPair lh)) + , "\" has a different version, " + , versionText actual + , ", than the resolver's wanted version, " + , versionText wanted + ] + return (Just lh) +processLoadResult mdb _ (reason, lh) = do + $logDebug $ T.concat $ + [ "Ignoring package " + , packageNameText (fst (lhPair lh)) + ] ++ + (maybe [] (\db -> [", from ", T.pack (show db), ","]) mdb) ++ + [ " due to " + , case reason of + Allowed -> " the impossible?!?!" + NeedsProfiling -> " it needing profiling." + NeedsHaddock -> " it needing haddocks." + UnknownPkg -> " it being unknown to the resolver / extra-deps." + WrongLocation mloc loc -> " wrong location: " <> T.pack (show (mloc, loc)) + WrongVersion actual wanted -> T.concat + [ " wanting version " + , versionText wanted + , " instead of " + , versionText actual + ] + ] + return Nothing + +data Allowed + = Allowed + | NeedsProfiling + | NeedsHaddock + | UnknownPkg + | WrongLocation (Maybe InstalledPackageLocation) InstallLocation + | WrongVersion Version Version + deriving (Eq, Show) + -- | Check if a can be included in the set of installed packages or not, based -- on the package selections made by the user. This does not perform any -- dirtiness or flag change checks. @@ -176,54 +226,62 @@ -> Map PackageName pii -> Maybe InstalledPackageLocation -> DumpPackage Bool Bool - -> Maybe LoadHelper + -> Allowed isAllowed opts mcache sourceMap mloc dp -- Check that it can do profiling if necessary - | getInstalledProfiling opts && isJust mcache && not (dpProfiling dp) = Nothing + | getInstalledProfiling opts && isJust mcache && not (dpProfiling dp) = NeedsProfiling -- Check that it has haddocks if necessary - | getInstalledHaddock opts && isJust mcache && not (dpHaddock dp) = Nothing - | toInclude = Just LoadHelper - { lhId = gid - , lhDeps = - -- We always want to consider the wired in packages as having all - -- of their dependencies installed, since we have no ability to - -- reinstall them. This is especially important for using different - -- minor versions of GHC, where the dependencies of wired-in - -- packages may change slightly and therefore not match the - -- snapshot. - if name `HashSet.member` wiredInPackages - then [] - else dpDepends dp - , lhPair = (name, (version, toPackageLocation mloc, Library ident gid)) - } - | otherwise = Nothing - where - toPackageLocation :: Maybe InstalledPackageLocation -> InstallLocation - toPackageLocation Nothing = Snap - toPackageLocation (Just ExtraGlobal) = Snap - toPackageLocation (Just (InstalledTo loc)) = loc - - toInclude = + | getInstalledHaddock opts && isJust mcache && not (dpHaddock dp) = NeedsHaddock + | otherwise = case Map.lookup name sourceMap of Nothing -> case mloc of -- The sourceMap has nothing to say about this global -- package, so we can use it - Nothing -> True - Just ExtraGlobal -> True + Nothing -> Allowed + Just ExtraGlobal -> Allowed -- For non-global packages, don't include unknown packages. -- See: -- https://github.com/commercialhaskell/stack/issues/292 - Just _ -> False - - Just pii -> - version == piiVersion pii -- only accept the desired version - && checkLocation (piiLocation pii) - + Just _ -> UnknownPkg + Just pii + | not (checkLocation (piiLocation pii)) -> WrongLocation mloc (piiLocation pii) + | version /= piiVersion pii -> WrongVersion version (piiVersion pii) + | otherwise -> Allowed + where + PackageIdentifier name version = dpPackageIdent dp -- Ensure that the installed location matches where the sourceMap says it -- should be installed checkLocation Snap = mloc /= Just (InstalledTo Local) -- we can allow either global or snap checkLocation Local = mloc == Just (InstalledTo Local) || mloc == Just ExtraGlobal -- 'locally' installed snapshot packages can come from extra dbs +data LoadHelper = LoadHelper + { lhId :: !GhcPkgId + , lhDeps :: ![GhcPkgId] + , lhPair :: !(PackageName, (InstallLocation, Installed)) + } + deriving Show + +toLoadHelper :: Maybe InstalledPackageLocation -> DumpPackage Bool Bool -> LoadHelper +toLoadHelper mloc dp = LoadHelper + { lhId = gid + , lhDeps = + -- We always want to consider the wired in packages as having all + -- of their dependencies installed, since we have no ability to + -- reinstall them. This is especially important for using different + -- minor versions of GHC, where the dependencies of wired-in + -- packages may change slightly and therefore not match the + -- snapshot. + if name `HashSet.member` wiredInPackages + then [] + else dpDepends dp + , lhPair = (name, (toPackageLocation mloc, Library ident gid)) + } + where gid = dpGhcPkgId dp - ident@(PackageIdentifier name version) = dpPackageIdent dp + ident@(PackageIdentifier name _) = dpPackageIdent dp + +toPackageLocation :: Maybe InstalledPackageLocation -> InstallLocation +toPackageLocation Nothing = Snap +toPackageLocation (Just ExtraGlobal) = Snap +toPackageLocation (Just (InstalledTo loc)) = loc diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -60,7 +60,6 @@ parseCustomMiniBuildPlan) import Stack.Constants (wiredInPackages) import Stack.Package -import Stack.PackageIndex import Stack.Types import System.Directory @@ -80,9 +79,10 @@ bconfig <- asks getBuildConfig rawLocals <- getLocalPackageViews (mbp0, cliExtraDeps, targets) <- parseTargetsFromBuildOpts needTargets bopts - menv <- getMinimalEnvOverride - caches <- getPackageCaches menv - let latestVersion = Map.fromListWith max $ map toTuple $ Map.keys caches + let latestVersion = + Map.fromListWith max $ + map toTuple $ + Map.keys (bcPackageCaches bconfig) -- Extend extra-deps to encompass targets requested on the command line -- that are not in the snapshot. @@ -94,6 +94,7 @@ locals <- mapM (loadLocalPackage bopts targets) $ Map.toList rawLocals checkFlagsUsed bopts locals extraDeps0 (mbpPackages mbp0) + checkComponentsBuildable locals let -- loadLocals returns PackageName (foo) and PackageIdentifier (bar-1.2.3) targets separately; @@ -115,7 +116,7 @@ -- the snapshot extraDeps2 = Map.union (Map.map (\v -> (v, Map.empty)) extraDeps0) - (Map.map (\mpi -> (mpiVersion mpi, mpiFlags mpi)) extraDeps1) + (Map.map (mpiVersion &&& mpiFlags) extraDeps1) -- Overwrite any flag settings with those from the config file extraDeps3 = Map.mapWithKey @@ -230,7 +231,7 @@ (warnings,gpkg) <- readPackageUnresolved cabalfp mapM_ (printCabalFileWarning cabalfp) warnings let cabalID = package $ packageDescription gpkg - name = fromCabalPackageName $ pkgName $ cabalID + name = fromCabalPackageName $ pkgName cabalID checkCabalFileName name cabalfp let lpv = LocalPackageView { lpvVersion = fromCabalVersion $ pkgVersion cabalID @@ -314,6 +315,12 @@ Just STUnknown -> assert False mempty Nothing -> mempty + toComponents e t b = Set.unions + [ Set.map CExe e + , Set.map CTest t + , Set.map CBench b + ] + btconfig = config { packageConfigEnableTests = not $ Set.null tests , packageConfigEnableBenchmarks = not $ Set.null benches @@ -329,45 +336,46 @@ btpkg | Set.null tests && Set.null benches = Nothing - | otherwise = Just $ LocalPackageTB - { lptbPackage = resolvePackage btconfig gpkg - , lptbTests = tests - , lptbBenches = benches - } + | otherwise = Just (resolvePackage btconfig gpkg) testpkg = resolvePackage testconfig gpkg benchpkg = resolvePackage benchconfig gpkg mbuildCache <- tryGetBuildCache $ lpvRoot lpv (files,_) <- getPackageFilesSimple pkg (lpvCabalFP lpv) + + -- Filter out the cabal_macros file to avoid spurious recompilations + let filteredFiles = Set.filter ((/= $(mkRelFile "cabal_macros.h")) . filename) files + (dirtyFiles, newBuildCache) <- checkBuildCache (fromMaybe Map.empty mbuildCache) - (map toFilePath $ Set.toList files) + (map toFilePath $ Set.toList filteredFiles) return LocalPackage { lpPackage = pkg - , lpTestDeps = packageDeps $ testpkg - , lpBenchDeps = packageDeps $ benchpkg - , lpExeComponents = - case mtarget of - Nothing -> Nothing - Just _ -> Just exes + , lpTestDeps = packageDeps testpkg + , lpBenchDeps = packageDeps benchpkg , lpTestBench = btpkg , lpFiles = files , lpDirtyFiles = if not (Set.null dirtyFiles) || boptsForceDirty bopts then let tryStripPrefix y = - case stripPrefix (toFilePath $ lpvRoot lpv) y of - Nothing -> y - Just z -> z + fromMaybe y (stripPrefix (toFilePath $ lpvRoot lpv) y) in Just $ Set.map tryStripPrefix dirtyFiles else Nothing , lpNewBuildCache = newBuildCache , lpCabalFile = lpvCabalFP lpv , lpDir = lpvRoot lpv - , lpComponents = Set.unions - [ Set.map CExe exes - , Set.map CTest tests - , Set.map CBench benches - ] + , lpWanted = isJust mtarget + , lpComponents = toComponents exes tests benches + -- TODO: refactor this so that it's easier to be sure that these + -- components are indeed unbuildable. + -- + -- The reasoning here is that if the STLocalComps specification + -- made it through component parsing, but the components aren't + -- present, then they must not be buildable. + , lpUnbuildable = toComponents + (exes `Set.difference` packageExes pkg) + (tests `Set.difference` packageTests pkg) + (benches `Set.difference` packageBenchmarks pkg) } -- | Ensure that the flags specified in the stack.yaml file and on the command @@ -421,9 +429,9 @@ -> PackageName -> Map FlagName Bool localFlags boptsflags bconfig name = Map.unions - [ fromMaybe Map.empty $ Map.lookup (Just name) $ boptsflags - , fromMaybe Map.empty $ Map.lookup Nothing $ boptsflags - , fromMaybe Map.empty $ Map.lookup name $ bcFlags bconfig + [ Map.findWithDefault Map.empty (Just name) boptsflags + , Map.findWithDefault Map.empty Nothing boptsflags + , Map.findWithDefault Map.empty name (bcFlags bconfig) ] -- | Add in necessary packages to extra dependencies @@ -464,7 +472,7 @@ -> [FilePath] -- ^ files in package -> m (Set FilePath, Map FilePath FileCacheInfo) checkBuildCache oldCache files = liftIO $ do - (dirtyFiles, m) <- fmap mconcat $ mapM go files + (dirtyFiles, m) <- mconcat <$> mapM go files return (dirtyFiles, m) where go fp = do @@ -553,3 +561,13 @@ , fciSize = size , fciHash = toBytes (digest :: Digest SHA256) } + +checkComponentsBuildable :: MonadThrow m => [LocalPackage] -> m () +checkComponentsBuildable lps = + unless (null unbuildable) $ throwM $ SomeTargetsNotBuildable unbuildable + where + unbuildable = + [ (packageName (lpPackage lp), c) + | lp <- lps + , c <- Set.toList (lpUnbuildable lp) + ] diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -145,7 +145,7 @@ -> Either Text ((RawInput, RawTarget 'NoIdents), Map PackageName Version) resolveIdents _ _ _ (ri, RTPackageComponent x y) = Right ((ri, RTPackageComponent x y), Map.empty) resolveIdents _ _ _ (ri, RTComponent x) = Right ((ri, RTComponent x), Map.empty) -resolveIdents _ _ _ (ri, RTPackage x) = Right $ ((ri, RTPackage x), Map.empty) +resolveIdents _ _ _ (ri, RTPackage x) = Right ((ri, RTPackage x), Map.empty) resolveIdents snap extras locals (ri, RTPackageIdentifier (PackageIdentifier name version)) = case mfound of Just (foundPlace, foundVersion) | foundVersion /= version -> Left $ T.pack $ concat diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -6,7 +6,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} - -- | Resolving a build plan for a set of packages in a given Stackage -- snapshot. @@ -76,9 +75,7 @@ import Prelude -- Fix AMP warning import Stack.Constants import Stack.Fetch -import Stack.GhcPkg import Stack.Package -import Stack.PackageIndex import Stack.Types import Stack.Types.StackT import System.Directory (canonicalizePath) @@ -177,21 +174,22 @@ -- -- This may fail if a target package is not present in the @BuildPlan@. resolveBuildPlan :: (MonadThrow m, MonadIO m, MonadReader env m, HasBuildConfig env, MonadLogger m, HasHttpManager env, MonadBaseControl IO m,MonadCatch m) - => EnvOverride - -> MiniBuildPlan + => MiniBuildPlan -> (PackageName -> Bool) -- ^ is it shadowed by a local package? -> Map PackageName (Set PackageName) -- ^ required packages, and users of it -> m ( Map PackageName (Version, Map FlagName Bool) , Map PackageName (Set PackageName) ) -resolveBuildPlan menv mbp isShadowed packages +resolveBuildPlan mbp isShadowed packages | Map.null (rsUnknown rs) && Map.null (rsShadowed rs) = return (rsToInstall rs, rsUsedBy rs) | otherwise = do - cache <- getPackageCaches menv - let maxVer = Map.fromListWith max $ map toTuple $ Map.keys cache + bconfig <- asks getBuildConfig + let maxVer = + Map.fromListWith max $ + map toTuple $ + Map.keys (bcPackageCaches bconfig) unknown = flip Map.mapWithKey (rsUnknown rs) $ \ident x -> (Map.lookup ident maxVer, x) - bconfig <- asks getBuildConfig throwM $ UnknownPackages (bcStackYaml bconfig) unknown @@ -434,8 +432,7 @@ -> m MiniBuildPlan loadMiniBuildPlan name = do path <- configMiniBuildPlanCache name - let fp = toFilePath path - taggedDecodeOrLoad fp $ liftM buildPlanFixes $ do + taggedDecodeOrLoad path $ liftM buildPlanFixes $ do bp <- loadBuildPlan name toMiniBuildPlan (siCompilerVersion $ bpSystemInfo bp) @@ -472,7 +469,7 @@ env <- ask let stackage = getStackRoot env file' <- parseRelFile $ T.unpack file - let fp = stackage $(mkRelDir "build-plan") file' + let fp = buildPlanDir stackage file' $logDebug $ "Decoding build plan from: " <> T.pack (toFilePath fp) eres <- liftIO $ decodeFileEither $ toFilePath fp case eres of @@ -693,7 +690,7 @@ customPlanDir <- getCustomPlanDir let binaryFP = customPlanDir $(mkRelDir "bin") binaryFilename - taggedDecodeOrLoad (toFilePath binaryFP) $ do + taggedDecodeOrLoad binaryFP $ do cs <- either throwM return $ decodeEither' yamlBS let addFlags :: PackageIdentifier -> (PackageName, (Version, Map FlagName Bool)) addFlags (PackageIdentifier name ver) = diff --git a/src/Stack/Clean.hs b/src/Stack/Clean.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Clean.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Clean a project. +module Stack.Clean + (clean + ,CleanOpts(..) + ,StackCleanException(..) + ) where + +import Control.Exception (Exception) +import Control.Monad.Catch (MonadThrow,throwM) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Logger (MonadLogger) +import Control.Monad.Reader (MonadReader) +import Data.Foldable (forM_) +import Data.List ((\\),intercalate) +import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) +import Data.Typeable (Typeable) +import Path.IO (removeTreeIfExists) +import Stack.Build.Source (getLocalPackageViews) +import Stack.Build.Target (LocalPackageView(..)) +import Stack.Constants (distDirFromDir) +import Stack.Types (HasEnvConfig,PackageName) + + +-- | Reset the build, i.e. remove the @dist@ directory +-- (for example @.stack-work\/dist\/x84_64-linux\/Cabal-1.22.4.0@) +-- for all targets. +-- +-- Throws 'StackCleanException'. +clean + :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m) + => CleanOpts + -> m () +clean (CleanOpts targets) = do + locals <- getLocalPackageViews + case targets \\ Map.keys locals of + [] -> do + let lpvs = + if null targets + then Map.elems locals -- default to cleaning all local packages + else mapMaybe (`Map.lookup` locals) targets + forM_ lpvs $ \(LocalPackageView{lpvRoot = pkgDir},_) -> do + distDir <- distDirFromDir pkgDir + removeTreeIfExists distDir + pkgs -> throwM (NonLocalPackages pkgs) + +-- | Options for cleaning a project. +newtype CleanOpts = CleanOpts + { cleanOptsTargets :: [PackageName] + -- ^ Names of the packages to clean. + -- If the list is empty, every local package should be cleaned. + } + +-- | Exceptions during cleanup. +newtype StackCleanException + = NonLocalPackages [PackageName] + deriving (Typeable) + +instance Show StackCleanException where + show (NonLocalPackages pkgs) = + "The following packages are not part of this project: " ++ + intercalate ", " (map show pkgs) + +instance Exception StackCleanException diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -34,9 +34,8 @@ import qualified Codec.Compression.GZip as GZip import Control.Applicative import Control.Arrow ((***)) -import Control.Exception (IOException) import Control.Monad -import Control.Monad.Catch (Handler(..), MonadCatch, MonadThrow, catches, throwM) +import Control.Monad.Catch (MonadThrow, MonadCatch, catchAll, throwM) import Control.Monad.IO.Class import Control.Monad.Logger hiding (Loc) import Control.Monad.Reader (MonadReader, ask, runReaderT) @@ -62,14 +61,16 @@ import Network.HTTP.Download (download) import Options.Applicative (Parser, strOption, long, help) import Path +import Path.Extra (toFilePathNoTrailingSep) import Path.IO import qualified Paths_stack as Meta import Safe (headMay) import Stack.BuildPlan -import Stack.Constants import Stack.Config.Docker +import Stack.Constants import qualified Stack.Image as Image import Stack.Init +import Stack.PackageIndex import Stack.Types import Stack.Types.Internal import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing, canonicalizePath) @@ -86,10 +87,7 @@ let mlts = do (x,y) <- listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots))) return (LTS x y) - snap = - case mlts of - Nothing -> Nightly (snapshotsNightly snapshots) - Just lts -> lts + snap = fromMaybe (Nightly (snapshotsNightly snapshots)) mlts return (ResolverSnapshot snap) -- Interprets ConfigMonoid options. @@ -97,7 +95,7 @@ :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env) => Path Abs Dir -- ^ stack root, e.g. ~/.stack -> Path Abs File -- ^ user config file path, e.g. ~/.stack/config.yaml - -> Maybe Project + -> Maybe (Project, Path Abs File) -> ConfigMonoid -> m Config configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoid@ConfigMonoid{..} = do @@ -145,7 +143,7 @@ configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck - configDocker <- dockerOptsFromMonoid mproject configStackRoot configMonoidDockerOpts + configDocker <- dockerOptsFromMonoid (fmap fst mproject) configStackRoot configMonoidDockerOpts rawEnv <- liftIO getEnvironment origEnv <- mkEnvOverride configPlatform @@ -171,11 +169,17 @@ localDir <- liftIO (getAppUserDataDirectory "local") >>= parseAbsDir return $ localDir $(mkRelDir "bin") Just userPath -> - (liftIO $ canonicalizePath userPath >>= parseAbsDir) - `catches` - [Handler (\(_ :: IOException) -> throwM $ NoSuchDirectory userPath) - ,Handler (\(_ :: PathParseException) -> throwM $ NoSuchDirectory userPath) - ] + (case mproject of + -- Not in a project + Nothing -> parseRelAsAbsDir userPath + -- Resolves to the project dir and appends the user path if it is relative + Just (_, configYaml) -> resolveDir (parent configYaml) userPath) + -- TODO: Either catch specific exceptions or add a + -- parseRelAsAbsDirMaybe utility and use it along with + -- resolveDirMaybe. + `catchAll` + const (throwM (NoSuchDirectory userPath)) + configJobs <- case configMonoidJobs of Nothing -> liftIO getNumProcessors @@ -191,6 +195,7 @@ configExplicitSetupDeps = configMonoidExplicitSetupDeps configRebuildGhcOptions = fromMaybe False configMonoidRebuildGhcOptions configApplyGhcOptions = fromMaybe AGOLocals configMonoidApplyGhcOptions + configAllowNewer = fromMaybe False configMonoidAllowNewer return Config {..} @@ -249,7 +254,7 @@ :: (MonadIO m, HasHttpManager a, MonadReader a m, MonadBaseControl IO m, MonadCatch m, MonadLogger m) => Config -> m MiniConfig loadMiniConfig config = do - menv <- liftIO $ (configEnvOverride config) minimalEnvSettings + menv <- liftIO $ configEnvOverride config minimalEnvSettings manager <- getHttpManager <$> ask ghcVariant <- case configGHCVariant0 config of @@ -276,13 +281,14 @@ (configMonoidDockerOpts c) {dockerMonoidDefaultEnable = False}}) extraConfigs0 mproject <- loadProjectConfig mstackYaml - config <- configFromConfigMonoid stackRoot userConfigPath (fmap (\(proj, _, _) -> proj) mproject) $ mconcat $ + let mproject' = (\(project, stackYaml, _) -> (project, stackYaml)) <$> mproject + config <- configFromConfigMonoid stackRoot userConfigPath mproject' $ mconcat $ case mproject of Nothing -> configArgs : extraConfigs Just (_, _, projectConfig) -> configArgs : projectConfig : extraConfigs unless (fromCabalVersion Meta.version `withinRange` configRequireStackVersion config) (throwM (BadStackVersionException (configRequireStackVersion config))) - return $ LoadConfig + return LoadConfig { lcConfig = config , lcLoadBuildConfig = loadBuildConfig mproject config , lcProjectRoot = fmap (\(_, fp, _) -> parent fp) mproject @@ -294,8 +300,9 @@ => Maybe (Project, Path Abs File, ConfigMonoid) -> Config -> Maybe AbstractResolver -- override resolver + -> Maybe CompilerVersion -- override compiler -> m BuildConfig -loadBuildConfig mproject config mresolver = do +loadBuildConfig mproject config mresolver mcompiler = do env <- ask miniConfig <- loadMiniConfig config @@ -339,6 +346,7 @@ , projectExtraDeps = mempty , projectFlags = mempty , projectResolver = r + , projectCompiler = Nothing , projectExtraPackageDBs = [] } liftIO $ do @@ -359,22 +367,29 @@ resolver <- case mresolver of Nothing -> return $ projectResolver project' - Just aresolver -> do + Just aresolver -> runReaderT (makeConcreteResolver aresolver) miniConfig - let project = project' { projectResolver = resolver } + let project = project' + { projectResolver = resolver + , projectCompiler = mcompiler <|> projectCompiler project' + } wantedCompiler <- - case projectResolver project of - ResolverSnapshot snapName -> do - mbp <- runReaderT (loadMiniBuildPlan snapName) miniConfig - return $ mbpCompilerVersion mbp - ResolverCustom _name url -> do - mbp <- runReaderT (parseCustomMiniBuildPlan stackYamlFP url) miniConfig - return $ mbpCompilerVersion mbp - ResolverCompiler wantedCompiler -> return wantedCompiler + case projectCompiler project of + Just wantedCompiler -> return wantedCompiler + Nothing -> case projectResolver project of + ResolverSnapshot snapName -> do + mbp <- runReaderT (loadMiniBuildPlan snapName) miniConfig + return $ mbpCompilerVersion mbp + ResolverCustom _name url -> do + mbp <- runReaderT (parseCustomMiniBuildPlan stackYamlFP url) miniConfig + return $ mbpCompilerVersion mbp + ResolverCompiler wantedCompiler -> return wantedCompiler extraPackageDBs <- mapM parseRelAsAbsDir (projectExtraPackageDBs project) + packageCaches <- runReaderT (getMinimalEnvOverride >>= getPackageCaches) miniConfig + return BuildConfig { bcConfig = config , bcResolver = projectResolver project @@ -386,6 +401,7 @@ , bcFlags = projectFlags project , bcImplicitGlobal = isNothing mproject , bcGHCVariant = getGHCVariant miniConfig + , bcPackageCaches = packageCaches } -- | Resolve a PackageEntry into a list of paths, downloading and cloning as @@ -463,7 +479,7 @@ readInNull (parent dirTmp) "git" menv [ "clone" , T.unpack url - , toFilePath dirTmp + , toFilePathNoTrailingSep dirTmp ] Nothing readInNull dirTmp "git" menv diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs --- a/src/Stack/Config/Docker.hs +++ b/src/Stack/Config/Docker.hs @@ -10,6 +10,7 @@ import Data.Maybe import qualified Data.Text as T import Data.Typeable (Typeable) +import Distribution.Version (simplifyVersionRange) import Path import Stack.Types @@ -55,6 +56,7 @@ dockerMount = dockerMonoidMount dockerEnv = dockerMonoidEnv dockerSetUser = dockerMonoidSetUser + dockerRequireDockerVersion = simplifyVersionRange dockerMonoidRequireDockerVersion dockerDatabasePath <- case dockerMonoidDatabasePath of Nothing -> return $ stackRoot $(mkRelFile "docker.db") diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs new file mode 100644 --- /dev/null +++ b/src/Stack/ConfigCmd.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Make changes to the stack yaml file + +module Stack.ConfigCmd + (ConfigCmdSet(..) + ,cfgCmdSet + ,cfgCmdSetName + ,cfgCmdName) where + +import Control.Monad.Catch (MonadMask, throwM, MonadThrow) +import Control.Monad.IO.Class +import Control.Monad.Logger +import Control.Monad.Reader (MonadReader, asks) +import Control.Monad.Trans.Control (MonadBaseControl) +import qualified Data.ByteString as S +import qualified Data.HashMap.Strict as HMap +import qualified Data.Yaml as Yaml +import Network.HTTP.Client.Conduit (HasHttpManager) +import Path +import Stack.BuildPlan +import Stack.Init +import Stack.Types + +data ConfigCmdSet = ConfigCmdSetResolver AbstractResolver + +cfgCmdSet :: ( MonadIO m + , MonadBaseControl IO m + , MonadMask m + , MonadReader env m + , HasConfig env + , HasBuildConfig env + , HasHttpManager env + , HasGHCVariant env + , MonadThrow m + , MonadLogger m) + => ConfigCmdSet -> m () +cfgCmdSet (ConfigCmdSetResolver newResolver) = do + stackYaml <- fmap bcStackYaml (asks getBuildConfig) + let stackYamlFp = + toFilePath stackYaml + -- We don't need to worry about checking for a valid yaml here + (projectYamlConfig :: Yaml.Object) <- + liftIO (Yaml.decodeFileEither stackYamlFp) >>= + either throwM return + newResolverText <- fmap resolverName (makeConcreteResolver newResolver) + -- We checking here that the snapshot actually exists + snap <- parseSnapName newResolverText + _ <- loadMiniBuildPlan snap + + let projectYamlConfig' = + HMap.insert + "resolver" + (Yaml.String newResolverText) + projectYamlConfig + liftIO + (S.writeFile + stackYamlFp + (Yaml.encode projectYamlConfig')) + return () + +cfgCmdName :: String +cfgCmdName = "config" + +cfgCmdSetName :: String +cfgCmdSetName = "set" diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,6 +6,7 @@ module Stack.Constants (builtConfigFileFromDir ,builtFileFromDir + ,buildPlanDir ,configuredFileFromDir ,defaultShakeThreads ,distDirFromDir @@ -26,12 +26,12 @@ ,benchBuiltFile ,stackProgName ,wiredInPackages + ,ghcjsBootPackages ,cabalPackageName ,implicitGlobalProjectDirDeprecated ,implicitGlobalProjectDir ,hpcRelativeDir ,hpcDirFromDir - ,dotHpc ,objectInterfaceDir ,templatesDir ,defaultUserConfigPathDeprecated @@ -49,16 +49,10 @@ import qualified Data.Text as T import Path as FL import Prelude +import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageName -#ifdef mingw32_HOST_OS -import qualified Crypto.Hash.SHA1 as SHA1 -import qualified Data.ByteString as B -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as B8 -import qualified Data.Text.Encoding as T -#endif -- | Extensions for anything that can be a Haskell module. haskellModuleExts :: [Text] @@ -132,7 +126,7 @@ buildCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env) => Path Abs Dir -- ^ Package directory. -> m (Path Abs File) -buildCacheFile dir = do +buildCacheFile dir = liftM ( $(mkRelFile "stack-build-cache")) (distDirFromDir dir) @@ -168,7 +162,7 @@ configCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env) => Path Abs Dir -- ^ Package directory. -> m (Path Abs File) -configCacheFile dir = do +configCacheFile dir = liftM ( $(mkRelFile "stack-config-cache")) (distDirFromDir dir) @@ -177,7 +171,7 @@ configCabalMod :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env) => Path Abs Dir -- ^ Package directory. -> m (Path Abs File) -configCabalMod dir = do +configCabalMod dir = liftM ( $(mkRelFile "stack-cabal-mod")) (distDirFromDir dir) @@ -213,22 +207,14 @@ distRelativeDir = do cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig) platform <- platformVariantRelDir - cabal <- + wc <- getWhichCompiler + -- Cabal version, suffixed with "_ghcjs" if we're using GHCJS. + envDir <- parseRelDir $ - packageIdentifierString - (PackageIdentifier cabalPackageName cabalPkgVer) - -#ifdef mingw32_HOST_OS - -- This is an attempt to shorten path to stack build artifacts dir on Windows to - -- decrease our chances of hitting 260 symbol path limit. - -- The idea is to calculate SHA1 hash from concatenated platform and cabal strings, - -- encode with base 16 and take first 8 symbols of it. - let concatenatedText = T.pack . toFilePath $ platform cabal - sha1 = SHA1.hash $ T.encodeUtf8 concatenatedText - platformAndCabal <- parseRelDir . B8.unpack . B.take 8 $ Base16.encode sha1 -#else - let platformAndCabal = platform cabal -#endif + (if wc == Ghcjs then (++ "_ghcjs") else id) $ + packageIdentifierString $ + PackageIdentifier cabalPackageName cabalPkgVer + platformAndCabal <- useShaPathOnWindows (platform envDir) return $ workDirRel $(mkRelDir "dist") @@ -290,7 +276,7 @@ wiredInPackages = maybe (error "Parse error in wiredInPackages") HashSet.fromList mparsed where - mparsed = sequence $ map parsePackageName + mparsed = mapM parsePackageName [ "ghc-prim" , "integer-gmp" , "integer-simple" @@ -303,6 +289,53 @@ , "interactive" ] +-- TODO: Get this unwieldy list out of here and into a datafile +-- generated by GHCJS! See https://github.com/ghcjs/ghcjs/issues/434 +ghcjsBootPackages :: HashSet PackageName +ghcjsBootPackages = + maybe (error "Parse error in ghcjsBootPackages") HashSet.fromList mparsed + where + mparsed = mapM parsePackageName + -- stage1a + [ "array" + , "base" + , "binary" + , "bytestring" + , "containers" + , "deepseq" + , "integer-gmp" + , "pretty" + , "primitive" + , "integer-gmp" + , "pretty" + , "primitive" + , "template-haskell" + , "transformers" + -- stage1b + , "directory" + , "filepath" + , "old-locale" + , "process" + , "time" + -- stage2 + , "async" + , "aeson" + , "attoparsec" + , "case-insensitive" + , "dlist" + , "extensible-exceptions" + , "hashable" + , "mtl" + , "old-time" + , "parallel" + , "scientific" + , "stm" + , "syb" + , "text" + , "unordered-containers" + , "vector" + ] + -- | Just to avoid repetition and magic strings. cabalPackageName :: PackageName cabalPackageName = @@ -323,10 +356,6 @@ p $(mkRelDir "global-project") --- | Where .mix files go. -dotHpc :: Path Rel Dir -dotHpc = $(mkRelDir ".hpc") - -- | Deprecated default global config path. defaultUserConfigPathDeprecated :: Path Abs Dir -> Path Abs File defaultUserConfigPathDeprecated = ( $(mkRelFile "stack.yaml")) @@ -346,3 +375,8 @@ -- Note that this will be @Nothing@ on Windows, which is by design. defaultGlobalConfigPath :: Maybe (Path Abs File) defaultGlobalConfigPath = parseAbsFile "/etc/stack/config.yaml" + +-- | Path where build plans are stored. +buildPlanDir :: Path Abs Dir -- ^ Stack root + -> Path Abs Dir +buildPlanDir = ( $(mkRelDir "build-plan")) diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Coverage.hs @@ -0,0 +1,400 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +-- | Generate HPC (Haskell Program Coverage) reports +module Stack.Coverage + ( deleteHpcReports + , updateTixFile + , generateHpcReport + , HpcReportOpts(..) + , generateHpcReportForTargets + , generateHpcUnifiedReport + , generateHpcMarkupIndex + ) where + +import Control.Applicative +import Control.Exception.Lifted +import Control.Monad (liftM, when, unless, void) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class +import Control.Monad.Logger +import Control.Monad.Reader (MonadReader, asks) +import Control.Monad.Trans.Resource +import qualified Data.ByteString.Char8 as S8 +import Data.Foldable (forM_, asum, toList) +import Data.Function +import Data.List +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Maybe.Extra (mapMaybeM) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as LT +import Data.Traversable (forM) +import Network.HTTP.Download (HasHttpManager) +import Path +import Path.Extra (toFilePathNoTrailingSep) +import Path.IO +import Prelude hiding (FilePath, writeFile) +import Stack.Build.Source (parseTargetsFromBuildOpts) +import Stack.Build.Target +import Stack.Constants +import Stack.Package +import Stack.Types +import qualified System.Directory as D +import System.FilePath (dropExtension, isPathSeparator) +import System.Process.Read +import Text.Hastache (htmlEscape) +import Trace.Hpc.Tix + +-- | Invoked at the beginning of running with "--coverage" +deleteHpcReports :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) + => m () +deleteHpcReports = do + hpcDir <- hpcReportDir + removeTreeIfExists hpcDir + +-- | Move a tix file into a sub-directory of the hpc report directory. Deletes the old one if one is +-- present. +updateTixFile :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) + => PackageName -> Path Abs File -> m () +updateTixFile pkgName tixSrc = do + exists <- fileExists tixSrc + when exists $ do + tixDest <- tixFilePath pkgName (dropExtension (toFilePath (filename tixSrc))) + removeFileIfExists tixDest + createTree (parent tixDest) + -- Remove exe modules because they are problematic. This could be revisited if there's a GHC + -- version that fixes https://ghc.haskell.org/trac/ghc/ticket/1853 + mtix <- readTixOrLog tixSrc + case mtix of + Nothing -> $logError $ "Failed to read " <> T.pack (toFilePath tixSrc) + Just tix -> do + liftIO $ writeTix (toFilePath tixDest) (removeExeModules tix) + removeFileIfExists tixSrc + +-- | Get the directory used for hpc reports for the given pkgId. +hpcPkgPath :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) + => PackageName -> m (Path Abs Dir) +hpcPkgPath pkgName = do + outputDir <- hpcReportDir + pkgNameRel <- parseRelDir (packageNameString pkgName) + return (outputDir pkgNameRel) + +-- | Get the tix file location, given the name of the file (without extension), and the package +-- identifier string. +tixFilePath :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) + => PackageName -> String -> m (Path Abs File) +tixFilePath pkgName tixName = do + pkgPath <- hpcPkgPath pkgName + tixRel <- parseRelFile (tixName ++ "/" ++ tixName ++ ".tix") + return (pkgPath tixRel) + +-- | Generates the HTML coverage report and shows a textual coverage summary for a package. +generateHpcReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) + => Path Abs Dir -> Package -> [Text] -> m () +generateHpcReport pkgDir package tests = do + -- If we're using > GHC 7.10, the hpc 'include' parameter must specify a ghc package key. See + -- https://github.com/commercialhaskell/stack/issues/785 + let pkgName = packageNameText (packageName package) + pkgId = packageIdentifierString (packageIdentifier package) + compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig) + eincludeName <- + -- Pre-7.8 uses plain PKG-version in tix files. + if getGhcVersion compilerVersion < $(mkVersion "7.10") then return $ Right $ Just pkgId + -- We don't expect to find a package key if there is no library. + else if not (packageHasLibrary package) then return $ Right Nothing + -- Look in the inplace DB for the package key. + -- See https://github.com/commercialhaskell/stack/issues/1181#issuecomment-148968986 + else do + mghcPkgKey <- findPackageKeyForBuiltPackage pkgDir (packageIdentifier package) + case mghcPkgKey of + Nothing -> do + let msg = "Failed to find GHC package key for " <> pkgName + $logError msg + return $ Left msg + Just ghcPkgKey -> return $ Right $ Just $ T.unpack ghcPkgKey + forM_ tests $ \testName -> do + tixSrc <- tixFilePath (packageName package) (T.unpack testName) + let report = "coverage report for " <> pkgName <> "'s test-suite \"" <> testName <> "\"" + reportDir = parent tixSrc + case eincludeName of + Left err -> generateHpcErrorReport reportDir (sanitize (T.unpack err)) + -- Restrict to just the current library code, if there is a library in the package (see + -- #634 - this will likely be customizable in the future) + Right mincludeName -> do + let extraArgs = case mincludeName of + Just includeName -> ["--include", includeName ++ ":"] + Nothing -> [] + generateHpcReportInternal tixSrc reportDir report extraArgs extraArgs + +generateHpcReportInternal :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) + => Path Abs File -> Path Abs Dir -> Text -> [String] -> [String] -> m () +generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArgs = do + -- If a .tix file exists, move it to the HPC output directory and generate a report for it. + tixFileExists <- fileExists tixSrc + if not tixFileExists + then $logError $ T.concat + [ "Didn't find .tix for " + , report + , " - expected to find it at " + , T.pack (toFilePath tixSrc) + , "." + ] + else (`catch` \err -> do + let msg = show (err :: ReadProcessException) + $logError (T.pack msg) + generateHpcErrorReport reportDir $ sanitize msg) $ + (`onException` $logError ("Error occurred while producing " <> report)) $ do + -- Directories for .mix files. + hpcRelDir <- hpcRelativeDir + -- Compute arguments used for both "hpc markup" and "hpc report". + pkgDirs <- Map.keys . envConfigPackages <$> asks getEnvConfig + let args = + -- Use index files from all packages (allows cross-package coverage results). + concatMap (\x -> ["--srcdir", toFilePathNoTrailingSep x]) pkgDirs ++ + -- Look for index files in the correct dir (relative to each pkgdir). + ["--hpcdir", toFilePathNoTrailingSep hpcRelDir, "--reset-hpcdirs"] + menv <- getMinimalEnvOverride + $logInfo $ "Generating " <> report + outputLines <- liftM S8.lines $ readProcessStdout Nothing menv "hpc" + ( "report" + : toFilePath tixSrc + : (args ++ extraReportArgs) + ) + if all ("(0/0)" `S8.isSuffixOf`) outputLines + then do + let msg html = T.concat + [ "Error: The " + , report + , " did not consider any code. One possible cause of this is" + , " if your test-suite builds the library code (see stack " + , if html then "" else "" + , "issue #1008" + , if html then "" else "" + , "). It may also indicate a bug in stack or" + , " the hpc program. Please report this issue if you think" + , " your coverage report should have meaningful results." + ] + $logError (msg False) + generateHpcErrorReport reportDir (msg True) + else do + -- Print output, stripping @\r@ characters because Windows. + forM_ outputLines ($logInfo . T.decodeUtf8 . S8.filter (not . (=='\r'))) + $logInfo + ("The " <> report <> " is available at " <> + T.pack (toFilePath (reportDir $(mkRelFile "hpc_index.html")))) + -- Generate the markup. + void $ readProcessStdout Nothing menv "hpc" + ( "markup" + : toFilePath tixSrc + : ("--destdir=" ++ toFilePathNoTrailingSep reportDir) + : (args ++ extraMarkupArgs) + ) + +data HpcReportOpts = HpcReportOpts + { hroptsInputs :: [Text] + , hroptsAll :: Bool + , hroptsDestDir :: Maybe String + } deriving (Show) + +generateHpcReportForTargets :: (MonadIO m, HasHttpManager env, MonadReader env m, MonadBaseControl IO m, MonadCatch m, MonadLogger m, HasEnvConfig env) + => HpcReportOpts -> m () +generateHpcReportForTargets opts = do + let (tixFiles, targetNames) = partition (".tix" `T.isSuffixOf`) (hroptsInputs opts) + targetTixFiles <- + -- When there aren't any package component arguments, then + -- don't default to all package components. + if not (hroptsAll opts) && null targetNames + then return [] + else do + when (hroptsAll opts && not (null targetNames)) $ + $logWarn $ "Since --all is used, it is redundant to specify these targets: " <> T.pack (show targetNames) + (_,_,targets) <- parseTargetsFromBuildOpts + AllowNoTargets + defaultBuildOpts + { boptsTargets = if hroptsAll opts then [] else targetNames + } + liftM concat $ forM (Map.toList targets) $ \(name, target) -> + case target of + STUnknown -> fail $ + packageNameString name ++ " isn't a known local page" + STNonLocal -> fail $ + "Expected a local package, but " ++ + packageNameString name ++ + " is either an extra-dep or in the snapshot." + STLocalComps comps -> do + pkgPath <- hpcPkgPath name + forM (toList comps) $ \nc -> + case nc of + CTest testName -> + liftM (pkgPath ) $ parseRelFile (T.unpack testName ++ ".tix") + _ -> fail $ + "Can't specify anything except test-suites as hpc report targets (" ++ + packageNameString name ++ + " is used with a non test-suite target)" + STLocalAll -> do + pkgPath <- hpcPkgPath name + exists <- dirExists pkgPath + if exists + then do + (_, files) <- listDirectory pkgPath + return (filter ((".tix" `isSuffixOf`) . toFilePath) files) + else return [] + tixPaths <- liftM (++ targetTixFiles) $ mapM (parseRelAsAbsFile . T.unpack) tixFiles + when (null tixPaths) $ + fail "Not generating combined report, because no targets or tix files are specified." + reportDir <- case hroptsDestDir opts of + Nothing -> liftM ( $(mkRelDir "combined/custom")) hpcReportDir + Just destDir -> do + liftIO $ D.createDirectoryIfMissing True destDir + parseRelAsAbsDir destDir + generateUnionReport "combined report" reportDir tixPaths + +generateHpcUnifiedReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) + => m () +generateHpcUnifiedReport = do + outputDir <- hpcReportDir + createTree outputDir + (dirs, _) <- listDirectory outputDir + tixFiles <- liftM (concat . concat) $ forM (filter (("combined" /=) . dirnameString) dirs) $ \dir -> do + (dirs', _) <- listDirectory dir + forM dirs' $ \dir' -> do + (_, files) <- listDirectory dir' + return (filter ((".tix" `isSuffixOf`) . toFilePath) files) + let reportDir = outputDir $(mkRelDir "combined/all") + if length tixFiles < 2 + then $logInfo $ T.concat + [ if null tixFiles then "No tix files" else "Only one tix file" + , " found in " + , T.pack (toFilePath outputDir) + , ", so not generating a unified coverage report." + ] + else generateUnionReport "unified report" reportDir tixFiles + +generateUnionReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) + => Text -> Path Abs Dir -> [Path Abs File] -> m () +generateUnionReport report reportDir tixFiles = do + (errs, tix) <- fmap (unionTixes . map removeExeModules) (mapMaybeM readTixOrLog tixFiles) + $logDebug $ "Using the following tix files: " <> T.pack (show tixFiles) + unless (null errs) $ $logWarn $ T.concat $ + "The following modules are left out of the " : report : " due to version mismatches: " : + intersperse ", " (map T.pack errs) + tixDest <- liftM (reportDir ) $ parseRelFile (dirnameString reportDir ++ ".tix") + createTree (parent tixDest) + liftIO $ writeTix (toFilePath tixDest) tix + generateHpcReportInternal tixDest reportDir report [] [] + +readTixOrLog :: (MonadLogger m, MonadIO m, MonadBaseControl IO m) => Path b File -> m (Maybe Tix) +readTixOrLog path = do + mtix <- liftIO (readTix (toFilePath path)) `catch` \(ErrorCall err) -> do + $logError $ "Error while reading tix: " <> T.pack err + return Nothing + when (isNothing mtix) $ + $logError $ "Failed to read tix file " <> T.pack (toFilePath path) + return mtix + +-- | Module names which contain '/' have a package name, and so they weren't built into the +-- executable. +removeExeModules :: Tix -> Tix +removeExeModules (Tix ms) = Tix (filter (\(TixModule name _ _ _) -> '/' `elem` name) ms) + +unionTixes :: [Tix] -> ([String], Tix) +unionTixes tixes = (Map.keys errs, Tix (Map.elems outputs)) + where + (errs, outputs) = Map.mapEither id $ Map.unionsWith merge $ map toMap tixes + toMap (Tix ms) = Map.fromList (map (\x@(TixModule k _ _ _) -> (k, Right x)) ms) + merge (Right (TixModule k hash1 len1 tix1)) + (Right (TixModule _ hash2 len2 tix2)) + | hash1 == hash2 && len1 == len2 = Right (TixModule k hash1 len1 (zipWith (+) tix1 tix2)) + merge _ _ = Left () + +generateHpcMarkupIndex :: (MonadIO m,MonadReader env m,MonadLogger m,MonadCatch m,HasEnvConfig env) + => m () +generateHpcMarkupIndex = do + outputDir <- hpcReportDir + let outputFile = outputDir $(mkRelFile "index.html") + createTree outputDir + (dirs, _) <- listDirectory outputDir + rows <- liftM (catMaybes . concat) $ forM dirs $ \dir -> do + (subdirs, _) <- listDirectory dir + forM subdirs $ \subdir -> do + let indexPath = subdir $(mkRelFile "hpc_index.html") + exists' <- fileExists indexPath + if not exists' then return Nothing else do + relPath <- stripDir outputDir indexPath + let package = dirname dir + testsuite = dirname subdir + return $ Just $ T.concat + [ "" + , pathToHtml package + , "" + , pathToHtml testsuite + , "" + ] + liftIO $ T.writeFile (toFilePath outputFile) $ T.concat $ + [ "" + -- Part of the css from HPC's output HTML + , "" + , "" + , "" + ] ++ + (if null rows + then + [ "No hpc_index.html files found in \"" + , pathToHtml outputDir + , "\"." + ] + else + [ "" + , "

NOTE: This is merely a listing of the html files found in the coverage reports directory. Some of these reports may be old.

" + , "" + ] ++ + rows ++ + ["
PackageTestSuiteModification Time
"]) ++ + [""] + unless (null rows) $ + $logInfo $ "\nAn index of the generated HTML coverage reports is available at " <> + T.pack (toFilePath outputFile) + +generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Text -> m () +generateHpcErrorReport dir err = do + createTree dir + liftIO $ T.writeFile (toFilePath (dir $(mkRelFile "hpc_index.html"))) $ T.concat + [ "" + , "

HPC Report Generation Error

" + , "

" + , err + , "

" + , "" + ] + +pathToHtml :: Path b t -> Text +pathToHtml = T.dropWhileEnd (=='/') . sanitize . toFilePath + +sanitize :: String -> Text +sanitize = LT.toStrict . htmlEscape . LT.pack + +dirnameString :: Path r Dir -> String +dirnameString = dropWhileEnd isPathSeparator . toFilePath . dirname + +findPackageKeyForBuiltPackage :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env) + => Path Abs Dir -> PackageIdentifier -> m (Maybe Text) +findPackageKeyForBuiltPackage pkgDir pkgId = do + distDir <- distDirFromDir pkgDir + path <- liftM (distDir ) $ + parseRelFile ("package.conf.inplace/" ++ packageIdentifierString pkgId ++ "-inplace.conf") + contents <- liftIO $ T.readFile (toFilePath path) + return $ asum (map (T.stripPrefix "key: ") (T.lines contents)) diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -10,7 +10,7 @@ ,dockerCleanupCmdName ,dockerCmdName ,dockerPullCmdName - ,execWithOptionalContainer + ,entrypoint ,preventInContainer ,pull ,reexecWithOptionalContainer @@ -19,12 +19,13 @@ ) where import Control.Applicative +import Control.Concurrent.MVar.Lifted (MVar,modifyMVar_,newMVar) import Control.Exception.Lifted import Control.Monad import Control.Monad.Catch (MonadThrow,throwM,MonadCatch,MonadMask) import Control.Monad.IO.Class (MonadIO,liftIO) import Control.Monad.Logger (MonadLogger,logError,logInfo,logWarn) -import Control.Monad.Reader (MonadReader,asks) +import Control.Monad.Reader (MonadReader,asks,runReaderT) import Control.Monad.Writer (execWriter,runWriter,tell) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode) @@ -33,11 +34,12 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char (isSpace,toUpper,isAscii,isDigit) import Data.Conduit.List (sinkNull) -import Data.List (dropWhileEnd,intercalate,intersperse,isPrefixOf,isInfixOf,foldl',sortBy) -import Data.List.Extra (trim) +import Data.List (dropWhileEnd,intercalate,isPrefixOf,isInfixOf,foldl') +import Data.List.Extra (trim,nubOrd) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe +import Data.Ord (Down(..)) import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import Data.Text (Text) import qualified Data.Text as T @@ -45,23 +47,29 @@ import Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..)) import Data.Typeable (Typeable) import Data.Version (showVersion) -import Distribution.System (Platform (Platform), Arch (X86_64), OS (Linux)) +import Distribution.System (Platform (Platform),Arch (X86_64),OS (Linux)) import Distribution.Text (display) +import GHC.Exts (sortWith) import Network.HTTP.Client.Conduit (HasHttpManager) import Path -import Path.IO (getWorkingDir,listDirectory,createTree,removeFile,removeTree,dirExists) +import Path.Extra (toFilePathNoTrailingSep) +import Path.IO import qualified Paths_stack as Meta import Prelude -- Fix redundant import warnings -import Stack.Constants (projectDockerSandboxDir,stackProgName,stackRootEnvVar) +import Stack.Constants (projectDockerSandboxDir,stackProgName,stackRootEnvVar,buildPlanDir) import Stack.Docker.GlobalDB import Stack.Types import Stack.Types.Internal import Stack.Setup (ensureDockerStackExe) -import System.Directory (canonicalizePath, getModificationTime) -import System.Environment (lookupEnv,getProgName, getArgs,getExecutablePath) +import System.Directory (canonicalizePath,getModificationTime) +import System.Environment (getEnv,getProgName,getArgs,getExecutablePath,lookupEnv) import System.Exit (exitSuccess, exitWith) -import System.FilePath (dropTrailingPathSeparator,takeBaseName) +import qualified System.FilePath as FP +import qualified System.FilePath.Posix as Posix import System.IO (stderr,stdin,stdout,hIsTerminalDevice) +import System.IO.Error (isDoesNotExistError) +import System.IO.Unsafe (unsafePerformIO) +import qualified System.PosixCompat.User as User import System.Process.PagerEditor (editByteString) import System.Process.Read import System.Process.Run @@ -91,24 +99,31 @@ reexecWithOptionalContainer mprojectRoot = execWithOptionalContainer mprojectRoot getCmdArgs where - getCmdArgs envOverride imageInfo = do + getCmdArgs docker envOverride imageInfo isRemoteDocker = do config <- asks getConfig + deUidGid <- + if fromMaybe (not isRemoteDocker) (dockerSetUser docker) + then liftIO $ Just <$> + ((,) <$> User.getEffectiveUserID <*> User.getEffectiveGroupID) + else return Nothing args <- fmap - (("--" ++ reExecArgName ++ "=" ++ showVersion Meta.version) :) + (["--" ++ reExecArgName ++ "=" ++ showVersion Meta.version + ,"--" ++ dockerEntrypointArgName + ,show DockerEntrypoint{..}] ++) (liftIO getArgs) case dockerStackExe (configDocker config) of Just DockerStackExeHost - | configPlatform config == dockerContainerPlatform -> - fmap (cmdArgs args) (liftIO getExecutablePath) + | configPlatform config == dockerContainerPlatform -> do + exePath <- liftIO getExecutablePath + cmdArgs args exePath | otherwise -> throwM UnsupportedStackExeHostPlatformException Just DockerStackExeImage -> do progName <- liftIO getProgName - return (takeBaseName progName, args, [], []) - Just (DockerStackExePath path) -> - fmap - (cmdArgs args) - (liftIO $ canonicalizePath (toFilePath path)) + return (FP.takeBaseName progName, args, [], []) + Just (DockerStackExePath path) -> do + exePath <- liftIO $ canonicalizePath (toFilePath path) + cmdArgs args exePath Just DockerStackExeDownload -> exeDownload args Nothing | configPlatform config == dockerContainerPlatform -> do @@ -125,10 +140,8 @@ exeTimestamp return (exePath, exeTimestamp, isKnown) case misCompatible of - Just True -> do - return (cmdArgs args exePath) - Just False -> do - exeDownload args + Just True -> cmdArgs args exePath + Just False -> exeDownload args Nothing -> do e <- try $ @@ -157,18 +170,15 @@ exeTimestamp compatible if compatible - then return (cmdArgs args exePath) + then cmdArgs args exePath else exeDownload args - Nothing - | otherwise -> do - exeDownload args - exeDownload args = - fmap - (cmdArgs args . toFilePath) - (ensureDockerStackExe dockerContainerPlatform) - cmdArgs args exePath = - let mountPath = concat ["/opt/host/bin/", takeBaseName exePath] - in (mountPath, args, [], [Mount exePath mountPath]) + Nothing -> exeDownload args + exeDownload args = do + exePath <- ensureDockerStackExe dockerContainerPlatform + cmdArgs args (toFilePath exePath) + cmdArgs args exePath = do + let mountPath = hostBinDir FP. FP.takeBaseName exePath + return (mountPath, args, [], [Mount exePath mountPath]) -- | If Docker is enabled, re-runs the OS command returned by the second argument in a -- Docker container. Otherwise, runs the inner action. @@ -177,7 +187,7 @@ execWithOptionalContainer :: M env m => Maybe (Path Abs Dir) - -> (EnvOverride -> Inspect -> m (FilePath,[String],[(String,String)],[Mount])) + -> GetCmdArgs env m -> Maybe (m ()) -> IO () -> Maybe (m ()) @@ -222,7 +232,7 @@ -- | Run a command in a new Docker container, then exit the process. runContainerAndExit :: M env m - => (EnvOverride -> Inspect -> m (FilePath,[String],[(String,String)],[Mount])) + => GetCmdArgs env m -> Maybe (Path Abs Dir) -> m () -> m () @@ -234,33 +244,23 @@ do config <- asks getConfig let docker = configDocker config envOverride <- getEnvOverride (configPlatform config) - checkDockerVersion envOverride + checkDockerVersion envOverride docker (dockerHost,dockerCertPath,bamboo,jenkins) <- liftIO ((,,,) <$> lookupEnv "DOCKER_HOST" <*> lookupEnv "DOCKER_CERT_PATH" <*> lookupEnv "bamboo_buildKey" <*> lookupEnv "JENKINS_HOME") let isRemoteDocker = maybe False (isPrefixOf "tcp://") dockerHost - userEnvVars <- - if fromMaybe (not isRemoteDocker) (dockerSetUser docker) - then do - uidOut <- readProcessStdout Nothing envOverride "id" ["-u"] - gidOut <- readProcessStdout Nothing envOverride "id" ["-g"] - return - [ "-e","WORK_UID=" ++ dropWhileEnd isSpace (decodeUtf8 uidOut) - , "-e","WORK_GID=" ++ dropWhileEnd isSpace (decodeUtf8 gidOut) ] - else return [] isStdoutTerminal <- asks getTerminal (isStdinTerminal,isStderrTerminal) <- liftIO ((,) <$> hIsTerminalDevice stdin <*> hIsTerminalDevice stderr) - pwd <- getWorkingDir when (isRemoteDocker && maybe False (isInfixOf "boot2docker") dockerCertPath) ($logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.") let image = dockerImage docker maybeImageInfo <- inspect envOverride image - imageInfo <- case maybeImageInfo of + imageInfo@Inspect{..} <- case maybeImageInfo of Just ii -> return ii Nothing | dockerAutoPull docker -> @@ -270,9 +270,10 @@ Just ii2 -> return ii2 Nothing -> throwM (InspectFailedException image) | otherwise -> throwM (NotPulledException image) - (cmnd,args,envVars,extraMount) <- getCmdArgs envOverride imageInfo - let imageEnvVars = map (break (== '=')) (icEnv (iiConfig imageInfo)) - sandboxID = fromMaybe "default" (lookupImageEnv sandboxIDEnvVar imageEnvVars) + let ImageConfig {..} = iiConfig + imageEnvVars = map (break (== '=')) icEnv + msandboxID = lookupImageEnv sandboxIDEnvVar imageEnvVars + sandboxID = fromMaybe "default" msandboxID sandboxIDDir <- parseRelDir (sandboxID ++ "/") let stackRoot = configStackRoot config sandboxDir = projectDockerSandboxDir projectRoot @@ -288,31 +289,41 @@ keepStdinOpen = not (dockerDetach docker) && -- Workaround for https://github.com/docker/docker/issues/12319 (isTerm || (isNothing bamboo && isNothing jenkins)) + newPathEnv = intercalate [Posix.searchPathSeparator] $ + nubOrd $ + [toFilePathNoTrailingSep $ sandboxRepoDir $(mkRelDir ".local/bin") + ,toFilePathNoTrailingSep $ sandboxRepoDir $(mkRelDir ".cabal/bin") + ,toFilePathNoTrailingSep $ sandboxRepoDir $(mkRelDir "bin") + ,hostBinDir] ++ + maybe [] Posix.splitSearchPath (lookupImageEnv "PATH" imageEnvVars) + (cmnd,args,envVars,extraMount) <- getCmdArgs docker envOverride imageInfo isRemoteDocker + pwd <- getWorkingDir liftIO - (do updateDockerImageLastUsed config - (iiId imageInfo) - (toFilePath projectRoot) - + (do updateDockerImageLastUsed config iiId (toFilePath projectRoot) mapM_ createTree - (concat [[sandboxHomeDir, sandboxSandboxDir, stackRoot] ++ - sandboxSubdirs])) + ([sandboxHomeDir, sandboxSandboxDir, stackRoot] ++ + sandboxSubdirs)) containerID <- (trim . decodeUtf8) <$> readDockerProcess envOverride (concat [["create" ,"--net=host" ,"-e",inContainerEnvVar ++ "=1" - ,"-e",stackRootEnvVar ++ "=" ++ toFPNoTrailingSep stackRoot - ,"-e","WORK_WD=" ++ toFPNoTrailingSep pwd - ,"-e","WORK_HOME=" ++ toFPNoTrailingSep sandboxRepoDir - ,"-e","WORK_ROOT=" ++ toFPNoTrailingSep projectRoot - ,"-v",toFPNoTrailingSep stackRoot ++ ":" ++ toFPNoTrailingSep stackRoot - ,"-v",toFPNoTrailingSep projectRoot ++ ":" ++ toFPNoTrailingSep projectRoot - ,"-v",toFPNoTrailingSep sandboxSandboxDir ++ ":" ++ toFPNoTrailingSep sandboxDir - ,"-v",toFPNoTrailingSep sandboxHomeDir ++ ":" ++ toFPNoTrailingSep sandboxRepoDir - ,"-v",toFPNoTrailingSep stackRoot ++ ":" ++ - toFPNoTrailingSep (sandboxRepoDir $(mkRelDir ("." ++ stackProgName ++ "/")))] - ,userEnvVars + ,"-e",stackRootEnvVar ++ "=" ++ toFilePathNoTrailingSep stackRoot + ,"-e","HOME=" ++ toFilePathNoTrailingSep sandboxRepoDir + ,"-e","PATH=" ++ newPathEnv + ,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ toFilePathNoTrailingSep stackRoot + ,"-v",toFilePathNoTrailingSep projectRoot ++ ":" ++ toFilePathNoTrailingSep projectRoot + ,"-v",toFilePathNoTrailingSep sandboxSandboxDir ++ ":" ++ toFilePathNoTrailingSep sandboxDir + ,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxRepoDir + ,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ + toFilePathNoTrailingSep (sandboxRepoDir $(mkRelDir ("." ++ stackProgName ++ "/"))) + ,"-w",toFilePathNoTrailingSep pwd] + -- Disable the deprecated entrypoint in FP Complete-generated images + ,["--entrypoint=/usr/bin/env" + | isJust msandboxID && + (icEntrypoint == ["/usr/local/sbin/docker-entrypoint"] || + icEntrypoint == ["/root/entrypoint.sh"])] ,concatMap (\(k,v) -> ["-e", k ++ "=" ++ v]) envVars ,concatMap sandboxSubdirArg sandboxSubdirs ,concatMap mountArg (extraMount ++ dockerMount docker) @@ -329,12 +340,12 @@ before #ifndef WINDOWS runInBase <- liftBaseWith $ \run -> return (void . run) - oldHandlers <- forM (concat [[(sigINT,sigTERM) | not keepStdinOpen] - ,[(sigTERM,sigTERM)]]) $ \(sigIn,sigOut) -> do - let sigHandler = runInBase (readProcessNull Nothing envOverride "docker" - ["kill","--signal=" ++ show sigOut,containerID]) - oldHandler <- liftIO $ installHandler sigIn (Catch sigHandler) Nothing - return (sigIn, oldHandler) + oldHandlers <- forM ([sigINT | not keepStdinOpen] ++ [sigTERM]) $ \sig -> do + let sigHandler = do + runInBase (readProcessNull Nothing envOverride "docker" + ["kill","--signal=" ++ show sig,containerID]) + oldHandler <- liftIO $ installHandler sig (Catch sigHandler) Nothing + return (sig, oldHandler) #endif e <- try (callProcess' (if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False })) @@ -361,8 +372,7 @@ Just ('=':val) -> Just val _ -> Nothing mountArg (Mount host container) = ["-v",host ++ ":" ++ container] - sandboxSubdirArg subdir = ["-v",toFPNoTrailingSep subdir++ ":" ++ toFPNoTrailingSep subdir] - toFPNoTrailingSep = dropTrailingPathSeparator . toFilePath + sandboxSubdirArg subdir = ["-v",toFilePathNoTrailingSep subdir++ ":" ++ toFilePathNoTrailingSep subdir] projectRoot = fromMaybeProjectRoot mprojectRoot -- | Clean-up old docker images and containers. @@ -370,8 +380,9 @@ => CleanupOpts -> m () cleanup opts = do config <- asks getConfig + let docker = configDocker config envOverride <- getEnvOverride (configPlatform config) - checkDockerVersion envOverride + checkDockerVersion envOverride docker let runDocker = readDockerProcess envOverride imagesOut <- runDocker ["images","--no-trunc","-f","dangling=false"] danglingImagesOut <- runDocker ["images","--no-trunc","-f","dangling=true"] @@ -433,7 +444,7 @@ | otherwise -> throwM (InvalidCleanupCommandException line) e <- try (readDockerProcess envOverride args) case e of - Left (ReadProcessException _ _ _ _) -> + Left (ReadProcessException{}) -> $logError (concatT ["Could not remove: '",v,"'"]) Left e' -> throwM e' Right _ -> return () @@ -513,17 +524,17 @@ case accessor opts of Just days -> buildStrLn ("# - " ++ description ++ " at least " ++ showDays days ++ ".") Nothing -> return () - sortCreated l = - reverse (sortBy (\(_,_,a) (_,_,b) -> compare a b) - (catMaybes (map (\(h,r) -> fmap (\ii -> (h,r,iiCreated ii)) - (Map.lookup h inspectMap)) - l))) + sortCreated = + sortWith (\(_,_,x) -> Down x) . + (mapMaybe (\(h,r) -> + case Map.lookup h inspectMap of + Nothing -> Nothing + Just ii -> Just (h,r,iiCreated ii))) buildSection sectionHead items itemBuilder = do let (anyWrote,b) = runWriter (forM items itemBuilder) - if or anyWrote - then do buildSectionHead sectionHead - tell b - else return () + when (or anyWrote) $ + do buildSectionHead sectionHead + tell b buildKnownImage (imageHash,lastUsedProjects) = case Map.lookup imageHash imageRepos of Just repos@(_:_) -> @@ -545,7 +556,7 @@ buildInspect hash return True buildContainer removeAge (hash,(image,name),created) = - do let disp = (name ++ " (image: " ++ image ++ ")") + do let disp = name ++ " (image: " ++ image ++ ")" buildTime containerStr removeAge created disp buildInspect hash return True @@ -614,7 +625,7 @@ case eitherDecode (LBS.pack (filter isAscii (decodeUtf8 inspectOut))) of Left msg -> throwM (InvalidInspectOutputException msg) Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results)) - Left (ReadProcessException _ _ _ _) -> return Map.empty + Left (ReadProcessException{}) -> return Map.empty Left e -> throwM e -- | Pull latest version of configured Docker image from registry. @@ -623,7 +634,7 @@ do config <- asks getConfig let docker = configDocker config envOverride <- getEnvOverride (configPlatform config) - checkDockerVersion envOverride + checkDockerVersion envOverride docker pullImage envOverride docker (dockerImage docker) -- | Pull Docker image from registry. @@ -650,8 +661,8 @@ -- | Check docker version (throws exception if incorrect) checkDockerVersion :: (MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => EnvOverride -> m () -checkDockerVersion envOverride = + => EnvOverride -> DockerOpts -> m () +checkDockerVersion envOverride docker = do dockerExists <- doesExecutableExist envOverride "docker" unless dockerExists (throwM DockerNotInstalledException) dockerVersionOut <- readDockerProcess envOverride ["--version"] @@ -663,12 +674,14 @@ throwM (DockerTooOldException minimumDockerVersion v') | v' `elem` prohibitedDockerVersions -> throwM (DockerVersionProhibitedException prohibitedDockerVersions v') + | not (v' `withinRange` dockerRequireDockerVersion docker) -> + throwM (BadDockerVersionException (dockerRequireDockerVersion docker) v') | otherwise -> return () _ -> throwM InvalidVersionOutputException _ -> throwM InvalidVersionOutputException - where minimumDockerVersion = $(mkVersion "1.3.0") - prohibitedDockerVersions = [$(mkVersion "1.2.0")] + where minimumDockerVersion = $(mkVersion "1.6.0") + prohibitedDockerVersions = [] -- | Remove the project's Docker sandbox. reset :: (MonadIO m) => Maybe (Path Abs Dir) -> Bool -> m () @@ -679,6 +692,94 @@ []) where projectRoot = fromMaybeProjectRoot maybeProjectRoot +-- | The Docker container "entrypoint": special actions performed when first entering +-- a container, such as switching the UID/GID to the "outside-Docker" user's. +entrypoint :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m) + => Config -> DockerEntrypoint -> m () +entrypoint config@Config{..} DockerEntrypoint{..} = do + modifyMVar_ entrypointMVar $ \alreadyRan -> do + -- Only run the entrypoint once + unless alreadyRan $ do + envOverride <- getEnvOverride configPlatform + homeDir <- parseAbsDir =<< liftIO (getEnv "HOME") + -- Get the UserEntry for the 'stack' user in the image, if it exists + estackUserEntry0 <- liftIO $ tryJust (guard . isDoesNotExistError) $ + User.getUserEntryForName stackUserName + -- Switch UID/GID if needed, and update user's home directory + case deUidGid of + Nothing -> return () + Just (0,_) -> return () + Just (uid,gid) -> updateOrCreateStackUser envOverride estackUserEntry0 homeDir uid gid + case estackUserEntry0 of + Left _ -> return () + Right ue -> do + -- If the 'stack' user exists in the image, copy any build plans and package indices from + -- its original home directory to the host's stack root, to avoid needing to download them + origStackHomeDir <- parseAbsDir (User.homeDirectory ue) + let origStackRoot = origStackHomeDir $(mkRelDir ("." ++ stackProgName)) + buildPlanDirExists <- dirExists (buildPlanDir origStackRoot) + when buildPlanDirExists $ do + (_, buildPlans) <- listDirectory (buildPlanDir origStackRoot) + forM_ buildPlans $ \srcBuildPlan -> do + let destBuildPlan = buildPlanDir configStackRoot filename srcBuildPlan + exists <- fileExists destBuildPlan + unless exists $ do + createTree (parent destBuildPlan) + copyFile srcBuildPlan destBuildPlan + forM_ configPackageIndices $ \pkgIdx -> do + msrcIndex <- flip runReaderT (config{configStackRoot = origStackRoot}) $ do + srcIndex <- configPackageIndex (indexName pkgIdx) + exists <- fileExists srcIndex + return $ if exists + then Just srcIndex + else Nothing + case msrcIndex of + Nothing -> return () + Just srcIndex -> do + flip runReaderT config $ do + destIndex <- configPackageIndex (indexName pkgIdx) + exists <- fileExists destIndex + unless exists $ do + createTree (parent destIndex) + copyFile srcIndex destIndex + return True + where + updateOrCreateStackUser envOverride estackUserEntry homeDir uid gid = do + case estackUserEntry of + Left _ -> do + -- If no 'stack' user in image, create one with correct UID/GID and home directory + readProcessNull Nothing envOverride "groupadd" + ["-o" + ,"--gid",show gid + ,stackUserName] + readProcessNull Nothing envOverride "useradd" + ["-oN" + ,"--uid",show uid + ,"--gid",show gid + ,"--home",toFilePathNoTrailingSep homeDir + ,stackUserName] + Right _ -> do + -- If there is already a 'stack' user in thr image, adjust its UID/GID and home directory + readProcessNull Nothing envOverride "usermod" + ["-o" + ,"--uid",show uid + ,"--home",toFilePathNoTrailingSep homeDir + ,stackUserName] + readProcessNull Nothing envOverride "groupmod" + ["-o" + ,"--gid",show gid + ,stackUserName] + -- 'setuid' to the wanted UID and GID + liftIO $ do + User.setGroupID gid + User.setUserID uid + stackUserName = "stack"::String + +-- | MVar used to ensure the Docker entrypoint is performed exactly once +entrypointMVar :: MVar Bool +{-# NOINLINE entrypointMVar #-} +entrypointMVar = unsafePerformIO (newMVar False) + -- | Remove the contents of a directory, without removing the directory itself. -- This is used instead of 'FS.removeTree' to clear bind-mounted directories, since -- removing the root of the bind-mount won't work. @@ -703,8 +804,7 @@ readDockerProcess :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> [String] -> m BS.ByteString -readDockerProcess envOverride args = - readProcessStdout Nothing envOverride "docker" args +readDockerProcess envOverride = readProcessStdout Nothing envOverride "docker" -- | Subdirectories of the home directory to sandbox between GHC/Stackage versions. sandboxedHomeSubdirectories :: [Path Rel Dir] @@ -717,9 +817,13 @@ homeDirName :: Path Rel Dir homeDirName = $(mkRelDir "_home/") +-- | Directory where 'stack' executable is bind-mounted in Docker container +hostBinDir :: FilePath +hostBinDir = "/opt/host/bin" + -- | Convenience function to decode ByteString to String. decodeUtf8 :: BS.ByteString -> String -decodeUtf8 bs = T.unpack (T.decodeUtf8 (bs)) +decodeUtf8 bs = T.unpack (T.decodeUtf8 bs) -- | Convenience function constructing message for @$log*@. concatT :: [String] -> Text @@ -735,7 +839,7 @@ -- | Environment variable used to indicate stack is running in container. inContainerEnvVar :: String -inContainerEnvVar = concat [map toUpper stackProgName,"_IN_CONTAINER"] +inContainerEnvVar = fmap toUpper stackProgName ++ "_IN_CONTAINER" -- | Command-line argument for "docker" dockerCmdName :: String @@ -749,10 +853,14 @@ dockerCleanupCmdName :: String dockerCleanupCmdName = "cleanup" --- | Command-line option for @--internal-re-exec@. +-- | Command-line option for @--internal-re-exec-version@. reExecArgName :: String reExecArgName = "internal-re-exec-version" +-- | Platform that Docker containers run +dockerContainerPlatform :: Platform +dockerContainerPlatform = Platform X86_64 Linux + -- | Options for 'cleanup'. data CleanupOpts = CleanupOpts { dcAction :: !CleanupAction @@ -774,28 +882,31 @@ {iiConfig :: ImageConfig ,iiCreated :: UTCTime ,iiId :: String - ,iiVirtualSize :: Maybe Integer } + ,iiVirtualSize :: Maybe Integer} deriving (Show) -- | Parse @docker inspect@ output. instance FromJSON Inspect where parseJSON v = do o <- parseJSON v - (Inspect <$> o .: T.pack "Config" - <*> o .: T.pack "Created" - <*> o .: T.pack "Id" - <*> o .:? T.pack "VirtualSize") + Inspect <$> o .: "Config" + <*> o .: "Created" + <*> o .: "Id" + <*> o .:? "VirtualSize" -- | Parsed @Config@ section of @docker inspect@ output. data ImageConfig = ImageConfig - {icEnv :: [String]} + {icEnv :: [String] + ,icEntrypoint :: [String]} deriving (Show) -- | Parse @Config@ section of @docker inspect@ output. instance FromJSON ImageConfig where parseJSON v = do o <- parseJSON v - (ImageConfig <$> o .:? T.pack "Env" .!= []) + ImageConfig + <$> o .:? "Env" .!= [] + <*> o .:? "Entrypoint" .!= [] -- | Exceptions thrown by Stack.Docker. data StackDockerException @@ -821,6 +932,8 @@ -- ^ Installed version of @docker@ below minimum version. | DockerVersionProhibitedException [Version] Version -- ^ Installed version of @docker@ is prohibited. + | BadDockerVersionException VersionRange Version + -- ^ Installed version of @docker@ is out of range specified in config file. | InvalidVersionOutputException -- ^ Invalid output from @docker --version@. | HostStackTooOldException Version (Maybe Version) @@ -841,7 +954,7 @@ -- | Show instance for StackDockerException. instance Show StackDockerException where show DockerMustBeEnabledException = - concat ["Docker must be enabled in your configuration file to use this command."] + "Docker must be enabled in your configuration file to use this command." show OnlyOnHostException = "This command must be run on host OS (not in a Docker container)." show (InspectFailedException image) = @@ -869,15 +982,26 @@ show (DockerTooOldException minVersion haveVersion) = concat ["Minimum docker version '" ,versionString minVersion - ,"' is required (you have '" + ,"' is required by " + ,stackProgName + ," (you have '" ,versionString haveVersion ,"')."] show (DockerVersionProhibitedException prohibitedVersions haveVersion) = - concat ["These Docker versions are prohibited (you have '" + concat ["These Docker versions are incompatible with " + ,stackProgName + ," (you have '" ,versionString haveVersion ,"'): " - ,concat (intersperse ", " (map versionString prohibitedVersions)) + ,intercalate ", " (map versionString prohibitedVersions) ,"."] + show (BadDockerVersionException requiredRange haveVersion) = + concat ["The version of 'docker' you are using (" + ,show haveVersion + ,") is outside the required\n" + ,"version range specified in stack.yaml (" + ,T.unpack (versionRangeText requiredRange) + ,")."] show InvalidVersionOutputException = "Cannot get Docker version (invalid 'docker --version' output)." show (HostStackTooOldException minVersion (Just hostVersion)) = @@ -913,9 +1037,15 @@ , display dockerContainerPlatform , " platform" ] --- | Platform that Docker containers run -dockerContainerPlatform :: Platform -dockerContainerPlatform = Platform X86_64 Linux +-- | Function to get command and arguments to run in Docker container +type GetCmdArgs env m + = M env m + => DockerOpts + -> EnvOverride + -> Inspect + -> Bool + -> m (FilePath,[String],[(String,String)],[Mount]) + type M env m = (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadCatch m ,HasConfig env,HasTerminal env,HasReExec env,HasHttpManager env,MonadMask m) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -92,7 +92,7 @@ (_,_,locals,_,sourceMap) <- loadSourceMap NeedTargets defaultBuildOpts let graph = Map.fromList (localDependencies dotOpts locals) menv <- getMinimalEnvOverride - installedMap <- fmap thrd . fst3 <$> getInstalled menv + installedMap <- fmap snd . fst4 <$> getInstalled menv (GetInstalledOpts False False) sourceMap withLoadPackage menv (\loader -> do @@ -105,16 +105,8 @@ fmap3 :: Functor f => (d -> e) -> (a -> b -> c -> f d) -> a -> b -> c -> f e fmap3 f g a b c = f <$> g a b c - thrd :: (a,b,c) -> c - thrd (_,_,x) = x - - fst3 :: (a,b,c) -> a - fst3 (x,_,_) = x - --- Given an 'Installed' try to get the 'Version' -libVersionFromInstalled :: Installed -> Maybe Version -libVersionFromInstalled (Library (PackageIdentifier _ v) _) = Just v -libVersionFromInstalled (Executable _) = Nothing + fst4 :: (a,b,c,d) -> a + fst4 (x,_,_,_) = x listDependencies :: (HasEnvConfig env ,HasHttpManager env @@ -198,8 +190,7 @@ case Map.lookup pkgName sourceMap of Just (PSLocal lp) -> pure ((packageAllDeps &&& (Just . packageVersion)) (lpPackage lp)) Just (PSUpstream version _ flags) -> loadPackageDeps pkgName version flags - Nothing -> pure (Set.empty, do m' <- T.traverse libVersionFromInstalled installed - Map.lookup pkgName m') + Nothing -> pure (Set.empty, fmap installedVersion (Map.lookup pkgName installed)) -- | Resolve the direct (depth 0) external dependencies of the given local packages localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName,(Set PackageName,Maybe Version))] diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -38,8 +38,7 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (asks) -import Control.Monad.Reader (runReaderT) +import Control.Monad.Reader (asks, runReaderT) import Control.Monad.Trans.Control import Crypto.Hash (SHA512 (..)) import Data.ByteString (ByteString) @@ -50,7 +49,9 @@ import Data.Function (fix) import Data.IORef (newIORef, readIORef, writeIORef) -import Data.List (intercalate, intersperse) +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (maybeToList, catMaybes) @@ -78,14 +79,17 @@ SeekMode (AbsoluteSeek), hSeek, withBinaryFile) import System.PosixCompat (setFileMode) +import Text.EditDistance as ED +type PackageCaches = Map PackageIdentifier (PackageIndex, PackageCache) + data FetchException = Couldn'tReadIndexTarball FilePath Tar.FormatError | Couldn'tReadPackageTarball FilePath SomeException | UnpackDirectoryAlreadyExists (Set FilePath) | CouldNotParsePackageSelectors [String] | UnknownPackageNames (Set PackageName) - | UnknownPackageIdentifiers (Set PackageIdentifier) + | UnknownPackageIdentifiers (Set PackageIdentifier) String deriving Typeable instance Exception FetchException @@ -111,9 +115,10 @@ show (UnknownPackageNames names) = "The following packages were not found in your indices: " ++ intercalate ", " (map packageNameString $ Set.toList names) - show (UnknownPackageIdentifiers idents) = + show (UnknownPackageIdentifiers idents suggestions) = "The following package identifiers were not found in your indices: " ++ - intercalate ", " (map packageIdentifierString $ Set.toList idents) + intercalate ", " (map packageIdentifierString $ Set.toList idents) ++ + (if null suggestions then "" else "\n" ++ suggestions) -- | Fetch packages into the cache without unpacking fetchPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m, MonadCatch m) @@ -193,14 +198,11 @@ go >>= either throwM return Right x -> return x where - go = do - (missingNames, missingIdents, idents) <- resolvePackagesAllowMissing menv idents0 names0 - return $ - case () of - () - | not $ Set.null missingNames -> Left $ UnknownPackageNames missingNames - | not $ Set.null missingIdents -> Left $ UnknownPackageIdentifiers missingIdents - | otherwise -> Right idents + go = r <$> resolvePackagesAllowMissing menv idents0 names0 + r (missingNames, missingIdents, idents) + | not $ Set.null missingNames = Left $ UnknownPackageNames missingNames + | not $ Set.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" + | otherwise = Right idents resolvePackagesAllowMissing :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadThrow m, MonadBaseControl IO m, MonadCatch m) @@ -289,37 +291,40 @@ -- Update the cache and try again Nothing -> do let fuzzy = fuzzyLookupCandidates ident cachesCurr - fuzzyCandidatesText = case fuzzy of - Nothing -> "" - Just cs -> "Possible candidates: " - <> commaSeparatedIdents cs - <> ". " + suggestions = case fuzzy of + Nothing -> + case typoCorrectionCandidates ident cachesCurr of + Nothing -> "" + Just cs -> "Perhaps you meant " <> + orSeparated cs <> "?" + Just cs -> "Possible candidates: " <> + commaSeparated (NE.map packageIdentifierString cs) + <> "." join $ modifyMVar updateRef $ \toUpdate -> if toUpdate then do runInBase $ do $logInfo $ T.concat [ "Didn't see " , T.pack $ packageIdentifierString ident - , " in your package indices. " - , T.pack fuzzyCandidatesText + , " in your package indices.\n" , "Updating and trying again." ] updateAllIndices menv caches <- getPackageCaches menv liftIO $ writeIORef icaches caches return (False, doLookup ident) - else return (toUpdate, throwM (unknownIdent ident)) + else return (toUpdate, + throwM $ UnknownPackageIdentifiers + (Set.singleton ident) suggestions) inner doLookup - where - unknownIdent = UnknownPackageIdentifiers . Set.singleton - commaSeparatedIdents = F.fold . intersperse ", " . map packageIdentifierString -type PackageCaches = Map PackageIdentifier (PackageIndex, PackageCache) - -lookupPackageIdentifierExact :: HasConfig env - => PackageIdentifier -> env -> PackageCaches - -> IO (Maybe ByteString) -lookupPackageIdentifierExact ident env caches = do +lookupPackageIdentifierExact + :: HasConfig env + => PackageIdentifier + -> env + -> PackageCaches + -> IO (Maybe ByteString) +lookupPackageIdentifierExact ident env caches = case Map.lookup ident caches of Nothing -> return Nothing Just (index, cache) -> do @@ -328,23 +333,36 @@ $ \_ _ bs -> return bs return $ Just bs --- TODO: use 'Maybe (NonEmpty PackageIdentifier)' return-type -fuzzyLookupCandidates :: PackageIdentifier -> PackageCaches - -> Maybe [PackageIdentifier] +-- | Given package identifier and package caches, return list of packages +-- with the same name and the same two first version number components found +-- in the caches. +fuzzyLookupCandidates + :: PackageIdentifier + -> PackageCaches + -> Maybe (NonEmpty PackageIdentifier) fuzzyLookupCandidates (PackageIdentifier name ver) caches = - if null sameMajor then Nothing else Just (map fst sameMajor) - where - sameMajor = filter (\(PackageIdentifier _ v, _) -> - toMajorVersion ver == toMajorVersion v) - sameIdentCaches - sameIdentCaches = maybe biggerFiltered - (\z -> (zeroIdent, z) : biggerFiltered) - zeroVer - biggerFiltered = takeWhile (\(PackageIdentifier n _, _) -> name == n) - (Map.toList bigger) - zeroIdent = PackageIdentifier name $(mkVersion "0.0") - (_, zeroVer, bigger) = Map.splitLookup zeroIdent caches + let (_, zero, bigger) = Map.splitLookup zeroIdent caches + zeroIdent = PackageIdentifier name $(mkVersion "0.0") + sameName (PackageIdentifier n _) = n == name + sameMajor (PackageIdentifier _ v) = toMajorVersion v == toMajorVersion ver + in NE.nonEmpty . filter sameMajor $ maybe [] (pure . const zeroIdent) zero + <> takeWhile sameName (Map.keys bigger) +-- | Try to come up with typo corrections for given package identifier using +-- package caches. This should be called before giving up, i.e. when +-- 'fuzzyLookupCandidates' cannot return anything. +typoCorrectionCandidates + :: PackageIdentifier + -> PackageCaches + -> Maybe (NonEmpty String) +typoCorrectionCandidates ident = + let getName = packageNameString . packageIdentifierName + name = getName ident + in NE.nonEmpty + . Map.keys + . Map.filterWithKey (const . (== 1) . damerauLevenshtein name) + . Map.mapKeys getName + -- | Figure out where to fetch from. getToFetch :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env) => Maybe (Path Abs Dir) -- ^ directory to unpack into, @Nothing@ means no unpack @@ -433,10 +451,10 @@ let downloadReq = DownloadRequest { drRequest = req , drHashChecks = map toHashCheck $ maybeToList (tfSHA512 toFetch) - , drLengthCheck = fmap fromIntegral $ tfSize toFetch + , drLengthCheck = fromIntegral <$> tfSize toFetch , drRetryPolicy = drRetryPolicyDefault } - let progressSink _ = do + let progressSink _ = liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": download" _ <- verifiedDownload downloadReq destpath progressSink @@ -521,3 +539,15 @@ workers 1 = Concurrently worker workers i = Concurrently worker *> workers (i - 1) liftIO $ runConcurrently $ workers cnt + +damerauLevenshtein :: String -> String -> Int +damerauLevenshtein = ED.restrictedDamerauLevenshteinDistance ED.defaultEditCosts + +orSeparated :: NonEmpty String -> String +orSeparated xs + | NE.length xs == 1 = NE.head xs + | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs + | otherwise = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs + +commaSeparated :: NonEmpty String -> String +commaSeparated = F.fold . NE.intersperse ", " diff --git a/src/Stack/FileWatch.hs b/src/Stack/FileWatch.hs --- a/src/Stack/FileWatch.hs +++ b/src/Stack/FileWatch.hs @@ -21,7 +21,6 @@ import Data.String (fromString) import Data.Traversable (forM) import GHC.IO.Handle (hIsTerminalDevice) -import Ignore import Path import System.Console.ANSI import System.Exit @@ -33,13 +32,11 @@ printExceptionStderr e = L.hPut stderr $ toLazyByteString $ fromShow e <> copyByteString "\n" -fileWatch :: IO (Path Abs Dir) - -> ((Set (Path Abs File) -> IO ()) -> IO ()) +fileWatch :: ((Set (Path Abs File) -> IO ()) -> IO ()) -> IO () fileWatch = fileWatchConf defaultConfig -fileWatchPoll :: IO (Path Abs Dir) - -> ((Set (Path Abs File) -> IO ()) -> IO ()) +fileWatchPoll :: ((Set (Path Abs File) -> IO ()) -> IO ()) -> IO () fileWatchPoll = fileWatchConf $ defaultConfig { confUsePolling = True } @@ -48,21 +45,12 @@ -- The action provided takes a callback that is used to set the files to be -- watched. When any of those files are changed, we rerun the action again. fileWatchConf :: WatchConfig - -> IO (Path Abs Dir) -> ((Set (Path Abs File) -> IO ()) -> IO ()) -> IO () -fileWatchConf cfg getProjectRoot inner = withManagerConf cfg $ \manager -> do +fileWatchConf cfg inner = withManagerConf cfg $ \manager -> do allFiles <- newTVarIO Set.empty dirtyVar <- newTVarIO True watchVar <- newTVarIO Map.empty - projRoot <- getProjectRoot - mChecker <- findIgnoreFiles [VCSGit, VCSMercurial, VCSDarcs] projRoot >>= buildChecker - (FileIgnoredChecker isFileIgnored) <- - case mChecker of - Left err -> - do putStrLn $ "Failed to parse VCS's ignore file: " ++ err - return $ FileIgnoredChecker (const False) - Right chk -> return chk let onChange event = atomically $ do files <- readTVar allFiles @@ -96,7 +84,7 @@ return Nothing startListening = Map.mapWithKey $ \dir () -> do let dir' = fromString $ toFilePath dir - listen <- watchDir manager dir' (not . isFileIgnored . eventPath) onChange + listen <- watchDir manager dir' (const True) onChange return $ Just listen let watchInput = do @@ -108,11 +96,11 @@ putStrLn "help: display this help" putStrLn "quit: exit" putStrLn "build: force a rebuild" - putStrLn "watched: display watched directories" + putStrLn "watched: display watched files" "build" -> atomically $ writeTVar dirtyVar True "watched" -> do - watch <- readTVarIO watchVar - mapM_ (putStrLn . toFilePath) (Map.keys watch) + watch <- readTVarIO allFiles + mapM_ putStrLn (Set.toList watch) "" -> atomically $ writeTVar dirtyVar True _ -> putStrLn $ concat [ "Unknown command: " diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -10,23 +10,16 @@ -- | Functions for the GHC package database. module Stack.GhcPkg - (findGhcPkgId - ,findGhcPkgKey - ,getGlobalDB + (getGlobalDB ,EnvOverride ,envHelper ,createDatabase ,unregisterGhcPkgId ,getCabalPkgVer - ,findGhcPkgHaddockHtml - ,findGhcPkgDepends - ,findTransitiveGhcPkgDepends - ,listGhcPkgDbs ,ghcPkgExeName ,mkGhcPackagePath) where -import Control.Applicative import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class @@ -35,20 +28,18 @@ import qualified Data.ByteString.Char8 as S8 import Data.Either import Data.List -import qualified Data.Map as Map import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Path (Path, Abs, Dir, toFilePath, parent, parseAbsDir) +import Path.Extra (toFilePathNoTrailingSep) import Path.IO (dirExists, createTree) import Prelude hiding (FilePath) import Stack.Constants import Stack.Types -import System.Directory (canonicalizePath, doesDirectoryExist) -import System.FilePath (FilePath, searchPathSeparator, dropTrailingPathSeparator) +import System.Directory (canonicalizePath) +import System.FilePath (searchPathSeparator) import System.Process.Read -- | Get the global package database @@ -76,12 +67,11 @@ -> m (Either ReadProcessException S8.ByteString) ghcPkg menv wc pkgDbs args = do eres <- go - r <- case eres of - Left _ -> do - mapM_ (createDatabase menv wc) pkgDbs - go - Right _ -> return eres - return r + case eres of + Left _ -> do + mapM_ (createDatabase menv wc) pkgDbs + go + Right _ -> return eres where go = tryProcessStdout Nothing menv (ghcPkgExeName wc) args' args' = packageDbFlags pkgDbs ++ args @@ -108,7 +98,7 @@ packageDbFlags :: [Path Abs Dir] -> [String] packageDbFlags pkgDbs = "--no-user-package-db" - : map (\x -> ("--package-db=" ++ toFilePath x)) pkgDbs + : map (\x -> "--package-db=" ++ toFilePath x) pkgDbs -- | Get the value of a field of the package. findGhcPkgField @@ -134,31 +124,6 @@ where stripCR t = fromMaybe t (T.stripSuffix "\r" t) --- | Get the id of the package e.g. @foo-0.0.0-9c293923c0685761dcff6f8c3ad8f8ec@. -findGhcPkgId :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) - => EnvOverride - -> WhichCompiler - -> [Path Abs Dir] -- ^ package databases - -> PackageName - -> m (Maybe GhcPkgId) -findGhcPkgId menv wc pkgDbs name = do - mpid <- findGhcPkgField menv wc pkgDbs (packageNameString name) "id" - case mpid of - Just !pid -> return (parseGhcPkgId (T.encodeUtf8 pid)) - _ -> return Nothing - --- | Get the package key e.g. @foo_9bTCpMF7G4UFWJJvtDrIdB@. --- --- NOTE: GHC > 7.10 only! Will always yield 'Nothing' otherwise. -findGhcPkgKey :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) - => EnvOverride - -> WhichCompiler - -> [Path Abs Dir] -- ^ package databases - -> PackageName - -> m (Maybe Text) -findGhcPkgKey menv wc pkgDbs name = - findGhcPkgField menv wc pkgDbs (packageNameString name) "key" - -- | Get the version of the package findGhcPkgVersion :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride @@ -172,76 +137,6 @@ Just !v -> return (parseVersion (T.encodeUtf8 v)) _ -> return Nothing --- | Get the Haddock HTML documentation path of the package. -findGhcPkgHaddockHtml :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) - => EnvOverride - -> WhichCompiler - -> [Path Abs Dir] -- ^ package databases - -> String -- ^ PackageIdentifier or GhcPkgId - -> m (Maybe (PackageIdentifier, Path Abs Dir)) -findGhcPkgHaddockHtml menv wc pkgDbs ghcPkgId = do - mpath <- findGhcPkgField menv wc pkgDbs ghcPkgId "haddock-html" - mid <- findGhcPkgField menv wc pkgDbs ghcPkgId "id" - mversion <- findGhcPkgField menv wc pkgDbs ghcPkgId "version" - let mpkgId = PackageIdentifier - <$> (mid >>= parsePackageName . T.encodeUtf8) - <*> (mversion >>= parseVersion . T.encodeUtf8) - case (,) <$> mpath <*> mpkgId of - Just (path0, pkgId) -> do - let path = T.unpack path0 - exists <- liftIO $ doesDirectoryExist path - path' <- if exists - then liftIO $ canonicalizePath path - else return path - - return $ fmap (pkgId,) (parseAbsDir path') - _ -> return Nothing - --- | Finds dependencies of package, and all their dependencies, etc. -findTransitiveGhcPkgDepends - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) - => EnvOverride - -> WhichCompiler - -> [Path Abs Dir] -- ^ package databases - -> PackageIdentifier - -> m (Set PackageIdentifier) -findTransitiveGhcPkgDepends menv wc pkgDbs pkgId0 = - liftM (Set.fromList . Map.elems) - (go (packageIdentifierString pkgId0) Map.empty) - where - go pkgId res = do - deps <- findGhcPkgDepends menv wc pkgDbs pkgId - loop deps res - loop [] res = return res - loop (dep:deps) res = do - if Map.member dep res - then loop deps res - else do - let pkgId = ghcPkgIdString dep - mname <- findGhcPkgField menv wc pkgDbs pkgId "name" - mversion <- findGhcPkgField menv wc pkgDbs pkgId "version" - let mident = do - name <- mname >>= parsePackageName . T.encodeUtf8 - version <- mversion >>= parseVersion . T.encodeUtf8 - Just $ PackageIdentifier name version - res' = maybe id (Map.insert dep) mident res - res'' <- go pkgId res' - -- FIXME is the Map.union actually necessary? - loop deps (Map.union res res'') - --- | Get the dependencies of the package. -findGhcPkgDepends :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) - => EnvOverride - -> WhichCompiler - -> [Path Abs Dir] -- ^ package databases - -> String -- ^ package identifier or GhcPkgId - -> m [GhcPkgId] -findGhcPkgDepends menv wc pkgDbs pkgId = do - mdeps <- findGhcPkgField menv wc pkgDbs pkgId "depends" - case mdeps of - Just !deps -> return (mapMaybe (parseGhcPkgId . T.encodeUtf8) (T.words deps)) - _ -> return [] - unregisterGhcPkgId :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadBaseControl IO m) => EnvOverride -> WhichCompiler @@ -274,30 +169,12 @@ cabalPackageName >>= maybe (throwM $ Couldn'tFindPkgId cabalPackageName) return -listGhcPkgDbs - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) - => EnvOverride -> WhichCompiler -> [Path Abs Dir] -> m [PackageIdentifier] -listGhcPkgDbs menv wc pkgDbs = do - result <- - ghcPkg - menv - wc - pkgDbs - ["list", "--simple-output"] - return $ - case result of - Left{} -> [] - Right lbs -> mapMaybe parsePackageIdentifier (S8.words lbs) - -- | Get the value for GHC_PACKAGE_PATH -mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> Path Abs Dir -> Text -mkGhcPackagePath locals localdb deps globaldb = +mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text +mkGhcPackagePath locals localdb deps extras globaldb = T.pack $ intercalate [searchPathSeparator] $ concat - [ [toFilePathNoTrailingSlash localdb | locals] - , [toFilePathNoTrailingSlash deps] - , [toFilePathNoTrailingSlash globaldb] + [ [toFilePathNoTrailingSep localdb | locals] + , [toFilePathNoTrailingSep deps] + , [toFilePathNoTrailingSep db | db <- reverse extras] + , [toFilePathNoTrailingSep globaldb] ] - --- TODO: dedupe with copy in Stack.Setup -toFilePathNoTrailingSlash :: Path loc Dir -> FilePath -toFilePathNoTrailingSlash = dropTrailingPathSeparator . toFilePath diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -5,20 +5,29 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} --- | Run a GHCi configured with the user's project(s). +-- | Run a GHCi configured with the user's package(s). -module Stack.Ghci (GhciOpts(..),GhciPkgInfo(..), ghciSetup, ghci) where +module Stack.Ghci + ( GhciOpts(..) + , GhciPkgInfo(..) + , ghciSetup + , ghci + ) where +import Control.Exception.Enclosed (tryAny) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Resource +import Data.Either import Data.Function import Data.List +import Data.List.Extra (nubOrd) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe +import Data.Maybe.Extra (forMaybeM) import Data.Monoid import Data.Set (Set) import qualified Data.Set as S @@ -28,6 +37,8 @@ import Distribution.Text (display) import Network.HTTP.Client.Conduit import Path +import Path.Extra (toFilePathNoTrailingSep) +import Path.IO import Prelude import Stack.Build import Stack.Build.Installed @@ -38,74 +49,112 @@ import Stack.Package import Stack.Types import Stack.Types.Internal +import System.Directory (getTemporaryDirectory) -- | Command-line options for GHC. data GhciOpts = GhciOpts - {ghciTargets :: ![Text] - ,ghciArgs :: ![String] - ,ghciGhcCommand :: !(Maybe FilePath) - ,ghciNoLoadModules :: !Bool - ,ghciAdditionalPackages :: ![String] - ,ghciMainIs :: !(Maybe Text) - } deriving (Show,Eq) + { ghciNoBuild :: !Bool + , ghciArgs :: ![String] + , ghciGhcCommand :: !(Maybe FilePath) + , ghciNoLoadModules :: !Bool + , ghciAdditionalPackages :: ![String] + , ghciMainIs :: !(Maybe Text) + , ghciBuildOpts :: !BuildOpts + } deriving Show -- | Necessary information to load a package or its components. data GhciPkgInfo = GhciPkgInfo - { ghciPkgName :: PackageName - , ghciPkgOpts :: [String] - , ghciPkgDir :: Path Abs Dir - , ghciPkgModules :: Set ModuleName - , ghciPkgModFiles :: Set (Path Abs File) -- ^ Module file paths. - , ghciPkgCFiles :: Set (Path Abs File) -- ^ C files. - , ghciPkgMainIs :: Map NamedComponent (Set (Path Abs File)) - } + { ghciPkgName :: !PackageName + , ghciPkgOpts :: ![(NamedComponent, BuildInfoOpts)] + , ghciPkgDir :: !(Path Abs Dir) + , ghciPkgModules :: !(Set ModuleName) + , ghciPkgModFiles :: !(Set (Path Abs File)) -- ^ Module file paths. + , ghciPkgCFiles :: !(Set (Path Abs File)) -- ^ C files. + , ghciPkgMainIs :: !(Map NamedComponent (Set (Path Abs File))) + , ghciPkgPackage :: !Package + } deriving Show --- | Launch a GHCi session for the given local project targets with the +-- | Launch a GHCi session for the given local package targets with the -- given options and configure it with the load paths and extensions -- of those targets. ghci :: (HasConfig r, HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m) => GhciOpts -> m () ghci GhciOpts{..} = do - (targets,mainIsTargets,pkgs) <- ghciSetup ghciMainIs ghciTargets + let bopts = ghciBuildOpts + { boptsTestOpts = (boptsTestOpts ghciBuildOpts) { toDisableRun = True } + , boptsBenchmarkOpts = (boptsBenchmarkOpts ghciBuildOpts) { beoDisableRun = True } + } + (targets,mainIsTargets,pkgs) <- ghciSetup bopts ghciNoBuild ghciMainIs + config <- asks getConfig bconfig <- asks getBuildConfig - mainFile <- figureOutMainFile mainIsTargets targets pkgs + mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs wc <- getWhichCompiler - let pkgopts = concatMap ghciPkgOpts pkgs - srcfiles - | ghciNoLoadModules = [] - | otherwise = - nub (maybe [] (return . toFilePath) mainFile <> - concatMap (map display . S.toList . ghciPkgModules) pkgs) + let pkgopts = hidePkgOpt ++ genOpts ++ ghcOpts + hidePkgOpt = if null pkgs then [] else ["-hide-all-packages"] + genOpts = nubOrd (concatMap (concatMap (bioGeneratedOpts . snd) . ghciPkgOpts) pkgs) + (omittedOpts, ghcOpts) = partition badForGhci $ + concatMap (concatMap (bioGhcOpts . snd) . ghciPkgOpts) pkgs ++ + getUserOptions Nothing ++ + concatMap (getUserOptions . Just . ghciPkgName) pkgs + getUserOptions mpkg = + map T.unpack (M.findWithDefault [] mpkg (configGhcOptions config)) + badForGhci x = + isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky -static") + unless (null omittedOpts) $ + $logWarn + ("The following GHC options are incompatible with GHCi and have not been passed to it: " <> + T.unwords (map T.pack (nubOrd omittedOpts))) + let modulesToLoad = nubOrd $ + maybe [] (return . toFilePath) mainFile <> + concatMap (map display . S.toList . ghciPkgModules) pkgs odir = - [ "-odir=" <> toFilePath (objectInterfaceDir bconfig) - , "-hidir=" <> toFilePath (objectInterfaceDir bconfig)] + [ "-odir=" <> toFilePathNoTrailingSep (objectInterfaceDir bconfig) + , "-hidir=" <> toFilePathNoTrailingSep (objectInterfaceDir bconfig)] $logInfo ("Configuring GHCi with the following packages: " <> T.intercalate ", " (map (packageNameText . ghciPkgName) pkgs)) - exec - defaultEnvSettings - (fromMaybe (compilerExeName wc) ghciGhcCommand) - ("--interactive" : odir <> pkgopts <> srcfiles <> ghciArgs) + let execGhci extras = + exec defaultEnvSettings + (fromMaybe (compilerExeName wc) ghciGhcCommand) + ("--interactive" : + -- This initial "-i" resets the include directories to not + -- include CWD. + "-i" : + odir <> pkgopts <> ghciArgs <> extras) + case ghciNoLoadModules of + True -> execGhci [] + False -> do + tmp <- liftIO getTemporaryDirectory + withCanonicalizedTempDirectory + tmp + "ghci-script" + (\tmpDir -> + do let scriptPath = tmpDir $(mkRelFile "ghci-script") + fp = toFilePath scriptPath + loadModules = ":load " <> unwords modulesToLoad + bringIntoScope = ":module + " <> unwords modulesToLoad + liftIO (writeFile fp (unlines [loadModules,bringIntoScope])) + finally (execGhci ["-ghci-script=" <> fp]) + (removeFile scriptPath)) -- | Figure out the main-is file to load based on the targets. Sometimes there -- is none, sometimes it's unambiguous, sometimes it's -- ambiguous. Warns and returns nothing if it's ambiguous. figureOutMainFile :: (Monad m, MonadLogger m) - => Maybe (Map PackageName SimpleTarget) + => BuildOpts + -> Maybe (Map PackageName SimpleTarget) -> Map PackageName SimpleTarget -> [GhciPkgInfo] -> m (Maybe (Path Abs File)) -figureOutMainFile mainIsTargets targets0 packages = do +figureOutMainFile bopts mainIsTargets targets0 packages = case candidates of [] -> return Nothing [c@(_,_,fp)] -> do $logInfo ("Using main module: " <> renderCandidate c) return (Just fp) - candidate:_ -> do - let border = $logWarn "* * * * * * * *" - border - $logWarn ("The main module to load is ambiguous. Candidates are: ") + candidate:_ -> borderedWarning $ do + $logWarn "The main module to load is ambiguous. Candidates are: " forM_ (map renderCandidate candidates) $logWarn $logWarn "None will be loaded. You can specify which one to pick by: " @@ -115,7 +164,6 @@ $logWarn (" 2) Specifying what the main is e.g. stack ghci " <> sampleMainIsArg candidate) - border return Nothing where targets = fromMaybe targets0 mainIsTargets @@ -125,15 +173,14 @@ Nothing -> [] Just target -> do (component,mains) <- - M.toList - (M.filterWithKey wantedComponent (ghciPkgMainIs pkg)) + M.toList $ + M.filterWithKey (\k _ -> k `S.member` wantedComponents) + (ghciPkgMainIs pkg) main <- S.toList mains return (ghciPkgName pkg, component, main) - where wantedComponent namedC _ = - case target of - STLocalAll -> True - STLocalComps cs -> S.member namedC cs - _ -> False + where + wantedComponents = + wantedPackageComponents bopts target (ghciPkgPackage pkg) renderCandidate (pkgName,namedComponent,mainIs) = "Package `" <> packageNameText pkgName <> "' component " <> renderComp namedComponent <> @@ -154,32 +201,22 @@ -- information to load that package/components. ghciSetup :: (HasConfig r, HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m) - => Maybe Text - -> [Text] + => BuildOpts + -> Bool + -> Maybe Text -> m (Map PackageName SimpleTarget, Maybe (Map PackageName SimpleTarget), [GhciPkgInfo]) -ghciSetup mainIs stringTargets = do - (_,_,targets) <- - parseTargetsFromBuildOpts - AllowNoTargets - defaultBuildOpts - { boptsTargets = stringTargets - } +ghciSetup bopts noBuild mainIs = do + (_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets bopts mainIsTargets <- case mainIs of Nothing -> return Nothing Just target -> do - (_,_,targets') <- - parseTargetsFromBuildOpts - AllowNoTargets - defaultBuildOpts - { boptsTargets = [target] - } + (_,_,targets') <- parseTargetsFromBuildOpts AllowNoTargets bopts { boptsTargets = [target] } return (Just targets') - let bopts = makeBuildOpts targets econfig <- asks getEnvConfig (realTargets,_,_,_,sourceMap) <- loadSourceMap AllowNoTargets bopts menv <- getMinimalEnvOverride - (installedMap, _, _) <- getInstalled + (installedMap, _, _, _) <- getInstalled menv GetInstalledOpts { getInstalledProfiling = False @@ -187,8 +224,7 @@ } sourceMap locals <- - liftM catMaybes $ - forM (M.toList (envConfigPackages econfig)) $ + forMaybeM (M.toList (envConfigPackages econfig)) $ \(dir,validWanted) -> do cabalfp <- getCabalFileName dir name <- parsePackageNameFromFilePath cabalfp @@ -198,97 +234,133 @@ return (Just (name, (cabalfp, simpleTargets))) Nothing -> return Nothing else return Nothing + -- Try to build, but optimistically launch GHCi anyway if it fails (#1065) + unless noBuild $ do + eres <- tryAny $ build (const (return ())) Nothing bopts + case eres of + Right () -> return () + Left err -> do + $logError $ T.pack (show err) + $logWarn "Warning: build failed, but optimistically launching GHCi anyway" + -- Load the list of modules _after_ building, to catch changes in unlisted dependencies (#1180) + let localLibs = [name | (name, (_, target)) <- locals, hasLocalComp isCLib target] infos <- forM locals $ - \(name,(cabalfp,components)) -> - makeGhciPkgInfo sourceMap installedMap (map fst locals) name cabalfp components - unless (M.null realTargets) (build (const (return ())) Nothing bopts) + \(name,(cabalfp,target)) -> + makeGhciPkgInfo bopts sourceMap installedMap localLibs name cabalfp target + checkForIssues infos return (realTargets, mainIsTargets, infos) where - makeBuildOpts targets = - base - { boptsTargets = stringTargets - , boptsTests = any (hasLocalComp isCTest) elems - , boptsBenchmarks = any (hasLocalComp isCBench) elems - , boptsTestOpts = (boptsTestOpts base) - { toDisableRun = True - , toRerunTests = False - } - , boptsBenchmarkOpts = (boptsBenchmarkOpts base) - { beoDisableRun = True - } - , boptsBuildSubset = BSOnlyDependencies - } - where - base = defaultBuildOpts - elems = M.elems targets - hasLocalComp p t = - case t of - STLocalComps s -> any p (S.toList s) - STLocalAll -> True - _ -> False - isCTest nc = - case nc of - CTest{} -> True - _ -> False - isCBench nc = - case nc of - CBench{} -> True - _ -> False + hasLocalComp p t = + case t of + STLocalComps s -> any p (S.toList s) + STLocalAll -> True + _ -> False -- | Make information necessary to load the given package in GHCi. makeGhciPkgInfo :: (MonadReader r m, HasEnvConfig r, MonadLogger m, MonadIO m, MonadCatch m) - => SourceMap + => BuildOpts + -> SourceMap -> InstalledMap -> [PackageName] -> PackageName -> Path Abs File -> SimpleTarget -> m GhciPkgInfo -makeGhciPkgInfo sourceMap installedMap locals name cabalfp components = do +makeGhciPkgInfo bopts sourceMap installedMap locals name cabalfp target = do econfig <- asks getEnvConfig bconfig <- asks getBuildConfig let config = PackageConfig { packageConfigEnableTests = True , packageConfigEnableBenchmarks = True - , packageConfigFlags = localFlags mempty bconfig name + , packageConfigFlags = localFlags (boptsFlags bopts) bconfig name , packageConfigCompilerVersion = envConfigCompilerVersion econfig , packageConfigPlatform = configPlatform (getConfig bconfig) } (warnings,pkg) <- readPackage config cabalfp mapM_ (printCabalFileWarning cabalfp) warnings - (componentsModules,componentFiles,componentsOpts,generalOpts) <- - getPackageOpts (packageOpts pkg) sourceMap installedMap locals cabalfp - let filterWithinWantedComponents m = - M.elems - (M.filterWithKey - (\k _ -> - case components of - STLocalComps cs -> S.member k cs - _ -> True) - m) + (mods,files,opts) <- getPackageOpts (packageOpts pkg) sourceMap installedMap locals cabalfp + let filteredOpts = filterWanted opts + filterWanted = M.filterWithKey (\k _ -> k `S.member` allWanted) + allWanted = wantedPackageComponents bopts target pkg + setMapMaybe f = S.fromList . mapMaybe f . S.toList return GhciPkgInfo { ghciPkgName = packageName pkg - , ghciPkgOpts = filter - (not . badForGhci) - (generalOpts <> - concat (filterWithinWantedComponents componentsOpts)) + , ghciPkgOpts = M.toList filteredOpts , ghciPkgDir = parent cabalfp - , ghciPkgModules = mconcat - (filterWithinWantedComponents componentsModules) - , ghciPkgModFiles = mconcat - (filterWithinWantedComponents - (M.map (setMapMaybe dotCabalModulePath) componentFiles)) - , ghciPkgMainIs = M.map (setMapMaybe dotCabalMainPath) componentFiles - , ghciPkgCFiles = mconcat - (filterWithinWantedComponents - (M.map (setMapMaybe dotCabalCFilePath) componentFiles)) + , ghciPkgModules = mconcat (M.elems (filterWanted mods)) + , ghciPkgModFiles = mconcat (M.elems (filterWanted (M.map (setMapMaybe dotCabalModulePath) files))) + , ghciPkgMainIs = M.map (setMapMaybe dotCabalMainPath) files + , ghciPkgCFiles = mconcat (M.elems (filterWanted (M.map (setMapMaybe dotCabalCFilePath) files))) + , ghciPkgPackage = pkg } + +-- NOTE: this should make the same choices as the components code in +-- 'loadLocalPackage'. Unfortunately for now we reiterate this logic +-- (differently). +wantedPackageComponents :: BuildOpts -> SimpleTarget -> Package -> Set NamedComponent +wantedPackageComponents _ (STLocalComps cs) _ = cs +wantedPackageComponents bopts STLocalAll pkg = S.fromList $ + (if packageHasLibrary pkg then [CLib] else []) ++ + map CExe (S.toList (packageExes pkg)) <> + (if boptsTests bopts then map CTest (S.toList (packageTests pkg)) else []) <> + (if boptsBenchmarks bopts then map CBench (S.toList (packageBenchmarks pkg)) else []) +wantedPackageComponents _ _ _ = S.empty + +checkForIssues :: (MonadThrow m, MonadLogger m) => [GhciPkgInfo] -> m () +checkForIssues pkgs = do + unless (null issues) $ borderedWarning $ do + $logWarn "There are issues with this project which may prevent GHCi from working properly." + $logWarn "" + mapM_ $logWarn $ intercalate [""] issues + $logWarn "" + $logWarn "To resolve, remove the flag(s) from the cabal file(s) and instead put them at the top of the haskell files." + $logWarn "" + $logWarn "It isn't yet possible to load multiple packages into GHCi in all cases - see" + $logWarn "https://ghc.haskell.org/trac/ghc/ticket/10827" where - badForGhci :: String -> Bool - badForGhci x = - isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky") - setMapMaybe f = S.fromList . mapMaybe f . S.toList + issues = concat + [ mixedFlag "-XNoImplicitPrelude" + [ "-XNoImplicitPrelude will be used, but GHCi will likely fail to build things which depend on the implicit prelude." ] + , mixedFlag "-XCPP" + [ "-XCPP will be used, but it can cause issues with multiline strings." + , "See https://downloads.haskell.org/~ghc/7.10.2/docs/html/users_guide/options-phases.html#cpp-string-gaps" + ] + , mixedFlag "-XNoTraditionalRecordSyntax" + [ "-XNoTraditionalRecordSyntax will be used, but it break modules which use record syntax." ] + , mixedFlag "-XTemplateHaskell" + [ "-XTemplateHaskell will be used, but it may cause compilation issues due to different parsing of ($)." ] + , mixedFlag "-XSafe" + [ "-XSafe will be used, but it will fail to compile unsafe modules." ] + ] + mixedFlag flag msgs = + let x = partitionComps (== flag) in + [ msgs ++ showWhich x | mixedSettings x ] + mixedSettings (xs, ys) = xs /= [] && ys /= [] + showWhich (haveIt, don'tHaveIt) = + [ "It is specified for:" + , " " <> renderPkgComponents haveIt + , "But not for: " + , " " <> renderPkgComponents don'tHaveIt + ] + partitionComps f = (map fst xs, map fst ys) + where + (xs, ys) = partition (any f . snd) compsWithOpts + compsWithOpts = map (\(k, bio) -> (k, bioGeneratedOpts bio ++ bioGhcOpts bio)) compsWithBios + compsWithBios = + [ ((ghciPkgName pkg, c), bio) + | pkg <- pkgs + , (c, bio) <- ghciPkgOpts pkg + ] + +borderedWarning :: MonadLogger m => m a -> m a +borderedWarning f = do + $logWarn "" + $logWarn "* * * * * * * *" + x <- f + $logWarn "* * * * * * * *" + $logWarn "" + return x diff --git a/src/Stack/Ide.hs b/src/Stack/Ide.hs --- a/src/Stack/Ide.hs +++ b/src/Stack/Ide.hs @@ -1,12 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} --- | Run a IDE configured with the user's project(s). +-- | Run a IDE configured with the user's package(s). module Stack.Ide (ide, getPackageOptsAndTargetFiles) @@ -25,6 +24,7 @@ import Distribution.System import Network.HTTP.Client.Conduit import Path +import Path.Extra (toFilePathNoTrailingSep) import Path.IO import Stack.Constants import Stack.Ghci (GhciPkgInfo(..), ghciSetup) @@ -32,6 +32,7 @@ import Stack.Types import Stack.Types.Internal import System.Environment (lookupEnv) +import System.FilePath (searchPathSeparator) import System.Process.Run -- | Launch a GHCi IDE for the given local project targets with the @@ -43,7 +44,11 @@ -> [String] -- ^ GHC options. -> m () ide targets useropts = do - (_realTargets,_,pkgs) <- ghciSetup Nothing targets + let bopts = defaultBuildOpts + { boptsTargets = targets + , boptsBuildSubset = BSOnlyDependencies + } + (_realTargets,_,pkgs) <- ghciSetup bopts False Nothing pwd <- getWorkingDir (pkgopts,_srcfiles) <- liftM mconcat $ forM pkgs $ getPackageOptsAndTargetFiles pwd @@ -52,14 +57,14 @@ mpath <- liftIO $ lookupEnv "PATH" bindirs <- extraBinDirs `ap` return True {- include local bin -} let pkgdbs = - ["--package-db=" <> toFilePath depsdb <> ":" <> toFilePath localdb] + ["--package-db=" <> toFilePathNoTrailingSep depsdb <> [searchPathSeparator] <> toFilePathNoTrailingSep localdb] paths = [ "--ide-backend-tools-path=" <> - intercalate ":" (map toFilePath bindirs) <> - (maybe "" (':' :) mpath)] + intercalate [searchPathSeparator] (map toFilePath bindirs) <> + maybe "" (searchPathSeparator :) mpath] args = ["--verbose"] <> ["--include=" <> includeDirs pkgopts] <> - ["--local-work-dir=" ++ toFilePath pwd] <> + ["--local-work-dir=" ++ toFilePathNoTrailingSep pwd] <> map ("--ghc-option=" ++) useropts <> paths <> pkgopts <> @@ -69,12 +74,12 @@ when (os == OSX) (catch (callProcess (Just pwd) menv "stty" ["cbreak", "-imaxbel"]) - (\(_ :: ProcessExitedUnsuccessfully) -> undefined)) + (\(_ :: ProcessExitedUnsuccessfully) -> return ())) callProcess (Just pwd) menv "stack-ide" args where includeDirs pkgopts = intercalate - ":" + [searchPathSeparator] (mapMaybe (stripPrefix "--ghc-option=-i") pkgopts) @@ -85,7 +90,7 @@ => Path Abs Dir -> GhciPkgInfo -> m ([FilePath], [FilePath]) getPackageOptsAndTargetFiles pwd pkg = do dist <- distDirFromDir (ghciPkgDir pkg) - autogen <- return (autogenDir dist) + let autogen = autogenDir dist paths_foo <- liftM (autogen ) @@ -93,11 +98,9 @@ ("Paths_" ++ packageNameString (ghciPkgName pkg) ++ ".hs")) paths_foo_exists <- fileExists paths_foo return - ( ["--dist-dir=" <> toFilePath dist] ++ - map ("--ghc-option=" ++) (ghciPkgOpts pkg) + ( ("--dist-dir=" <> toFilePathNoTrailingSep dist) : + map ("--ghc-option=" ++) (concatMap (\(_, bio) -> bioGeneratedOpts bio ++ bioGhcOpts bio) (ghciPkgOpts pkg)) , mapMaybe (fmap toFilePath . stripDir pwd) (S.toList (ghciPkgCFiles pkg) <> S.toList (ghciPkgModFiles pkg) <> - if paths_foo_exists - then [paths_foo] - else [])) + [paths_foo | paths_foo_exists])) diff --git a/src/Stack/Image.hs b/src/Stack/Image.hs --- a/src/Stack/Image.hs +++ b/src/Stack/Image.hs @@ -30,12 +30,12 @@ import Data.Typeable import Options.Applicative import Path +import Path.Extra import Path.IO import Stack.Constants import Stack.Types import Stack.Types.Internal -import System.FilePath (dropTrailingPathSeparator) -import System.Process +import System.Process.Run type Build e m = (HasBuildConfig e, HasConfig e, HasEnvConfig e, HasTerminal e, MonadBaseControl IO m, MonadCatch m, MonadIO m, MonadLogger m, MonadReader e m) @@ -95,36 +95,40 @@ -- | Derive an image name from the project directory. imageName :: Path Abs Dir -> String -imageName = map toLower . dropTrailingPathSeparator . toFilePath . dirname +imageName = map toLower . toFilePathNoTrailingSep . dirname -- | Create a general purpose docker image from the temporary -- directory of executables & static content. createDockerImage :: Assemble e m => Path Abs Dir -> m () createDockerImage dir = do + menv <- getMinimalEnvOverride config <- asks getConfig let dockerConfig = imgDocker (configImage config) case imgDockerBase =<< dockerConfig of Nothing -> throwM StackImageDockerBaseUnspecifiedException Just base -> do liftIO - (do writeFile - (toFilePath - (dir - $(mkRelFile "Dockerfile"))) - (unlines ["FROM " ++ base, "ADD ./ /"]) - callProcess - "docker" - [ "build" - , "-t" - , fromMaybe - (imageName (parent (parent dir))) - (imgDockerImageName =<< dockerConfig) - , toFilePath dir]) + (writeFile + (toFilePath + (dir + $(mkRelFile "Dockerfile"))) + (unlines ["FROM " ++ base, "ADD ./ /"])) + callProcess + Nothing + menv + "docker" + [ "build" + , "-t" + , fromMaybe + (imageName (parent (parent dir))) + (imgDockerImageName =<< dockerConfig) + , toFilePathNoTrailingSep dir] -- | Extend the general purpose docker image with entrypoints (if -- specified). extendDockerImageWithEntrypoint :: Assemble e m => Path Abs Dir -> m () extendDockerImageWithEntrypoint dir = do + menv <- getMinimalEnvOverride config <- asks getConfig let dockerConfig = imgDocker (configImage config) let dockerImageName = fromMaybe @@ -133,26 +137,28 @@ let imgEntrypoints = maybe Nothing imgDockerEntrypoints dockerConfig case imgEntrypoints of Nothing -> return () - Just eps -> do + Just eps -> forM_ eps - (\ep -> + (\ep -> do liftIO - (do writeFile - (toFilePath - (dir - $(mkRelFile "Dockerfile"))) - (unlines - [ "FROM " ++ dockerImageName - , "ENTRYPOINT [\"/usr/local/bin/" ++ - ep ++ "\"]" - , "CMD []"]) - callProcess - "docker" - [ "build" - , "-t" - , dockerImageName ++ "-" ++ ep - , toFilePath dir])) + (writeFile + (toFilePath + (dir + $(mkRelFile "Dockerfile"))) + (unlines + [ "FROM " ++ dockerImageName + , "ENTRYPOINT [\"/usr/local/bin/" ++ + ep ++ "\"]" + , "CMD []"])) + callProcess + Nothing + menv + "docker" + [ "build" + , "-t" + , dockerImageName ++ "-" ++ ep + , toFilePathNoTrailingSep dir]) -- | The command name for dealing with images. imgCmdName :: String diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -15,7 +15,7 @@ import Control.Exception (assert) import Control.Exception.Enclosed (catchAny, handleIO) -import Control.Monad (liftM, when) +import Control.Monad (liftM, when, zipWithM_) import Control.Monad.Catch (MonadMask, MonadThrow, throwM) import Control.Monad.IO.Class import Control.Monad.Logger @@ -26,7 +26,7 @@ import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as IntMap import qualified Data.Foldable as F -import Data.List (isSuffixOf,sort) +import Data.List (isSuffixOf,sortBy) import Data.List.Extra (nubOrd) import Data.Map (Map) import qualified Data.Map as Map @@ -86,7 +86,7 @@ when (null cabalfps) $ error "In order to init, you should have an existing .cabal file. Please try \"stack new\" instead" (warnings,gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps) - sequence_ (zipWith (mapM_ . printCabalFileWarning) cabalfps warnings) + zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings (r, flags, extraDeps) <- getDefaultResolver cabalfps gpds initOpts let p = Project @@ -94,6 +94,7 @@ , projectExtraDeps = extraDeps , projectFlags = flags , projectResolver = r + , projectCompiler = Nothing , projectExtraPackageDBs = [] } pkgs = map toPkg cabalfps @@ -226,7 +227,7 @@ -- prefer them over anything else, since odds are high that something -- already exists for them. existing <- - liftM (reverse . sort . mapMaybe (parseSnapName . T.pack)) $ + liftM (sortBy (flip compare) . mapMaybe (parseSnapName . T.pack)) $ snapshotsDir >>= liftIO . handleIO (const $ return []) . getDirectoryContents . toFilePath @@ -289,7 +290,7 @@ Nothing -> error $ "No LTS release found with major version " ++ show x Just y -> return $ ResolverSnapshot $ LTS x y ARLatestLTS - | IntMap.null $ snapshotsLts snapshots -> error $ "No LTS releases found" + | IntMap.null $ snapshotsLts snapshots -> error "No LTS releases found" | otherwise -> let (x, y) = IntMap.findMax $ snapshotsLts snapshots in return $ ResolverSnapshot $ LTS x y diff --git a/src/Stack/New.hs b/src/Stack/New.hs --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -30,7 +30,7 @@ import Data.List import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe +import Data.Maybe.Extra (mapMaybeM) import Data.Monoid import Data.Set (Set) import qualified Data.Set as S @@ -109,18 +109,38 @@ -- | Download and read in a template's text content. loadTemplate - :: (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadThrow m, MonadCatch m) + :: forall m r. + (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadThrow m, MonadCatch m) => TemplateName -> m Text -loadTemplate name = do - req <- - parseUrl (defaultTemplateUrl <> "/" <> toFilePath (templatePath name)) - config <- asks getConfig - let path = templatesDir config templatePath name - _ <- catch (redownload req path) (throwM . FailedToDownloadTemplate name) - exists <- fileExists path - if exists - then liftIO (T.readFile (toFilePath path)) - else throwM (FailedToLoadTemplate name path) +loadTemplate name = + case templatePath name of + Left absFile -> loadLocalFile absFile + Right relFile -> + catch + (loadLocalFile relFile) + (\(_ :: NewException) -> + downloadTemplate relFile) + where + loadLocalFile :: Path b File -> m Text + loadLocalFile path = do + exists <- fileExists path + if exists + then liftIO (T.readFile (toFilePath path)) + else throwM (FailedToLoadTemplate name (toFilePath path)) + downloadTemplate :: Path Rel File -> m Text + downloadTemplate rel = do + config <- asks getConfig + req <- parseUrl (defaultTemplateUrl <> "/" <> toFilePath rel) + let path :: Path Abs File + path = templatesDir config rel + _ <- + catch + (redownload req path) + (throwM . FailedToDownloadTemplate name) + exists <- fileExists path + if exists + then liftIO (T.readFile (toFilePath path)) + else throwM (FailedToLoadTemplate name (toFilePath path)) -- | Apply and unpack a template into a directory. applyTemplate @@ -143,7 +163,7 @@ defaultConfig templateText (mkStrContextM (contextFunction context))) - when (not (S.null missingKeys)) + unless (S.null missingKeys) ($logInfo (T.pack (show (MissingParameters project template missingKeys (configUserConfigPath config))))) files :: Map FilePath LB.ByteString <- execWriterT $ @@ -165,7 +185,7 @@ => Map Text Text -> String -> WriterT (Set String) m (MuType (WriterT (Set String) m)) - contextFunction context key = do + contextFunction context key = case M.lookup (T.pack key) context of Nothing -> do tell (S.singleton key) @@ -176,7 +196,7 @@ writeTemplateFiles :: MonadIO m => Map (Path Abs File) LB.ByteString -> m () -writeTemplateFiles files = do +writeTemplateFiles files = forM_ (M.toList files) (\(fp,bytes) -> @@ -193,9 +213,8 @@ case configScmInit config of Nothing -> return () Just Git -> - do catch - (callProcess (Just dir) menv "git" ["init"]) - (\(_ :: ProcessExitedUnsuccessfully) -> + catch (callProcess (Just dir) menv "git" ["init"]) + (\(_ :: ProcessExitedUnsuccessfully) -> $logInfo "git init failed to run, ignoring ...") -------------------------------------------------------------------------------- @@ -234,12 +253,12 @@ parseTemplateSet :: Value -> Parser (Set TemplateName) parseTemplateSet a = do xs <- parseJSON a - fmap (S.fromList . catMaybes) (mapM parseTemplate xs) + fmap S.fromList (mapMaybeM parseTemplate xs) where parseTemplate v = do o <- parseJSON v name <- o .: "name" - if isSuffixOf ".hsfiles" name + if ".hsfiles" `isSuffixOf` name then case parseTemplateNameFromString name of Left{} -> fail ("Unable to parse template name from " <> name) @@ -269,7 +288,7 @@ -- | Exception that might occur when making a new project. data NewException = FailedToLoadTemplate !TemplateName - !(Path Abs File) + !FilePath | FailedToDownloadTemplate !TemplateName !DownloadException | FailedToDownloadTemplates !HttpException @@ -285,7 +304,7 @@ show (FailedToLoadTemplate name path) = "Failed to load download template " <> T.unpack (templateName name) <> " from " <> - toFilePath path + path show (FailedToDownloadTemplate name (RedownloadFailed _ _ resp)) = case statusCode (responseStatus resp) of 404 -> diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings,RecordWildCards #-} module Stack.Options (Command(..) ,benchOptsParser ,buildOptsParser + ,cleanOptsParser + ,configCmdSetParser ,configOptsParser ,dockerOptsParser ,dockerCleanupOptsParser @@ -15,10 +17,11 @@ ,newOptsParser ,logLevelOptsParser ,ghciOptsParser - ,abstractResolverOptsParser ,solverOptsParser ,testOptsParser + ,hpcReportOptsParser ,pvpBoundsOption + ,globalOptsFromMonoid ) where import Control.Monad.Logger (LogLevel(..)) @@ -33,12 +36,16 @@ import qualified Data.Set as Set import qualified Data.Text as T import Data.Text.Read (decimal) +import Distribution.Version (anyVersion) +import Options.Applicative import Options.Applicative.Args import Options.Applicative.Builder.Extra -import Options.Applicative.Simple -import Options.Applicative.Types (readerAsk) +import Options.Applicative.Types (fromM, oneM, readerAsk) +import Stack.Clean (CleanOpts(..)) import Stack.Config (packagesParser) +import Stack.ConfigCmd import Stack.Constants (stackProgName) +import Stack.Coverage (HpcReportOpts(..)) import Stack.Docker import qualified Stack.Docker as Docker import Stack.Dot @@ -64,10 +71,8 @@ metavar "BENCH_ARGS" <> help ("Forward BENCH_ARGS to the benchmark suite. " <> "Supports templates from `cabal bench`"))) - <*> flag False - True - (long "no-run-benchmarks" <> - help "Disable running of benchmarks. (Benchmarks will still be built.)") + <*> switch (long "no-run-benchmarks" <> + help "Disable running of benchmarks. (Benchmarks will still be built.)") addCoverageFlags :: BuildOpts -> BuildOpts addCoverageFlags bopts @@ -103,7 +108,7 @@ haddock = boolFlags (cmd == Haddock) "haddock" - "generating Haddocks the project(s) in this directory/configuration" + "generating Haddocks the package(s) in this directory/configuration" idm haddockDeps = maybeBoolFlags @@ -115,13 +120,17 @@ "copying binaries to the local-bin-path (see 'stack path')" idm - dryRun = flag False True (long "dry-run" <> - help "Don't build anything, just prepare to") - ghcOpts = (++) + dryRun = switch (long "dry-run" <> + help "Don't build anything, just prepare to") + ghcOpts = (\x y z -> concat [x, y, z]) <$> flag [] ["-Wall", "-Werror"] ( long "pedantic" - <> help "Turn on -Wall and -Werror (note: option name may change in the future" + <> help "Turn on -Wall and -Werror" ) + <*> flag [] ["-O0"] + ( long "fast" + <> help "Turn off optimizations (-O0)" + ) <*> many (textOption (long "ghc-options" <> metavar "OPTION" <> help "Additional options passed to GHC")) @@ -133,20 +142,20 @@ help ("Override flags set in stack.yaml " <> "(applies to local packages and extra-deps)"))) - preFetch = flag False True + preFetch = switch (long "prefetch" <> help "Fetch packages necessary for the build immediately, useful with --dry-run") buildSubset = - flag' BSOnlySnapshot - (long "only-snapshot" <> - help "Only build packages for the snapshot database, not the local database") - <|> flag' BSOnlyDependencies - (long "only-dependencies" <> - help "Only build packages that are dependencies of targets on the command line") - <|> flag' BSOnlyDependencies + flag' BSOnlyDependencies (long "dependencies-only" <> help "A synonym for --only-dependencies") + <|> flag' BSOnlySnapshot + (long ("only-snapshot") <> + help ("Only build packages for the snapshot database, not the local database")) + <|> flag' BSOnlyDependencies + (long ("only-dependencies") <> + help ("Only build packages that are dependencies of targets on the command line")) <|> pure BSAll fileWatch' = @@ -163,18 +172,18 @@ "continue running after a step fails (default: false for build, true for test/bench)" idm - forceDirty = flag False True + forceDirty = switch (long "force-dirty" <> help "Force treating all local packages as having dirty files (useful for cases where stack can't detect a file change)") tests = boolFlags (cmd == Test) "test" - "testing the project(s) in this directory/configuration" + "testing the package(s) in this directory/configuration" idm benches = boolFlags (cmd == Bench) "bench" - "benchmarking the project(s) in this directory/configuration" + "benchmarking the package(s) in this directory/configuration" idm exec = cmdOption @@ -182,15 +191,15 @@ metavar "CMD [ARGS]" <> help "Command and arguments to run after a successful build" ) - onlyConfigure = flag False True + onlyConfigure = switch (long "only-configure" <> help "Only perform the configure step, not any builds. Intended for tool usage, may break when used on multiple packages at once!") - reconfigure = flag False True + reconfigure = switch (long "reconfigure" <> help "Perform the configure step even if unnecessary. Useful in some corner cases with custom Setup.hs files") - cabalVerbose = flag False True + cabalVerbose = switch (long "cabal-verbose" <> help "Ask Cabal to be verbose in its output") @@ -217,9 +226,19 @@ return $ Map.singleton pn' $ Map.singleton flagN b _ -> readerError "Must have a colon" +-- | Command-line parser for the clean command. +cleanOptsParser :: Parser CleanOpts +cleanOptsParser = CleanOpts <$> packages + where + packages = + many + (packageNameArgument + (metavar "PACKAGE" <> + help "If none specified, clean all local packages")) + -- | Command-line arguments parser for configuration. configOptsParser :: Bool -> Parser ConfigMonoid -configOptsParser docker = +configOptsParser hide0 = (\opts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage -> mempty { configMonoidDockerOpts = opts , configMonoidSystemGHC = systemGHC @@ -235,63 +254,70 @@ , configMonoidLocalBinPath = localBin , configMonoidModifyCodePage = modifyCodePage }) - <$> dockerOptsParser docker + <$> dockerOptsParser True <*> maybeBoolFlags "system-ghc" "using the system installed GHC (on the PATH) if available and a matching version" - idm + hide <*> maybeBoolFlags "install-ghc" "downloading and installing GHC if necessary (can be done manually with stack setup)" - idm + hide <*> optional (strOption ( long "arch" <> metavar "ARCH" <> help "System architecture, e.g. i386, x86_64" + <> hide )) <*> optional (strOption ( long "os" <> metavar "OS" <> help "Operating system, e.g. linux, windows" + <> hide )) - <*> optional ghcVariantParser + <*> optional (ghcVariantParser hide0) <*> optional (option auto ( long "jobs" <> short 'j' <> metavar "JOBS" <> help "Number of concurrent jobs to run" + <> hide )) <*> fmap Set.fromList (many (textOption ( long "extra-include-dirs" <> metavar "DIR" <> help "Extra directories to check for C header files" + <> hide ))) <*> fmap Set.fromList (many (textOption ( long "extra-lib-dirs" <> metavar "DIR" <> help "Extra directories to check for libraries" + <> hide ))) <*> maybeBoolFlags "skip-ghc-check" "skipping the GHC version and architecture check" - idm + hide <*> maybeBoolFlags "skip-msys" "skipping the local MSYS installation (Windows only)" - idm + hide <*> optional (strOption ( long "local-bin-path" - <> metavar "DIR" - <> help "Install binaries to DIR" - )) + <> metavar "DIR" + <> help "Install binaries to DIR" + <> hide + )) <*> maybeBoolFlags "modify-code-page" "setting the codepage to support UTF-8 (Windows only)" - idm + hide + where hide = hideMods hide0 -- | Options parser configuration for Docker. dockerOptsParser :: Bool -> Parser DockerOptsMonoid -dockerOptsParser showOptions = +dockerOptsParser hide0 = DockerOptsMonoid <$> pure False <*> maybeBoolFlags dockerCmdName @@ -363,12 +389,11 @@ <*> maybeBoolFlags (dockerOptName dockerSetUserArgName) "setting user in container to match host" hide + <*> pure anyVersion where dockerOptName optName = dockerCmdName ++ "-" ++ T.unpack optName maybeStrOption = optional . option str - hide = if showOptions - then idm - else internal <> hidden + hide = hideMods hide0 -- | Parser for docker cleanup arguments. dockerCleanupOptsParser :: Parser Docker.CleanupOpts @@ -448,19 +473,15 @@ ghciOptsParser :: Parser GhciOpts ghciOptsParser = GhciOpts - <$> many (textArgument - (metavar "TARGET" <> - help ("If none specified, " <> - "use all packages defined in current directory"))) - <*> fmap concat (many (argsOption (long "ghc-options" <> + <$> switch (long "no-build" <> help "Don't build before launching GHCi") + <*> fmap concat (many (argsOption (long "ghci-options" <> metavar "OPTION" <> help "Additional options passed to GHCi"))) <*> optional (strOption (long "with-ghc" <> metavar "GHC" <> - help "Use this command for the GHC to run")) - <*> flag False True (long "no-load" <> - help "Don't load modules on start-up") + help "Use this GHC to run GHCi")) + <*> (not <$> boolFlags True "load" "load modules on start-up" idm) <*> packagesParser <*> optional (textOption @@ -469,32 +490,28 @@ help "Specify which target should contain the main \ \module to load, such as for an executable for \ \test suite or benchmark.")) + <*> buildOptsParser Build -- | Parser for exec command -execOptsParser :: Maybe String -- ^ command - -> Parser ExecOpts +execOptsParser :: Maybe SpecialExecCmd -> Parser ExecOpts execOptsParser mcmd = ExecOpts - <$> pure mcmd + <$> maybe eoCmdParser pure mcmd <*> eoArgsParser <*> execOptsExtraParser where - eoArgsParser :: Parser [String] - eoArgsParser = many (strArgument (metavar meta)) - where - meta = (maybe ("CMD ") (const "") mcmd) ++ - "-- ARGS (e.g. stack ghc -- X.hs -o x)" + eoCmdParser = ExecCmd <$> strArgument (metavar "CMD") + eoArgsParser = many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)")) -evalOptsParser :: Maybe String -- ^ metavar +evalOptsParser :: String -- ^ metavar -> Parser EvalOpts -evalOptsParser mmeta = +evalOptsParser meta = EvalOpts <$> eoArgsParser <*> execOptsExtraParser where eoArgsParser :: Parser String eoArgsParser = strArgument (metavar meta) - meta = maybe ("CODE") id mmeta -- | Parser for extra options to exec command execOptsExtraParser :: Parser ExecOptsExtra @@ -524,40 +541,47 @@ (long "plain" <> help "Use an unmodified environment (only useful with Docker)") - -- | Parser for global command-line options. -globalOptsParser :: Bool -> Parser GlobalOpts -globalOptsParser defaultTerminal = - GlobalOpts <$> - optional (strOption (long Docker.reExecArgName <> - hidden <> - internal)) <*> - logLevelOptsParser <*> - configOptsParser False <*> - optional abstractResolverOptsParser <*> - flag - defaultTerminal - False - (long "no-terminal" <> - help - "Override terminal detection in the case of running in a false terminal") <*> +globalOptsParser :: Bool -> Parser GlobalOptsMonoid +globalOptsParser hide0 = + GlobalOptsMonoid <$> + optional (strOption (long Docker.reExecArgName <> hidden <> internal)) <*> + optional (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*> + logLevelOptsParser hide0 <*> + configOptsParser hide0 <*> + optional (abstractResolverOptsParser hide0) <*> + optional (compilerOptsParser hide0) <*> + maybeBoolFlags + "terminal" + "overriding terminal detection in the case of running in a false terminal" + hide <*> optional (strOption (long "stack-yaml" <> metavar "STACK-YAML" <> help ("Override project stack.yaml file " <> - "(overrides any STACK_YAML environment variable)"))) + "(overrides any STACK_YAML environment variable)") <> + hide)) + where hide = hideMods hide0 +-- | Create GlobalOpts from GlobalOptsMonoid. +globalOptsFromMonoid :: Bool -> GlobalOptsMonoid -> GlobalOpts +globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts + { globalReExecVersion = globalMonoidReExecVersion + , globalDockerEntrypoint = globalMonoidDockerEntrypoint + , globalLogLevel = fromMaybe defaultLogLevel (globalMonoidLogLevel) + , globalConfigMonoid = globalMonoidConfigMonoid + , globalResolver = globalMonoidResolver + , globalCompiler = globalMonoidCompiler + , globalTerminal = fromMaybe defaultTerminal (globalMonoidTerminal) + , globalStackYaml = globalMonoidStackYaml } + initOptsParser :: Parser InitOpts initOptsParser = InitOpts <$> method <*> overwrite <*> fmap not ignoreSubDirs where - ignoreSubDirs = flag False - True - (long "ignore-subdirs" <> - help "Do not search for .cabal files in sub directories") - overwrite = flag False - True - (long "force" <> - help "Force overwriting of an existing stack.yaml if it exists") + ignoreSubDirs = switch (long "ignore-subdirs" <> + help "Do not search for .cabal files in sub directories") + overwrite = switch (long "force" <> + help "Force overwriting of an existing stack.yaml if it exists") method = solver <|> (MethodResolver <$> resolver) <|> (MethodSnapshot <$> snapPref) @@ -582,16 +606,18 @@ help "Use the given resolver, even if not all dependencies are met") -- | Parse for a logging level. -logLevelOptsParser :: Parser LogLevel -logLevelOptsParser = - fmap parse +logLevelOptsParser :: Bool -> Parser (Maybe LogLevel) +logLevelOptsParser hide = + fmap (Just . parse) (strOption (long "verbosity" <> metavar "VERBOSITY" <> - help "Verbosity: silent, error, warn, info, debug")) <|> - flag defaultLogLevel - verboseLevel + help "Verbosity: silent, error, warn, info, debug" <> + hideMods hide)) <|> + flag' (Just verboseLevel) (short 'v' <> long "verbose" <> - help ("Enable verbose mode: verbosity level \"" <> showLevel verboseLevel <> "\"")) + help ("Enable verbose mode: verbosity level \"" <> showLevel verboseLevel <> "\"") <> + hideMods hide) <|> + pure Nothing where verboseLevel = LevelDebug showLevel l = case l of @@ -609,12 +635,13 @@ _ -> LevelOther (T.pack s) -- | Parser for the resolver -abstractResolverOptsParser :: Parser AbstractResolver -abstractResolverOptsParser = +abstractResolverOptsParser :: Bool -> Parser AbstractResolver +abstractResolverOptsParser hide = option readAbstractResolver (long "resolver" <> metavar "RESOLVER" <> - help "Override resolver in project file") + help "Override resolver in project file" <> + hideMods hide) readAbstractResolver :: ReadM AbstractResolver readAbstractResolver = do @@ -630,14 +657,31 @@ Left e -> readerError $ show e Right x -> return $ ARResolver x +compilerOptsParser :: Bool -> Parser CompilerVersion +compilerOptsParser hide = + option readCompilerVersion + (long "compiler" <> + metavar "COMPILER" <> + help "Use the specified compiler" <> + hideMods hide) + +readCompilerVersion :: ReadM CompilerVersion +readCompilerVersion = do + s <- readerAsk + case parseCompilerVersion (T.pack s) of + Nothing -> readerError $ "Failed to parse compiler: " ++ s + Just x -> return x + -- | GHC variant parser -ghcVariantParser :: Parser GHCVariant -ghcVariantParser = +ghcVariantParser :: Bool -> Parser GHCVariant +ghcVariantParser hide = option readGHCVariant (long "ghc-variant" <> metavar "VARIANT" <> help - "Specialized GHC variant, e.g. integersimple (implies --no-system-ghc)") + "Specialized GHC variant, e.g. integersimple (implies --no-system-ghc)" <> + hideMods hide + ) where readGHCVariant = do s <- readerAsk @@ -663,14 +707,10 @@ (optional (argsOption(long "test-arguments" <> metavar "TEST_ARGS" <> help "Arguments passed in to the test suite program"))) - <*> flag False - True - (long "coverage" <> - help "Generate a code coverage report") - <*> flag False - True - (long "no-run-tests" <> - help "Disable running of tests. (Tests will still be built.)") + <*> switch (long "coverage" <> + help "Generate a code coverage report") + <*> switch (long "no-run-tests" <> + help "Disable running of tests. (Tests will still be built.)") -- | Parser for @stack new@. newOptsParser :: Parser (NewOpts,InitOpts) @@ -685,7 +725,8 @@ help "Do not create a subdirectory for the project") <*> templateNameArgument (metavar "TEMPLATE_NAME" <> - help "Name of a template, for example: foo or foo.hsfiles" <> + help "Name of a template or a local template in a subdirectory,\ + \ for example: foo or foo.hsfiles" <> value defaultTemplateName) <*> fmap M.fromList @@ -693,9 +734,15 @@ (templateParamArgument (short 'p' <> long "param" <> metavar "KEY:VALUE" <> help - "Parameter for the template in the format key:value"))) <* - abortOption ShowHelpText (long "help" <> help "Show help text.") + "Parameter for the template in the format key:value"))) +-- | Parser for @stack hpc report@. +hpcReportOptsParser :: Parser HpcReportOpts +hpcReportOptsParser = HpcReportOpts + <$> many (textArgument $ metavar "TARGET_OR_TIX") + <*> switch (long "all" <> help "Use results from all packages and components") + <*> optional (strOption (long "destdir" <> help "Output directy for HTML report")) + pvpBoundsOption :: Parser PvpBounds pvpBoundsOption = option @@ -707,5 +754,31 @@ readPvpBounds = do s <- readerAsk case parsePvpBounds $ T.pack s of - Left e -> readerError e - Right v -> return v + Left e -> + readerError e + Right v -> + return v + +configCmdSetParser :: Parser ConfigCmdSet +configCmdSetParser = + fromM + (do field <- + oneM + (strArgument + (metavar "FIELD VALUE")) + oneM (fieldToValParser field)) + where + fieldToValParser :: String -> Parser ConfigCmdSet + fieldToValParser s = + case s of + "resolver" -> + ConfigCmdSetResolver <$> + argument + readAbstractResolver + idm + _ -> + error "parse stack config set field: only set resolver is implemented" + +-- | If argument is True, hides the option from usage and help +hideMods :: Bool -> Mod f a +hideMods hide = if hide then internal <> hidden else idm diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -36,6 +36,7 @@ ,printCabalFileWarning) where +import Control.Arrow ((&&&)) import Control.Exception hiding (try,catch) import Control.Monad import Control.Monad.Catch @@ -70,6 +71,7 @@ import Distribution.System (OS (..), Arch, Platform (..)) import Distribution.Text (display, simpleParse) import Path as FL +import Path.Extra import Path.Find import Path.IO import Prelude @@ -185,21 +187,21 @@ , packageFlags = packageConfigFlags packageConfig , packageAllDeps = S.fromList (M.keys deps) , packageHasLibrary = maybe False (buildable . libBuildInfo) (library pkg) - , packageTests = S.fromList $ + , packageTests = S.fromList [T.pack (testName t) | t <- testSuites pkg , buildable (testBuildInfo t)] - , packageBenchmarks = S.fromList $ + , packageBenchmarks = S.fromList [T.pack (benchmarkName b) | b <- benchmarks pkg , buildable (benchmarkBuildInfo b)] - , packageExes = S.fromList $ + , packageExes = S.fromList [T.pack (exeName b) | b <- executables pkg , buildable (buildInfo b)] , packageOpts = GetPackageOpts $ - \sourceMap installedMap locals cabalfp -> + \sourceMap installedMap omitPkgs cabalfp -> do (componentsModules,componentFiles,_,_) <- getPackageFiles pkgFiles cabalfp - (componentsOpts,generalOpts) <- - generatePkgDescOpts sourceMap installedMap locals cabalfp pkg componentFiles - return (componentsModules,componentFiles,componentsOpts,generalOpts) + componentsOpts <- + generatePkgDescOpts sourceMap installedMap omitPkgs cabalfp pkg componentFiles + return (componentsModules,componentFiles,componentsOpts) , packageHasExposedModules = maybe False (not . null . exposedModules) @@ -212,11 +214,11 @@ pkgFiles = GetPackageFiles $ \cabalfp -> do distDir <- distDirFromDir (parent cabalfp) - (componentModules,componentFiles,cabalFiles,warnings) <- + (componentModules,componentFiles,dataFiles',warnings) <- runReaderT (packageDescModulesAndFiles pkg) (cabalfp, buildDir distDir) - return (componentModules, componentFiles, cabalFiles, warnings) + return (componentModules, componentFiles, S.insert cabalfp dataFiles', warnings) pkgId = package (packageDescription gpkg) name = fromCabalPackageName (pkgName pkgId) pkg = resolvePackageDescription packageConfig gpkg @@ -229,12 +231,12 @@ :: (HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m, MonadIO m) => SourceMap -> InstalledMap - -> [PackageName] + -> [PackageName] -- ^ Packages to omit from the "-package" / "-package-id" flags -> Path Abs File -> PackageDescription -> Map NamedComponent (Set DotCabalPath) - -> m (Map NamedComponent [String],[String]) -generatePkgDescOpts sourceMap installedMap locals cabalfp pkg componentPaths = do + -> m (Map NamedComponent BuildInfoOpts) +generatePkgDescOpts sourceMap installedMap omitPkgs cabalfp pkg componentPaths = do distDir <- distDirFromDir cabalDir let cabalmacros = autogenDir distDir $(mkRelFile "cabal_macros.h") exists <- fileExists cabalmacros @@ -250,7 +252,7 @@ mcabalmacros cabalDir distDir - locals + omitPkgs binfo (fromMaybe mempty (M.lookup namedComponent componentPaths)) namedComponent) @@ -261,25 +263,24 @@ [] (return . generate CLib . libBuildInfo) (library pkg) - , map + , fmap (\exe -> - (generate + generate (CExe (T.pack (exeName exe))) - (buildInfo exe))) + (buildInfo exe)) (executables pkg) - , map + , fmap (\bench -> - (generate + generate (CBench (T.pack (benchmarkName bench))) - (benchmarkBuildInfo bench))) + (benchmarkBuildInfo bench)) (benchmarks pkg) - , map + , fmap (\test -> - (generate - (CBench (T.pack (testName test))) - (testBuildInfo test))) - (testSuites pkg)]) - , ["-hide-all-packages"]) + generate + (CTest (T.pack (testName test))) + (testBuildInfo test)) + (testSuites pkg)])) where cabalDir = parent cabalfp @@ -294,9 +295,20 @@ -> BuildInfo -> Set DotCabalPath -> NamedComponent - -> [String] -generateBuildInfoOpts sourceMap installedMap mcabalmacros cabalDir distDir locals b dotCabalPaths componentName = - nubOrd (concat [ghcOpts b, extOpts b, srcOpts, includeOpts, macros, deps, extra b, extraDirs, fworks b, cObjectFiles]) + -> BuildInfoOpts +generateBuildInfoOpts sourceMap installedMap mcabalmacros cabalDir distDir omitPkgs b dotCabalPaths componentName = + BuildInfoOpts + { bioGhcOpts = ghcOpts b + -- NOTE for future changes: Due to this use of nubOrd (and other uses + -- downstream), these generated options must not rely on multiple + -- argument sequences. For example, ["--main-is", "Foo.hs", "--main- + -- is", "Bar.hs"] would potentially break due to the duplicate + -- "--main-is" being removed. + -- + -- See https://github.com/commercialhaskell/stack/issues/1255 + , bioGeneratedOpts = nubOrd $ concat + [extOpts b, srcOpts, includeOpts, macros, deps, extra b, extraDirs, fworks b, cObjectFiles] + } where cObjectFiles = mapMaybe (fmap toFilePath . @@ -306,13 +318,13 @@ deps = concat [ case M.lookup (fromCabalPackageName name) installedMap of - Just (_, _, Stack.Types.Library _ident ipid) -> ["-package-id=" <> ghcPkgIdString ipid] + Just (_, Stack.Types.Library _ident ipid) -> ["-package-id=" <> ghcPkgIdString ipid] _ -> ["-package=" <> display name <> maybe "" -- This empty case applies to e.g. base. ((("-" <>) . versionString) . sourceVersion) (M.lookup (fromCabalPackageName name) sourceMap)] | Dependency name _ <- targetBuildDepends b - , not (elem name (map toCabalPackageName locals))] + , name `notElem` fmap toCabalPackageName omitPkgs] -- Generates: -package=base -package=base16-bytestring-0.1.1.6 ... sourceVersion (PSUpstream ver _ _) = ver sourceVersion (PSLocal localPkg) = packageVersion (lpPackage localPkg) @@ -328,13 +340,15 @@ extOpts = map (("-X" ++) . display) . usedExtensions srcOpts = map - (("-i" <>) . toFilePath) - (cabalDir : - map (cabalDir ) (mapMaybe parseRelDir (hsSourceDirs b)) <> + (("-i" <>) . toFilePathNoTrailingSep) + ([cabalDir | null (hsSourceDirs b)] <> + mapMaybe toIncludeDir (hsSourceDirs b) <> [autogenDir distDir,buildDir distDir]) ++ - ["-stubdir=" ++ toFilePath (buildDir distDir)] + ["-stubdir=" ++ toFilePathNoTrailingSep (buildDir distDir)] + toIncludeDir "." = Just cabalDir + toIncludeDir x = fmap (cabalDir ) (parseRelDir x) includeOpts = - [ "-I" <> toFilePath absDir + [ "-I" <> toFilePathNoTrailingSep absDir | dir <- includeDirs b , absDir <- case (parseAbsDir dir, parseRelDir dir) of (Just ab, _ ) -> [ab] @@ -345,7 +359,7 @@ = map ("-l" <>) . extraLibs extraDirs = - [ "-L" <> toFilePath absDir + [ "-L" <> toFilePathNoTrailingSep absDir | dir <- extraLibDirs b , absDir <- case (parseAbsDir dir, parseRelDir dir) of (Just ab, _ ) -> [ab] @@ -421,7 +435,7 @@ packageDependencies :: PackageDescription -> Map PackageName VersionRange packageDependencies = M.fromListWith intersectVersionRanges . - concatMap (map (\dep -> ((depName dep),depRange dep)) . + concatMap (fmap (depName &&& depRange) . targetBuildDepends) . allBuildInfo' @@ -429,7 +443,7 @@ packageToolDependencies :: PackageDescription -> Map BS.ByteString VersionRange packageToolDependencies = M.fromList . - concatMap (map (\dep -> ((packageNameByteString $ depName dep),depRange dep)) . + concatMap (fmap (packageNameByteString . depName &&& depRange) . buildTools) . allBuildInfo' @@ -508,7 +522,7 @@ mapM resolve where resolve name = - if any (== '*') name + if '*' `elem` name then explode name else liftM return (resolveFileOrWarn name) explode name = do @@ -646,7 +660,7 @@ cfiles <- buildOtherSources build return (modules, files <> cfiles, warnings) where - names = concat [bnames, exposed] + names = bnames ++ exposed exposed = map DotCabalModule (exposedModules lib) bnames = map DotCabalModule (otherModules build) build = libBuildInfo lib @@ -699,8 +713,7 @@ updateLibDeps lib deps = lib {libBuildInfo = - ((libBuildInfo lib) {targetBuildDepends = - deps})} + (libBuildInfo lib) {targetBuildDepends = deps}} updateExeDeps exe deps = exe {buildInfo = (buildInfo exe) {targetBuildDepends = deps}} @@ -750,7 +763,7 @@ where basic = addDeps lib deps children = mconcat (map apply cs) where apply (cond,node,mcs) = - if (condSatisfied cond) + if condSatisfied cond then resolveConditions rc addDeps node else maybe mempty (resolveConditions rc addDeps) mcs condSatisfied c = @@ -760,21 +773,18 @@ CNot c' -> not (condSatisfied c') COr cx cy -> - or [condSatisfied cx,condSatisfied cy] + condSatisfied cx || condSatisfied cy CAnd cx cy -> - and [condSatisfied cx,condSatisfied cy] + condSatisfied cx && condSatisfied cy varSatisifed v = case v of OS os -> os == rcOS rc Arch arch -> arch == rcArch rc Flag flag -> - case M.lookup (fromCabalFlagName flag) (rcFlags rc) of - Just x -> x - Nothing -> - -- NOTE: This should never happen, as all flags - -- which are used must be declared. Defaulting - -- to False - False + fromMaybe False $ M.lookup (fromCabalFlagName flag) (rcFlags rc) + -- NOTE: ^^^^^ This should never happen, as all flags + -- which are used must be declared. Defaulting to + -- False. Impl flavor range -> case (flavor, rcCompilerVersion rc) of (GHC, GhcVersion vghc) -> vghc `withinRange` range @@ -789,11 +799,11 @@ -- | Get the name of a dependency. depName :: Dependency -> PackageName -depName = \(Dependency n _) -> fromCabalPackageName n +depName (Dependency n _) = fromCabalPackageName n -- | Get the version range of a dependency. depRange :: Dependency -> VersionRange -depRange = \(Dependency _ r) -> r +depRange (Dependency _ r) = r -- | Try to resolve the list of base names in the given directory by -- looking for unique instances of base names applied with the given @@ -801,10 +811,10 @@ -- dependencies. resolveFilesAndDeps :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) - => Maybe (String) -- ^ Package component name - -> [Path Abs Dir] -- ^ Directories to look in. + => Maybe String -- ^ Package component name + -> [Path Abs Dir] -- ^ Directories to look in. -> [DotCabalDescriptor] -- ^ Base names. - -> [Text] -- ^ Extentions. + -> [Text] -- ^ Extentions. -> m (Set ModuleName,Set DotCabalPath,[PackageWarning]) resolveFilesAndDeps component dirs names0 exts = do (dotCabalPaths,foundModules) <- loop names0 S.empty @@ -833,7 +843,7 @@ warnUnlisted foundModules = do let unlistedModules = foundModules `S.difference` - (S.fromList $ mapMaybe dotCabalModule names0) + S.fromList (mapMaybe dotCabalModule names0) cabalfp <- asks fst return $ if S.null unlistedModules @@ -913,8 +923,8 @@ -> [DotCabalDescriptor] -- ^ Base names. -> [Text] -- ^ Extentions. -> m [DotCabalPath] -resolveFiles dirs names exts = do - liftM catMaybes (forM names (findCandidate dirs exts)) +resolveFiles dirs names exts = + forMaybeM names (findCandidate dirs exts) -- | Find a candidate for the given module-or-filename from the list -- of directories and given extensions. @@ -932,8 +942,7 @@ [] -> do case name of DotCabalModule mn - | not (display mn == paths_pkg pkg) -> do - logPossibilities dirs mn + | display mn /= paths_pkg pkg -> logPossibilities dirs mn _ -> return () return Nothing (candidate:rest) -> do @@ -958,12 +967,10 @@ DotCabalCFile fp -> liftM return (try (resolveFile' dir fp)) DotCabalModule mn -> mapM - (\ext -> - try - (resolveFile' - dir - (Cabal.toFilePath mn ++ "." ++ ext))) - (map T.unpack exts) + ((\ ext -> + try (resolveFile' dir (Cabal.toFilePath mn ++ "." ++ ext))) + . T.unpack) + exts resolveFile' :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath.FilePath -> m (Path Abs File) @@ -983,7 +990,7 @@ $logWarn ("There were multiple candidates for the Cabal entry \"" <> showName name <> - "(" <> + "\" (" <> T.intercalate "," (map (T.pack . toFilePath) rest) <> "), picking " <> T.pack (toFilePath candidate)) @@ -1053,8 +1060,8 @@ env <- ask let stack = configProjectWorkDir env fp <- parseRelFile $ concat $ - (packageIdentifierString (packageIdentifier package')) : - (maybe id (\suffix -> ("-" :) . (suffix :)) msuffix) [".log"] + packageIdentifierString (packageIdentifier package') : + maybe id (\suffix -> ("-" :) . (suffix :)) msuffix [".log"] return $ stack $(mkRelDir "logs") fp -- Internal helper to define resolveFileOrWarn and resolveDirOrWarn diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} @@ -13,6 +12,7 @@ , DumpPackage (..) , conduitDumpPackage , ghcPkgDump + , ghcPkgDescribe , InstalledCache , InstalledCacheEntry (..) , newInstalledCache @@ -45,13 +45,15 @@ import Data.IORef import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, listToMaybe) +import Data.Maybe.Extra (mapMaybeM) import qualified Data.Set as Set import qualified Data.Text.Encoding as T import Data.Typeable (Typeable) import GHC.Generics (Generic) import Path import Path.IO (createTree) +import Path.Extra (toFilePathNoTrailingSep) import Prelude -- Fix AMP warning import Stack.GhcPkg import Stack.Types @@ -83,18 +85,41 @@ -> [Path Abs Dir] -- ^ if empty, use global -> Sink ByteString IO a -> m a -ghcPkgDump menv wc mpkgDbs sink = do +ghcPkgDump = ghcPkgCmdArgs ["dump"] + +-- | Call ghc-pkg describe with appropriate flags and stream to the given @Sink@, for a single database +ghcPkgDescribe + :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) + => PackageName + -> EnvOverride + -> WhichCompiler + -> [Path Abs Dir] -- ^ if empty, use global + -> Sink ByteString IO a + -> m a +ghcPkgDescribe pkgName = ghcPkgCmdArgs ["describe", "--simple-output", packageNameString pkgName] + +-- | Call ghc-pkg and stream to the given @Sink@, for a single database +ghcPkgCmdArgs + :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) + => [String] + -> EnvOverride + -> WhichCompiler + -> [Path Abs Dir] -- ^ if empty, use global + -> Sink ByteString IO a + -> m a +ghcPkgCmdArgs cmd menv wc mpkgDbs sink = do case reverse mpkgDbs of - (pkgDb:_) -> (createDatabase menv wc) pkgDb -- TODO maybe use some retry logic instead? + (pkgDb:_) -> createDatabase menv wc pkgDb -- TODO maybe use some retry logic instead? _ -> return () - a <- sinkProcessStdout Nothing menv (ghcPkgExeName wc) args sink - return a + sinkProcessStdout Nothing menv (ghcPkgExeName wc) args sink where args = concat [ case mpkgDbs of - [] -> ["--global", "--no-user-package-db"] - _ -> ["--user", "--no-user-package-db"] ++ concatMap (\pkgDb -> ["--package-db", toFilePath pkgDb]) mpkgDbs - , ["dump", "--expand-pkgroot"] + [] -> ["--global", "--no-user-package-db"] + _ -> ["--user", "--no-user-package-db"] ++ + concatMap (\pkgDb -> ["--package-db", toFilePathNoTrailingSep pkgDb]) mpkgDbs + , cmd + , ["--expand-pkgroot"] ] -- | Create a new, empty @InstalledCache@ @@ -105,14 +130,14 @@ -- empty cache. loadInstalledCache :: (MonadLogger m, MonadIO m) => Path Abs File -> m InstalledCache loadInstalledCache path = do - m <- taggedDecodeOrLoad (toFilePath path) (return $ InstalledCacheInner Map.empty) - liftIO $ fmap InstalledCache $ newIORef m + m <- taggedDecodeOrLoad path (return $ InstalledCacheInner Map.empty) + liftIO $ InstalledCache <$> newIORef m -- | Save a @InstalledCache@ to disk saveInstalledCache :: MonadIO m => Path Abs File -> InstalledCache -> m () saveInstalledCache path (InstalledCache ref) = liftIO $ do createTree (parent path) - readIORef ref >>= taggedEncodeFile (toFilePath path) + readIORef ref >>= taggedEncodeFile path -- | Prune a list of possible packages down to those whose dependencies are met. -- @@ -129,7 +154,7 @@ -> Map name item pruneDeps getName getId getDepends chooseBest = Map.fromList - . (map $ \item -> (getName $ getId item, item)) + . fmap (getName . getId &&& id) . loop Set.empty Set.empty [] where loop foundIds usedNames foundItems dps = @@ -247,6 +272,7 @@ , dpHasExposedModules :: !Bool , dpDepends :: ![GhcPkgId] , dpHaddockInterfaces :: ![FilePath] + , dpHaddockHtml :: !(Maybe FilePath) , dpProfiling :: !profiling , dpHaddock :: !haddock , dpIsExposed :: !Bool @@ -282,10 +308,7 @@ _ -> throwM $ MissingSingleField k m -- Can't fail: if not found, same as an empty list. See: -- https://github.com/fpco/stack/issues/182 - parseM k = - case Map.lookup k m of - Just vs -> vs - Nothing -> [] + parseM k = Map.findWithDefault [] k m parseDepend :: MonadThrow m => ByteString -> m (Maybe GhcPkgId) parseDepend "builtin_rts" = return Nothing @@ -311,7 +334,7 @@ libraries = parseM "hs-libraries" exposedModules = parseM "exposed-modules" exposed = parseM "exposed" - depends <- mapM parseDepend $ parseM "depends" + depends <- mapMaybeM parseDepend $ parseM "depends" let parseQuoted key = case mapM (P.parseOnly (argsParser NoEscaping) . T.decodeUtf8) val of @@ -321,6 +344,7 @@ val = parseM key libDirPaths <- parseQuoted libDirKey haddockInterfaces <- parseQuoted "haddock-interfaces" + haddockHtml <- parseQuoted "haddock-html" return $ Just DumpPackage { dpGhcPkgId = ghcPkgId @@ -328,8 +352,9 @@ , dpLibDirs = libDirPaths , dpLibraries = S8.words $ S8.unwords libraries , dpHasExposedModules = not (null libraries || null exposedModules) - , dpDepends = catMaybes (depends :: [Maybe GhcPkgId]) + , dpDepends = depends , dpHaddockInterfaces = haddockInterfaces + , dpHaddockHtml = listToMaybe haddockHtml , dpProfiling = () , dpHaddock = () , dpIsExposed = exposed == ["True"] diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -17,15 +17,13 @@ -- | Dealing with the 00-index file and all its cabal files. module Stack.PackageIndex ( updateAllIndices - , PackageDownload (..) - , PackageCache (..) , getPackageCaches ) where import qualified Codec.Archive.Tar as Tar import Control.Exception (Exception) import Control.Exception.Enclosed (tryIO) -import Control.Monad (unless, when, liftM, mzero) +import Control.Monad (unless, when, liftM) import Control.Monad.Catch (MonadThrow, throwM, MonadCatch) import qualified Control.Monad.Catch as C import Control.Monad.IO.Class (MonadIO, liftIO) @@ -35,9 +33,7 @@ import Control.Monad.Trans.Control import Data.Aeson.Extended -import qualified Data.Binary as Binary import Data.Binary.VersionTagged -import Data.ByteString (ByteString) import qualified Data.Word8 as Word8 import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as SU @@ -55,19 +51,11 @@ import Data.Text (Text) import qualified Data.Text as T - -import Data.Text.Encoding (encodeUtf8) - import Data.Traversable (forM) import Data.Typeable (Typeable) -import Data.Word (Word64) - - -import GHC.Generics (Generic) - import Network.HTTP.Download import Path (mkRelDir, parent, parseRelDir, toFilePath, @@ -81,24 +69,6 @@ withBinaryFile) import System.Process.Read (readInNull, EnvOverride, doesExecutableExist) -data PackageCache = PackageCache - { pcOffset :: !Int64 - -- ^ offset in bytes into the 00-index.tar file for the .cabal file contents - , pcSize :: !Int64 - -- ^ size in bytes of the .cabal file - , pcDownload :: !(Maybe PackageDownload) - } - deriving (Generic) - -instance Binary PackageCache -instance NFData PackageCache -instance HasStructuralInfo PackageCache - -newtype PackageCacheMap = PackageCacheMap (Map PackageIdentifier PackageCache) - deriving (Generic, Binary, NFData) -instance HasStructuralInfo PackageCacheMap -instance HasSemanticVersion PackageCacheMap - -- | Populate the package index caches and return them. populateCache :: (MonadIO m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m, MonadCatch m) @@ -244,7 +214,7 @@ (True, ILGitHttp url _) -> logUpdate url >> updateIndexGit menv name index url (_, ILHttp url) -> logUpdate url >> updateIndexHTTP name index url (False, ILGitHttp _ url) -> logUpdate url >> updateIndexHTTP name index url - (False, ILGit url) -> logUpdate url >> (throwM $ GitNotAvailable name) + (False, ILGit url) -> logUpdate url >> throwM (GitNotAvailable name) -- | Update the index Git repo and the index tarball updateIndexGit :: (MonadIO m,MonadLogger m,MonadThrow m,MonadReader env m,HasConfig env,MonadBaseControl IO m, MonadCatch m) @@ -280,15 +250,15 @@ $logStickyDone "Fetched package index." removeFileIfExists tarFile when (indexGpgVerify index) - (do readInNull acfDir - "git" - menv - ["tag","-v","current-hackage"] - (Just (T.unlines ["Signature verification failed. " - ,"Please ensure you've set up your" - ,"GPG keychain to accept the D6CF60FD signing key." - ,"For more information, see:" - ,"https://github.com/fpco/stackage-update#readme"]))) + (readInNull acfDir + "git" + menv + ["tag","-v","current-hackage"] + (Just (T.unlines ["Signature verification failed. " + ,"Please ensure you've set up your" + ,"GPG keychain to accept the D6CF60FD signing key." + ,"For more information, see:" + ,"https://github.com/fpco/stackage-update#readme"]))) $logDebug ("Exporting a tarball to " <> (T.pack . toFilePath) tarFile) deleteCache indexName' @@ -357,31 +327,6 @@ Left e -> $logDebug $ "Could not delete cache: " <> T.pack (show e) Right () -> $logDebug $ "Deleted index cache at " <> T.pack (toFilePath fp) -data PackageDownload = PackageDownload - { pdSHA512 :: !ByteString - , pdUrl :: !ByteString - , pdSize :: !Word64 - } - deriving (Show, Generic) -instance Binary.Binary PackageDownload -instance HasStructuralInfo PackageDownload -instance NFData PackageDownload -instance FromJSON PackageDownload where - parseJSON = withObject "Package" $ \o -> do - hashes <- o .: "package-hashes" - sha512 <- maybe mzero return (Map.lookup ("SHA512" :: Text) hashes) - locs <- o .: "package-locations" - url <- - case reverse locs of - [] -> mzero - x:_ -> return x - size <- o .: "package-size" - return PackageDownload - { pdSHA512 = encodeUtf8 sha512 - , pdUrl = encodeUtf8 url - , pdSize = size - } - -- | Load the cached package URLs, or created the cache if necessary. getPackageCaches :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m) => EnvOverride @@ -389,7 +334,7 @@ getPackageCaches menv = do config <- askConfig liftM mconcat $ forM (configPackageIndices config) $ \index -> do - fp <- liftM toFilePath $ configPackageIndexCache (indexName index) + fp <- configPackageIndexCache (indexName index) PackageCacheMap pis' <- taggedDecodeOrLoad fp $ liftM PackageCacheMap $ populateCache menv index return (fmap (index,) pis') diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -14,7 +14,7 @@ import qualified Codec.Compression.GZip as GZip import Control.Applicative import Control.Concurrent.Execute (ActionContext(..)) -import Control.Monad (when, void) +import Control.Monad (unless, void) import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class import Control.Monad.Logger @@ -33,6 +33,7 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE +import Data.Time.Clock.POSIX import Distribution.Package (Dependency (..)) import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) import Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion) @@ -50,6 +51,7 @@ import Stack.Package import Stack.Types import Stack.Types.Internal +import System.Directory (getModificationTime, getPermissions, Permissions(..)) import qualified System.FilePath as FP type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env) @@ -80,15 +82,13 @@ -- everything in at once, so that's what we're doing for now: let tarPath isDir fp = either error id (Tar.toTarPath isDir (pkgId FP. fp)) - packWith f isDir fp = - liftIO $ f (pkgFp FP. fp) - (tarPath isDir fp) + packWith f isDir fp = liftIO $ f (pkgFp FP. fp) (tarPath isDir fp) packDir = packWith Tar.packDirectoryEntry True packFile fp | tweakCabal && isCabalFp fp = do lbs <- getCabalLbs pvpBounds $ toFilePath cabalfp return $ Tar.fileEntry (tarPath False fp) lbs - | otherwise = packWith Tar.packFileEntry False fp + | otherwise = packWith packFileEntry False fp isCabalFp fp = toFilePath pkgDir FP. fp == toFilePath cabalfp tarName = pkgId FP.<.> "tar.gz" pkgId = packageIdentifierString (packageIdentifier (lpPackage lp)) @@ -103,7 +103,7 @@ (_warnings, gpd) <- readPackageUnresolvedBS Nothing bs (_, _, _, _, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOpts menv <- getMinimalEnvOverride - (installedMap, _, _) <- getInstalled menv GetInstalledOpts + (installedMap, _, _, _) <- getInstalled menv GetInstalledOpts { getInstalledProfiling = False , getInstalledHaddock = False } @@ -126,7 +126,7 @@ Just (PSUpstream version _ _) -> Just version Nothing -> case Map.lookup name installedMap of - Just (version, _, _) -> Just version + Just (_, installed) -> Just (installedVersion installed) Nothing -> Nothing @@ -171,7 +171,7 @@ mapM_ (printCabalFileWarning cabalfp) warnings return LocalPackage { lpPackage = package - , lpExeComponents = Nothing -- HACK: makes it so that sdist output goes to a log instead of a file. + , lpWanted = False -- HACK: makes it so that sdist output goes to a log instead of a file. , lpDir = pkgDir , lpCabalFile = cabalfp -- NOTE: these aren't the 'correct values, but aren't used in @@ -183,6 +183,7 @@ , lpNewBuildCache = Map.empty , lpFiles = Set.empty , lpComponents = Set.empty + , lpUnbuildable = Set.empty } -- | Returns a newline-separate list of paths, and the absolute path to the .cabal file. @@ -192,11 +193,11 @@ menv <- getMinimalEnvOverride let bopts = defaultBuildOpts baseConfigOpts <- mkBaseConfigOpts bopts - (_, _mbp, locals, _extraToBuild, sourceMap) <- loadSourceMap NeedTargets bopts + (_, _mbp, locals, _extraToBuild, _sourceMap) <- loadSourceMap NeedTargets bopts runInBase <- liftBaseWith $ \run -> return (void . run) withExecuteEnv menv bopts baseConfigOpts locals - [] -- provide empty list of globals. This is a hack around custom Setup.hs files - sourceMap $ \ee -> do + [] [] [] -- provide empty list of globals. This is a hack around custom Setup.hs files + $ \ee -> withSingleContext runInBase ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _console _mlogFile -> do let outFile = toFilePath tmpdir FP. "source-files-list" cabal False ["sdist", "--list-sources", outFile] @@ -213,13 +214,14 @@ , tcoOpts = \_ -> ConfigureOpts [] [] } , taskPresent = Map.empty + , taskAllInOne = True } normalizeTarballPaths :: M env m => [FilePath] -> m [FilePath] normalizeTarballPaths fps = do --TODO: consider whether erroring out is better - otherwise the --user might upload an incomplete tar? - when (not (null outsideDir)) $ + unless (null outsideDir) $ $logWarn $ T.concat [ "Warning: These files are outside of the package directory, and will be omitted from the tarball: " , T.pack (show outsideDir)] @@ -228,7 +230,7 @@ (outsideDir, files) = partitionEithers (map pathToEither fps) pathToEither fp = maybe (Left fp) Right (normalizePath fp) -normalizePath :: FilePath -> (Maybe FilePath) +normalizePath :: FilePath -> Maybe FilePath normalizePath = fmap FP.joinPath . go . FP.splitDirectories . FP.normalise where go [] = Just [] @@ -243,3 +245,27 @@ go s x | Set.member x s = s | otherwise = go (Set.insert x s) (FP.takeDirectory x) + +-------------------------------------------------------------------------------- + +-- Copy+modified from the tar package to avoid issues with lazy IO ( see +-- https://github.com/commercialhaskell/stack/issues/1344 ) + +packFileEntry :: FilePath -- ^ Full path to find the file on the local disk + -> Tar.TarPath -- ^ Path to use for the tar Entry in the archive + -> IO Tar.Entry +packFileEntry filepath tarpath = do + mtime <- getModTime filepath + perms <- getPermissions filepath + content <- S.readFile filepath + let size = fromIntegral (S.length content) + return (Tar.simpleEntry tarpath (Tar.NormalFile (L.fromStrict content) size)) { + Tar.entryPermissions = if executable perms then Tar.executableFilePermissions + else Tar.ordinaryFilePermissions, + Tar.entryTime = mtime + } + +getModTime :: FilePath -> IO Tar.EpochTime +getModTime path = do + t <- getModificationTime path + return . floor . utcTimeToPOSIXSeconds $ t diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -42,7 +42,7 @@ import Data.Foldable hiding (concatMap, or, maximum) import Data.IORef import Data.IORef.RunOnce (runOnce) -import Data.List hiding (concat, elem, maximumBy) +import Data.List hiding (concat, elem, maximumBy, any) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe @@ -64,16 +64,20 @@ import Network.HTTP.Client.Conduit import Network.HTTP.Download.Verified import Path +import Path.Extra (toFilePathNoTrailingSep) import Path.IO import qualified Paths_stack as Meta -import Prelude hiding (concat, elem) -- Fix AMP warning +import Prelude hiding (concat, elem, any) -- Fix AMP warning import Safe (readMay) -import Stack.Config (resolvePackageEntry) +import Stack.Build (build) +import Stack.Config (resolvePackageEntry, loadConfig) import Stack.Constants (distRelativeDir, stackProgName) +import Stack.Exec (defaultEnvSettings) import Stack.Fetch import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath) import Stack.Setup.Installed import Stack.Types +import Stack.Types.Internal (HasTerminal, HasReExec, HasLogLevel) import Stack.Types.StackT import qualified System.Directory as D import System.Environment (getExecutablePath) @@ -178,7 +182,7 @@ , "' option to specify a location"] -- | Modify the environment variables (like PATH) appropriately, possibly doing installation too -setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, HasGHCVariant env, MonadBaseControl IO m) +setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, HasGHCVariant env, MonadBaseControl IO m) => Maybe Text -- ^ Message to give user when necessary GHC is not available -> m EnvConfig setupEnv mResolveMissingGHC = do @@ -235,7 +239,8 @@ localdb <- runReaderT packageDatabaseLocal envConfig0 createDatabase menv wc localdb globaldb <- getGlobalDB menv wc - let mkGPP locals = mkGhcPackagePath locals localdb deps globaldb + extras <- runReaderT packageDatabaseExtra envConfig0 + let mkGPP locals = mkGhcPackagePath locals localdb deps extras globaldb distDir <- runReaderT distRelativeDir envConfig0 @@ -266,21 +271,20 @@ else id) -- For reasoning and duplication, see: https://github.com/fpco/stack/issues/70 - $ Map.insert "HASKELL_PACKAGE_SANDBOX" (T.pack $ toFilePathNoTrailingSlash deps) + $ Map.insert "HASKELL_PACKAGE_SANDBOX" (T.pack $ toFilePathNoTrailingSep deps) $ Map.insert "HASKELL_PACKAGE_SANDBOXES" (T.pack $ if esIncludeLocals es then intercalate [searchPathSeparator] - [ toFilePathNoTrailingSlash localdb - , toFilePathNoTrailingSlash deps + [ toFilePathNoTrailingSep localdb + , toFilePathNoTrailingSep deps , "" ] else intercalate [searchPathSeparator] - [ toFilePathNoTrailingSlash deps + [ toFilePathNoTrailingSep deps , "" ]) - $ Map.insert "HASKELL_DIST_DIR" (T.pack $ toFilePathNoTrailingSlash distDir) - $ env - !() <- atomicModifyIORef envRef $ \m' -> + $ Map.insert "HASKELL_DIST_DIR" (T.pack $ toFilePathNoTrailingSep distDir) env + () <- atomicModifyIORef envRef $ \m' -> (Map.insert es eo m', ()) return eo @@ -307,7 +311,7 @@ } -- | Ensure compiler (ghc or ghcjs) is installed and provide the PATHs to add if necessary -ensureCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadBaseControl IO m) +ensureCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, HasGHCVariant env, MonadBaseControl IO m) => SetupOpts -> m (Maybe ExtraDirs) ensureCompiler sopts = do @@ -336,12 +340,14 @@ arch /= expectedArch isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts) - -- If we need to install a GHC, try to do so + -- If we need to install a GHC or MSYS, try to do so + -- Return the additional directory paths of GHC & MSYS. mtools <- if needLocal then do getSetupInfo' <- runOnce (getSetupInfo (soptsStackSetupYaml sopts) =<< asks getHttpManager) - installed <- listInstalled + localPrograms <- asks $ configLocalPrograms . getConfig + installed <- listInstalled localPrograms -- Install GHC ghcVariant <- asks getGHCVariant @@ -361,7 +367,7 @@ (soptsWantedCompiler sopts) (soptsCompilerCheck sopts) (soptsGHCBindistURL sopts) - | otherwise -> do + | otherwise -> throwM $ CompilerVersionMismatch msystem (soptsWantedCompiler sopts, expectedArch) @@ -400,6 +406,7 @@ mpaths <- case mtools of Nothing -> return Nothing Just (compilerTool, mmsys2Tool) -> do + -- Add GHC's and MSYS's paths to the config. let idents = catMaybes [Just compilerTool, mmsys2Tool] paths <- mapM extraDirs idents return $ Just $ mconcat paths @@ -501,7 +508,7 @@ dir <- case Map.lookup ident m of - Nothing -> error $ "upgradeCabal: Invariant violated, dir missing" + Nothing -> error "upgradeCabal: Invariant violated, dir missing" Just dir -> return dir runIn dir (compilerExeName wc) menv ["Setup.hs"] Nothing @@ -621,16 +628,16 @@ downloadAndInstallTool programsDir si downloadInfo tool installer = do (file, at) <- downloadFromInfo programsDir downloadInfo tool dir <- installDir programsDir tool - unmarkInstalled tool + unmarkInstalled programsDir tool installer si file at dir - markInstalled tool + markInstalled programsDir tool return tool -downloadAndInstallCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasGHCVariant env, HasHttpManager env, MonadBaseControl IO m) +downloadAndInstallCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasGHCVariant env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m) => SetupInfo -> CompilerVersion -> VersionCheck - -> (Maybe String) + -> Maybe String -> m Tool downloadAndInstallCompiler si wanted@(GhcVersion{}) versionCheck mbindistURL = do ghcVariant <- asks getGHCVariant @@ -664,7 +671,7 @@ ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant) let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installer -downloadAndInstallCompiler si wanted@(GhcjsVersion version _) versionCheck _mbindistUrl = do +downloadAndInstallCompiler si wanted versionCheck _mbindistUrl = do config <- asks getConfig ghcVariant <- asks getGHCVariant case ghcVariant of @@ -675,7 +682,11 @@ Just pairs -> getWantedCompilerInfo "source" versionCheck wanted id pairs $logInfo "Preparing to install GHCJS to an isolated location." $logInfo "This will not interfere with any system-level installation." - downloadAndInstallTool (configLocalPrograms config) si downloadInfo (ToolGhcjs selectedVersion) (installGHCJS version) + let tool = ToolGhcjs selectedVersion + installer = installGHCJS $ case selectedVersion of + GhcjsVersion version _ -> version + _ -> error "Invariant violated: expected ghcjs version in downloadAndInstallCompiler." + downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installer getWantedCompilerInfo :: (Ord k, MonadThrow m) => Text @@ -684,7 +695,7 @@ -> (k -> CompilerVersion) -> Map k a -> m (k, a) -getWantedCompilerInfo key versionCheck wanted toCV pairs = do +getWantedCompilerInfo key versionCheck wanted toCV pairs = case mpair of Just pair -> return pair Nothing -> throwM $ UnknownCompilerVersion key wanted (map toCV (Map.keys pairs)) @@ -704,7 +715,7 @@ getOSKey :: (MonadReader env m, MonadThrow m, HasPlatform env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m) => Platform -> m Text -getOSKey platform = do +getOSKey platform = case platform of Platform I386 Cabal.Linux -> return "linux32" Platform X86_64 Cabal.Linux -> return "linux64" @@ -783,7 +794,7 @@ parseRelDir $ "ghc-" ++ versionString version - $logSticky $ T.concat ["Unpacking GHC into ", (T.pack . toFilePath $ root), " ..."] + $logSticky $ T.concat ["Unpacking GHC into ", T.pack . toFilePath $ root, " ..."] $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) readInNull root tarTool menv ["xf", toFilePath archiveFile] Nothing @@ -797,7 +808,7 @@ $logStickyDone $ "Installed GHC." $logDebug $ "GHC installed to " <> T.pack (toFilePath destDir) -installGHCJS :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) +installGHCJS :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m) => Version -> SetupInfo -> Path Abs File @@ -827,7 +838,7 @@ let unpackDir = destDir Path. $(mkRelDir "src") tarComponent <- parseRelDir ("ghcjs-" ++ versionString version) runUnpack <- case platform of - Platform _ Cabal.Windows -> return $ do + Platform _ Cabal.Windows -> return $ withUnpackedTarball7z "GHCJS" si archiveFile archiveType tarComponent unpackDir _ -> do zipTool' <- @@ -846,23 +857,34 @@ readInNull destDir tarTool menv ["xf", toFilePath archiveFile] Nothing renameDir (destDir Path. tarComponent) unpackDir - $logSticky $ T.concat ["Unpacking GHCJS into ", (T.pack . toFilePath $ unpackDir), " ..."] + $logSticky $ T.concat ["Unpacking GHCJS into ", T.pack . toFilePath $ unpackDir, " ..."] $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) runUnpack - $logSticky "Installing GHCJS (this will take a long time) ..." - let destBinDir = destDir Path. $(mkRelDir "bin") - stackPath <- liftIO getExecutablePath + $logSticky "Setting up GHCJS build environment" + let stackYaml = unpackDir $(mkRelFile "stack.yaml") + destBinDir = destDir Path. $(mkRelDir "bin") createTree destBinDir - runAndLog (Just unpackDir) stackPath menv - [ "--install-ghc" - , "--stack-yaml" - , toFilePath (unpackDir $(mkRelFile "stack.yaml")) - , "--local-bin-path" - , toFilePath destBinDir - , "install" - , "-v" - ] + envConfig <- loadGhcjsEnvConfig stackYaml destBinDir + + -- On windows we need to copy options files out of the install dir. Argh! + -- This is done before the build, so that if it fails, things fail + -- earlier. + mwindowsInstallDir <- case platform of + Platform _ Cabal.Windows -> + liftM Just $ runInnerStackT envConfig installationRootLocal + _ -> return Nothing + + $logSticky "Installing GHCJS (this will take a long time) ..." + runInnerStackT envConfig $ + build (\_ -> return ()) Nothing defaultBuildOpts { boptsInstallExes = True } + -- Copy over *.options files needed on windows. + forM_ mwindowsInstallDir $ \dir -> do + (_, files) <- listDirectory (dir $(mkRelDir "bin")) + forM_ (filter ((".options" `isSuffixOf`). toFilePath) files) $ \optionsFile -> do + let dest = destDir $(mkRelDir "bin") filename optionsFile + removeFileIfExists dest + copyFile optionsFile dest $logStickyDone "Installed GHCJS." -- Install the downloaded stack binary distribution @@ -886,7 +908,7 @@ ["xf", toFilePath archiveFile, "--strip-components", "1"] Nothing -ensureGhcjsBooted :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) +ensureGhcjsBooted :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadReader env m) => EnvOverride -> CompilerVersion -> Bool -> m () ensureGhcjsBooted menv cv shouldBoot = do eres <- try $ sinkProcessStdout Nothing menv "ghcjs" [] (return ()) @@ -915,47 +937,40 @@ parseRelFile $ "ghcjs-" ++ versionString version ++ "/stack.yaml" _ -> fail "ensureGhcjsBooted invoked on non GhcjsVersion" actualStackYamlExists <- fileExists actualStackYaml - when (not actualStackYamlExists) $ + unless actualStackYamlExists $ fail "Couldn't find GHCJS stack.yaml in old or new location." - bootGhcjs menv actualStackYaml + bootGhcjs actualStackYaml destDir Left err -> throwM err -bootGhcjs :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m) - => EnvOverride -> Path Abs File -> m () -bootGhcjs menv stackYaml = do - stackPath <- liftIO getExecutablePath +bootGhcjs :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadReader env m) + => Path Abs File -> Path Abs Dir -> m () +bootGhcjs stackYaml destDir = do + envConfig <- loadGhcjsEnvConfig stackYaml (destDir $(mkRelDir "bin")) + menv <- liftIO $ configEnvOverride (getConfig envConfig) defaultEnvSettings -- Install cabal-install if missing, or if the installed one is old. - mcabal <- getCabalInstallVersion menv stackYaml + mcabal <- getCabalInstallVersion menv shouldInstallCabal <- case mcabal of Nothing -> do - $logInfo "No 'cabal' binary found for use with GHCJS. Installing a local copy of 'cabal' from source." + $logInfo "No cabal-install binary found for use with GHCJS. Installing a local copy of cabal-install from source." return True Just v | v < $(mkVersion "1.22.4") -> do $logInfo $ - "'cabal' binary found on PATH is too old to be used for booting GHCJS (version " <> + "cabal-install found on PATH is too old to be used for booting GHCJS (version " <> versionText v <> - "). Installing a local copy of 'cabal' from source." + "). Installing a local copy of cabal-install from source." return True | otherwise -> return False when shouldInstallCabal $ do $logSticky "Building cabal-install for use by ghcjs-boot ... " - runAndLog Nothing stackPath menv - [ "--stack-yaml" - , toFilePath stackYaml - , "build" - , "cabal-install" - ] + runInnerStackT envConfig $ + build (\_ -> return ()) + Nothing + defaultBuildOpts { boptsTargets = ["cabal-install"] } $logSticky "Booting GHCJS (this will take a long time) ..." - runAndLog Nothing stackPath menv - [ "--stack-yaml" - , toFilePath stackYaml - , "exec" - , "--no-ghc-package-path" - , "--" - , "ghcjs-boot" - , "--clean" - ] + let envSettings = defaultEnvSettings { esIncludeGhcPackagePath = False } + menv' <- liftIO $ configEnvOverride (getConfig envConfig) envSettings + runAndLog Nothing "ghcjs-boot" menv' ["--clean"] $logStickyDone "GHCJS booted." -- TODO: something similar is done in Stack.Build.Execute. Create some utilities @@ -966,16 +981,22 @@ let logLines = CB.lines =$ CL.mapM_ (void . restore . monadLoggerLog $(TH.location >>= liftLoc) "" LevelInfo . toLogStr) void $ restore $ sinkProcessStderrStdout mdir menv name args logLines logLines +loadGhcjsEnvConfig :: (MonadIO m, HasHttpManager r, MonadReader r m, HasTerminal r, HasReExec r, HasLogLevel r) + => Path Abs File -> Path b t -> m EnvConfig +loadGhcjsEnvConfig stackYaml binPath = runInnerStackLoggingT $ do + lc <- loadConfig + (mempty + { configMonoidInstallGHC = Just True + , configMonoidLocalBinPath = Just (toFilePath binPath) + }) + (Just stackYaml) + bconfig <- lcLoadBuildConfig lc Nothing Nothing + runInnerStackT bconfig $ setupEnv Nothing + getCabalInstallVersion :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m) - => EnvOverride -> Path Abs File -> m (Maybe Version) -getCabalInstallVersion menv stackYaml = do - ebs <- tryProcessStdout Nothing menv "stack" - [ "--stack-yaml" - , toFilePath stackYaml - , "exec" - , "--" - , "cabal" - , "--numeric-version"] + => EnvOverride -> m (Maybe Version) +getCabalInstallVersion menv = do + ebs <- tryProcessStdout Nothing menv "cabal" ["--numeric-version"] case ebs of Left _ -> return Nothing Right bs -> Just <$> parseVersion (T.encodeUtf8 (T.dropWhileEnd isSpace (T.decodeUtf8 bs))) @@ -1086,11 +1107,10 @@ Nothing -> error $ "Invalid " ++ name ++ " filename: " ++ show archiveFile Just x -> parseAbsFile $ T.unpack x run7z <- setup7z si - let tmpName = (FP.dropTrailingPathSeparator $ toFilePath $ dirname destDir) ++ "-tmp" + let tmpName = toFilePathNoTrailingSep (dirname destDir) ++ "-tmp" + createTree (parent destDir) withCanonicalizedTempDirectory (toFilePath $ parent destDir) tmpName $ \tmpDir -> do let absSrcDir = tmpDir srcDir - removeTreeIfExists absSrcDir - removeFileIfExists tarFile removeTreeIfExists destDir run7z (parent archiveFile) archiveFile run7z tmpDir tarFile @@ -1106,7 +1126,7 @@ -- | Download 7z as necessary, and get a function for unpacking things. -- -- Returned function takes an unpack directory and archive. -setup7z :: (MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadBaseControl IO m) +setup7z :: (MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadLogger n, MonadBaseControl IO m) => SetupInfo -> m (Path Abs Dir -> Path Abs File -> n ()) setup7z si = do @@ -1117,15 +1137,18 @@ (Just sevenzDll, Just sevenzExe) -> do chattyDownload "7z.dll" sevenzDll dll chattyDownload "7z.exe" sevenzExe exe - return $ \outdir archive -> liftIO $ do - ec <- rawSystem (toFilePath exe) - [ "x" - , "-o" ++ toFilePath outdir - , "-y" - , toFilePath archive - ] + return $ \outdir archive -> do + let cmd = toFilePath exe + args = + [ "x" + , "-o" ++ toFilePath outdir + , "-y" + , toFilePath archive + ] + $logProcessRun cmd args + ec <- liftIO $ rawSystem cmd args when (ec /= ExitSuccess) - $ throwM (ProblemWhileDecompressing archive) + $ liftIO $ throwM (ProblemWhileDecompressing archive) _ -> throwM SetupInfoMissingSevenz chattyDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m) @@ -1205,7 +1228,7 @@ (T.unpack label) percentage where percentage :: Double - percentage = (fromIntegral totalSoFar / fromIntegral total * 100) + percentage = fromIntegral totalSoFar / fromIntegral total * 100 -- | Given a printf format string for the decimal part and a number of -- bytes, formats the bytes using an appropiate unit and returns the @@ -1273,9 +1296,6 @@ Left e -> throwM $ GHCSanityCheckCompileFailed e ghc Right _ -> return () -- TODO check that the output of running the command is correct -toFilePathNoTrailingSlash :: Path loc Dir -> FilePath -toFilePathNoTrailingSlash = FP.dropTrailingPathSeparator . toFilePath - -- Remove potentially confusing environment variables removeHaskellEnvVars :: Map Text Text -> Map Text Text removeHaskellEnvVars = @@ -1307,10 +1327,7 @@ existingVarNames = Set.unions (map snd checkedVars) -- True if a locale is already specified by one of the "global" locale variables. hasAnyExisting = - or $ - map - (`Set.member` existingVarNames) - ["LANG", "LANGUAGE", "LC_ALL"] + any (`Set.member` existingVarNames) ["LANG", "LANGUAGE", "LC_ALL"] if null needChangeVars && hasAnyExisting then -- If no variables need changes and at least one "global" variable is set, no @@ -1392,7 +1409,7 @@ -- -a@. getFallbackLocale :: [Text] -> Maybe Text - getFallbackLocale utf8Locales = do + getFallbackLocale utf8Locales = case concatMap (matchingLocales utf8Locales) fallbackPrefixes of (v:_) -> Just v [] -> @@ -1403,17 +1420,10 @@ matchingLocales :: [Text] -> Text -> [Text] matchingLocales utf8Locales prefix = - filter - (\v -> - (T.toLower prefix) `T.isPrefixOf` T.toLower v) - utf8Locales + filter (\v -> T.toLower prefix `T.isPrefixOf` T.toLower v) utf8Locales -- Does the locale have one of the encodings in @utf8Suffixes@ (case-insensitive)? isUtf8Locale locale = - or $ - map - (\v -> - T.toLower v `T.isSuffixOf` T.toLower locale) - utf8Suffixes + any (\ v -> T.toLower v `T.isSuffixOf` T.toLower locale) utf8Suffixes -- Prefixes of fallback locales (case-insensitive) fallbackPrefixes = ["C.", "en_US.", "en_"] -- Suffixes of UTF-8 locales (case-insensitive) diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -31,10 +31,10 @@ import Distribution.System (Platform (..)) import qualified Distribution.System as Cabal import Path +import Path.Extra (toFilePathNoTrailingSep) import Path.IO import Prelude hiding (concat, elem) -- Fix AMP warning import Stack.Types -import qualified System.FilePath as FP import System.Process.Read data Tool @@ -55,27 +55,27 @@ parseToolText _ = Nothing markInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m) - => Tool + => Path Abs Dir + -> Tool -> m () -markInstalled tool = do - dir <- asks $ configLocalPrograms . getConfig +markInstalled programsPath tool = do fpRel <- parseRelFile $ toolString tool ++ ".installed" - liftIO $ writeFile (toFilePath $ dir fpRel) "installed" + liftIO $ writeFile (toFilePath $ programsPath fpRel) "installed" unmarkInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m) - => Tool + => Path Abs Dir + -> Tool -> m () -unmarkInstalled tool = do - dir <- asks $ configLocalPrograms . getConfig +unmarkInstalled programsPath tool = do fpRel <- parseRelFile $ toolString tool ++ ".installed" - removeFileIfExists $ dir fpRel + removeFileIfExists $ programsPath fpRel listInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m) - => m [Tool] -listInstalled = do - dir <- asks $ configLocalPrograms . getConfig - createTree dir - (_, files) <- listDirectory dir + => Path Abs Dir + -> m [Tool] +listInstalled programsPath = do + createTree programsPath + (_, files) <- listDirectory programsPath return $ mapMaybe toTool files where toTool fp = do @@ -143,7 +143,7 @@ $logWarn $ "binDirs: unexpected OS/tool combo: " <> T.pack (show (x, toolName)) return mempty where - goList = map toFilePathNoTrailingSlash + goList = map toFilePathNoTrailingSep isGHC n = "ghc" == n || "ghc-" `isPrefixOf` n isGHCJS n = "ghcjs" == n @@ -166,6 +166,3 @@ installDir programsDir tool = do reldir <- parseRelDir $ toolString tool return $ programsDir reldir - -toFilePathNoTrailingSlash :: Path loc Dir -> FilePath -toFilePathNoTrailingSlash = FP.dropTrailingPathSeparator . toFilePath diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -47,6 +47,7 @@ -> [String] -- ^ additional arguments -> m (CompilerVersion, Map PackageName (Version, Map FlagName Bool)) cabalSolver wc cabalfps constraints userFlags cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do + when (null cabalfps) $ throwM SolverNoCabalFiles configLines <- getCabalConfig dir constraints let configFile = dir FP. "cabal.config" liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines @@ -58,7 +59,8 @@ case mghc of Just _ -> return menv0 Nothing -> do - tools <- listInstalled + localPrograms <- asks $ configLocalPrograms . getConfig + tools <- listInstalled localPrograms let ghcName = $(mkPackageName "ghc") case [version | Tool (PackageIdentifier name version) <- tools, name == ghcName] of [] -> throwM SolverMissingGHC @@ -98,7 +100,7 @@ : "--package-db=global" : cabalArgs ++ toConstraintArgs userFlags ++ - (map toFilePath cabalfps) ++ + fmap toFilePath cabalfps ++ ["--ghcjs" | wc == Ghcjs] $logInfo "Asking cabal to calculate a build plan, please wait" @@ -177,8 +179,6 @@ => Bool -- ^ modify stack.yaml? -> m () solveExtraDeps modStackYaml = do - $logInfo "This command is not guaranteed to give you a perfect build plan" - $logInfo "It's possible that even with the changes generated below, you will still need to do some manual tweaking" econfig <- asks getEnvConfig bconfig <- asks getBuildConfig snapshot <- @@ -204,11 +204,13 @@ let newDeps = extraDeps `Map.difference` packages newFlags = Map.filter (not . Map.null) $ fmap snd newDeps + $logInfo "This command is not guaranteed to give you a perfect build plan" if Map.null newDeps then $logInfo "No needed changes found" else do + $logInfo "It's possible that even with the changes generated below, you will still need to do some manual tweaking" let o = object - $ ("extra-deps" .= (map fromTuple $ Map.toList $ fmap fst newDeps)) + $ ("extra-deps" .= map fromTuple (Map.toList $ fmap fst newDeps)) : (if Map.null newFlags then [] else ["flags" .= newFlags]) diff --git a/src/Stack/Types.hs b/src/Stack/Types.hs --- a/src/Stack/Types.hs +++ b/src/Stack/Types.hs @@ -8,6 +8,7 @@ import Stack.Types.FlagName as X import Stack.Types.GhcPkgId as X import Stack.Types.PackageIdentifier as X +import Stack.Types.PackageIndex as X import Stack.Types.PackageName as X import Stack.Types.Version as X import Stack.Types.Config as X diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -67,6 +67,7 @@ import Distribution.Text (display) import GHC.Generics import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, ()) +import Path.Extra (toFilePathNoTrailingSep) import Prelude import Stack.Types.FlagName import Stack.Types.GhcPkgId @@ -77,7 +78,7 @@ import Stack.Types.PackageName import Stack.Types.Version import System.Exit (ExitCode (ExitFailure)) -import System.FilePath (dropTrailingPathSeparator, pathSeparator) +import System.FilePath (pathSeparator) import System.Process.Log (showProcessArgDebug) ---------------------------------------------- @@ -119,6 +120,8 @@ | DuplicateLocalPackageNames [(PackageName, [Path Abs Dir])] | SolverMissingCabalInstall | SolverMissingGHC + | SolverNoCabalFiles + | SomeTargetsNotBuildable [(PackageName, NamedComponent)] deriving Typeable data FlagSource = FSCommandLine | FSStackYaml @@ -325,6 +328,14 @@ [ "Solver requires that GHC be on your PATH" , "Try running 'stack setup'" ] + show SolverNoCabalFiles = unlines + [ "No cabal files provided. Maybe this is due to not having a stack.yaml file?" + , "Try running 'stack init' to create a stack.yaml" + ] + show (SomeTargetsNotBuildable xs) = + "The following components have 'buildable: False' set in the cabal configuration, and so cannot be targets:\n " ++ + T.unpack (renderPkgComponents xs) ++ + "\nTo resolve this, either provide flags such that these components are buildable, or only specify buildable targets." instance Exception StackBuildException @@ -404,7 +415,7 @@ -- ^ Only install packages in the snapshot database, skipping -- packages intended for the local database. | BSOnlyDependencies - deriving Show + deriving (Show, Eq) -- | Configuration for building. data BuildOpts = @@ -553,10 +564,15 @@ -- | A task to perform when building data Task = Task - { taskProvides :: !PackageIdentifier -- ^ the package/version to be built - , taskType :: !TaskType -- ^ the task type, telling us how to build this + { taskProvides :: !PackageIdentifier + -- ^ the package/version to be built + , taskType :: !TaskType + -- ^ the task type, telling us how to build this , taskConfigOpts :: !TaskConfigOpts - , taskPresent :: !(Map PackageIdentifier GhcPkgId) -- ^ GhcPkgIds of already-installed dependencies + , taskPresent :: !(Map PackageIdentifier GhcPkgId) + -- ^ GhcPkgIds of already-installed dependencies + , taskAllInOne :: !Bool + -- ^ indicates that the package can be built in one step } deriving Show @@ -590,7 +606,7 @@ -- | A complete plan of what needs to be built and how to do it data Plan = Plan { planTasks :: !(Map PackageName Task) - , planFinals :: !(Map PackageName (Task, LocalPackageTB)) + , planFinals :: !(Map PackageName Task) -- ^ Final actions to be taken (test, benchmark, etc) , planUnregisterLocal :: !(Map GhcPkgId (PackageIdentifier, Maybe Text)) -- ^ Text is reason we're unregistering, for display only @@ -629,20 +645,19 @@ -> [String] configureOptsDirs bco loc package = concat [ ["--user", "--package-db=clear", "--package-db=global"] - , map (("--package-db=" ++) . toFilePath) $ case loc of + , map (("--package-db=" ++) . toFilePathNoTrailingSep) $ case loc of Snap -> bcoExtraDBs bco ++ [bcoSnapDB bco] Local -> bcoExtraDBs bco ++ [bcoSnapDB bco] ++ [bcoLocalDB bco] - , [ "--libdir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "lib")) - , "--bindir=" ++ toFilePathNoTrailingSlash (installRoot bindirSuffix) - , "--datadir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "share")) - , "--libexecdir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "libexec")) - , "--sysconfdir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "etc")) - , "--docdir=" ++ toFilePathNoTrailingSlash docDir - , "--htmldir=" ++ toFilePathNoTrailingSlash docDir - , "--haddockdir=" ++ toFilePathNoTrailingSlash docDir] + , [ "--libdir=" ++ toFilePathNoTrailingSep (installRoot $(mkRelDir "lib")) + , "--bindir=" ++ toFilePathNoTrailingSep (installRoot bindirSuffix) + , "--datadir=" ++ toFilePathNoTrailingSep (installRoot $(mkRelDir "share")) + , "--libexecdir=" ++ toFilePathNoTrailingSep (installRoot $(mkRelDir "libexec")) + , "--sysconfdir=" ++ toFilePathNoTrailingSep (installRoot $(mkRelDir "etc")) + , "--docdir=" ++ toFilePathNoTrailingSep docDir + , "--htmldir=" ++ toFilePathNoTrailingSep docDir + , "--haddockdir=" ++ toFilePathNoTrailingSep docDir] ] where - toFilePathNoTrailingSlash = dropTrailingPathSeparator . toFilePath installRoot = case loc of Snap -> bcoSnapInstallRoot bco @@ -709,10 +724,9 @@ where PackageIdentifier name version = ident - ghcOptionsMap = configGhcOptions $ getConfig econfig allGhcOptions = concat - [ fromMaybe [] $ Map.lookup Nothing ghcOptionsMap - , fromMaybe [] $ Map.lookup (Just $ packageName package) ghcOptionsMap + [ Map.findWithDefault [] Nothing (configGhcOptions config) + , Map.findWithDefault [] (Just $ packageName package) (configGhcOptions config) , if includeExtraOptions then boptsGhcOptions bopts else [] diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ViewPatterns #-} module Stack.Types.Compiler where diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} @@ -12,7 +13,111 @@ -- | The Config type. -module Stack.Types.Config where +module Stack.Types.Config + ( + -- * Main configuration types and classes + -- ** HasPlatform & HasStackRoot + HasPlatform(..) + ,HasStackRoot(..) + -- ** Config & HasConfig + ,Config(..) + ,HasConfig(..) + ,askConfig + ,askLatestSnapshotUrl + ,explicitSetupDeps + ,getMinimalEnvOverride + -- ** BuildConfig & HasBuildConfig + ,BuildConfig(..) + ,bcRoot + ,bcWorkDir + ,HasBuildConfig(..) + -- ** GHCVariant & HasGHCVariant + ,GHCVariant(..) + ,ghcVariantName + ,ghcVariantSuffix + ,parseGHCVariant + ,HasGHCVariant(..) + ,snapshotsDir + -- ** EnvConfig & HasEnvConfig + ,EnvConfig(..) + ,HasEnvConfig(..) + ,getWhichCompiler + -- * Details + -- ** ApplyGhcOptions + ,ApplyGhcOptions(..) + -- ** ConfigException + ,ConfigException(..) + -- ** ConfigMonoid + ,ConfigMonoid(..) + -- ** EnvSettings + ,EnvSettings(..) + ,minimalEnvSettings + -- ** GlobalOpts & GlobalOptsMonoid + ,GlobalOpts(..) + ,GlobalOptsMonoid(..) + ,defaultLogLevel + -- ** LoadConfig + ,LoadConfig(..) + -- ** PackageEntry & PackageLocation + ,PackageEntry(..) + ,peExtraDep + ,PackageLocation(..) + -- ** PackageIndex, IndexName & IndexLocation + ,PackageIndex(..) + ,IndexName(..) + ,configPackageIndex + ,configPackageIndexCache + ,configPackageIndexGz + ,configPackageIndexRoot + ,configPackageTarball + ,indexNameText + ,IndexLocation(..) + -- ** Project & ProjectAndConfigMonoid + ,Project(..) + ,ProjectAndConfigMonoid(..) + -- ** PvpBounds + ,PvpBounds(..) + ,parsePvpBounds + -- ** Resolver & AbstractResolver + ,Resolver(..) + ,parseResolverText + ,resolverName + ,AbstractResolver(..) + -- ** SCM + ,SCM(..) + -- * Paths + ,bindirSuffix + ,configInstalledCache + ,configMiniBuildPlanCache + ,configProjectWorkDir + ,docDirSuffix + ,flagCacheLocal + ,extraBinDirs + ,hpcReportDir + ,installationRootDeps + ,installationRootLocal + ,packageDatabaseDeps + ,packageDatabaseExtra + ,packageDatabaseLocal + ,platformOnlyRelDir + ,platformVariantRelDir + ,useShaPathOnWindows + ,workDirRel + -- * Command-specific types + -- ** Eval + ,EvalOpts(..) + -- ** Exec + ,ExecOpts(..) + ,SpecialExecCmd(..) + ,ExecOptsExtra(..) + -- ** Setup + ,DownloadInfo(..) + ,VersionedDownloadInfo(..) + ,SetupInfo(..) + ,SetupInfoLocation(..) + -- ** Docker entrypoint + ,DockerEntrypoint(..) + ) where import Control.Applicative import Control.Arrow ((&&&)) @@ -35,7 +140,6 @@ import Data.Hashable (Hashable) import Data.Map (Map) import qualified Data.Map as Map - import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid @@ -58,9 +162,15 @@ import Stack.Types.FlagName import Stack.Types.Image import Stack.Types.PackageIdentifier +import Stack.Types.PackageIndex import Stack.Types.PackageName import Stack.Types.Version +import System.PosixCompat.Types (UserID, GroupID) import System.Process.Read (EnvOverride) +#ifdef mingw32_HOST_OS +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Data.ByteString.Base16 as B16 +#endif -- | The top-level Stackage configuration. data Config = @@ -151,6 +261,9 @@ -- ^ Rebuild on GHC options changes ,configApplyGhcOptions :: !ApplyGhcOptions -- ^ Which packages to ghc-options on the command line apply to? + ,configAllowNewer :: !Bool + -- ^ Ignore version ranges in .cabal files. Funny naming chosen to + -- match cabal. } -- | Which packages to ghc-options on the command line apply to? @@ -236,36 +349,69 @@ deriving (Show, Eq, Ord) data ExecOpts = ExecOpts - { eoCmd :: !(Maybe String) - -- ^ Usage of @Maybe@ here is nothing more than a hack, to avoid some weird - -- bug in optparse-applicative. See: - -- https://github.com/commercialhaskell/stack/issues/806 + { eoCmd :: !SpecialExecCmd , eoArgs :: ![String] , eoExtra :: !ExecOptsExtra - } + } deriving (Show) +data SpecialExecCmd + = ExecCmd String + | ExecGhc + | ExecRunGhc + deriving (Show, Eq) + data ExecOptsExtra = ExecOptsPlain | ExecOptsEmbellished { eoEnvSettings :: !EnvSettings , eoPackages :: ![String] } + deriving (Show) data EvalOpts = EvalOpts { evalArg :: !String , evalExtra :: !ExecOptsExtra - } + } deriving (Show) -- | Parsed global command-line options. data GlobalOpts = GlobalOpts { globalReExecVersion :: !(Maybe String) -- ^ Expected re-exec in container version + , globalDockerEntrypoint :: !(Maybe DockerEntrypoint) + -- ^ Data used when stack is acting as a Docker entrypoint (internal use only) , globalLogLevel :: !LogLevel -- ^ Log level , globalConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig' , globalResolver :: !(Maybe AbstractResolver) -- ^ Resolver override + , globalCompiler :: !(Maybe CompilerVersion) -- ^ Compiler override , globalTerminal :: !Bool -- ^ We're in a terminal? , globalStackYaml :: !(Maybe FilePath) -- ^ Override project stack.yaml } deriving (Show) +-- | Parsed global command-line options monoid. +data GlobalOptsMonoid = GlobalOptsMonoid + { globalMonoidReExecVersion :: !(Maybe String) -- ^ Expected re-exec in container version + , globalMonoidDockerEntrypoint :: !(Maybe DockerEntrypoint) + -- ^ Data used when stack is acting as a Docker entrypoint (internal use only) + , globalMonoidLogLevel :: !(Maybe LogLevel) -- ^ Log level + , globalMonoidConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig' + , globalMonoidResolver :: !(Maybe AbstractResolver) -- ^ Resolver override + , globalMonoidCompiler :: !(Maybe CompilerVersion) -- ^ Compiler override + , globalMonoidTerminal :: !(Maybe Bool) -- ^ We're in a terminal? + , globalMonoidStackYaml :: !(Maybe FilePath) -- ^ Override project stack.yaml + } deriving (Show) + +instance Monoid GlobalOptsMonoid where + mempty = GlobalOptsMonoid Nothing Nothing Nothing mempty Nothing Nothing Nothing Nothing + mappend l r = GlobalOptsMonoid + { globalMonoidReExecVersion = globalMonoidReExecVersion l <|> globalMonoidReExecVersion r + , globalMonoidDockerEntrypoint = + globalMonoidDockerEntrypoint l <|> globalMonoidDockerEntrypoint r + , globalMonoidLogLevel = globalMonoidLogLevel l <|> globalMonoidLogLevel r + , globalMonoidConfigMonoid = globalMonoidConfigMonoid l <> globalMonoidConfigMonoid r + , globalMonoidResolver = globalMonoidResolver l <|> globalMonoidResolver r + , globalMonoidCompiler = globalMonoidCompiler l <|> globalMonoidCompiler r + , globalMonoidTerminal = globalMonoidTerminal l <|> globalMonoidTerminal r + , globalMonoidStackYaml = globalMonoidStackYaml l <|> globalMonoidStackYaml r } + -- | Either an actual resolver value, or an abstract description of one (e.g., -- latest nightly). data AbstractResolver @@ -312,15 +458,17 @@ -- for providing better error messages. , bcGHCVariant :: !GHCVariant -- ^ The variant of GHC used to select a GHC bindist. + , bcPackageCaches :: !(Map PackageIdentifier (PackageIndex, PackageCache)) + -- ^ Shared package cache map } -- | Directory containing the project's stack.yaml file bcRoot :: BuildConfig -> Path Abs Dir bcRoot = parent . bcStackYaml --- | Directory containing the project's stack.yaml file +-- | @"'bcRoot'/.stack-work"@ bcWorkDir :: BuildConfig -> Path Abs Dir -bcWorkDir = ( workDirRel) . parent . bcStackYaml +bcWorkDir = ( workDirRel) . bcRoot -- | Configuration after the environment has been setup. data EnvConfig = EnvConfig @@ -343,7 +491,7 @@ data LoadConfig m = LoadConfig { lcConfig :: !Config -- ^ Top-level Stack configuration. - , lcLoadBuildConfig :: !(Maybe AbstractResolver -> m BuildConfig) + , lcLoadBuildConfig :: !(Maybe AbstractResolver -> Maybe CompilerVersion -> m BuildConfig) -- ^ Action to load the remaining 'BuildConfig'. , lcProjectRoot :: !(Maybe (Path Abs Dir)) -- ^ The project root directory, if in a project. @@ -435,12 +583,15 @@ -- ^ Per-package flag overrides , projectResolver :: !Resolver -- ^ How we resolve which dependencies to use + , projectCompiler :: !(Maybe CompilerVersion) + -- ^ When specified, overrides which compiler to use , projectExtraPackageDBs :: ![FilePath] } deriving Show instance ToJSON Project where - toJSON p = object + toJSON p = object $ + (maybe id (\cv -> (("compiler" .= cv) :)) (projectCompiler p)) [ "packages" .= projectPackages p , "extra-deps" .= map fromTuple (Map.toList $ projectExtraDeps p) , "flags" .= projectFlags p @@ -605,6 +756,9 @@ ,configMonoidRebuildGhcOptions :: !(Maybe Bool) -- ^ See 'configMonoidRebuildGhcOptions' ,configMonoidApplyGhcOptions :: !(Maybe ApplyGhcOptions) + -- ^ See 'configApplyGhcOptions' + ,configMonoidAllowNewer :: !(Maybe Bool) + -- ^ See 'configMonoidAllowNewer' } deriving Show @@ -640,6 +794,7 @@ , configMonoidExplicitSetupDeps = mempty , configMonoidRebuildGhcOptions = Nothing , configMonoidApplyGhcOptions = Nothing + , configMonoidAllowNewer = Nothing } mappend l r = ConfigMonoid { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r @@ -673,6 +828,7 @@ , configMonoidExplicitSetupDeps = configMonoidExplicitSetupDeps l <> configMonoidExplicitSetupDeps r , configMonoidRebuildGhcOptions = configMonoidRebuildGhcOptions l <|> configMonoidRebuildGhcOptions r , configMonoidApplyGhcOptions = configMonoidApplyGhcOptions l <|> configMonoidApplyGhcOptions r + , configMonoidAllowNewer = configMonoidAllowNewer l <|> configMonoidAllowNewer r } instance FromJSON (ConfigMonoid, [JSONWarning]) where @@ -683,57 +839,57 @@ -- warnings for missing fields. parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid parseConfigMonoidJSON obj = do - configMonoidDockerOpts <- jsonSubWarnings (obj ..:? "docker" ..!= mempty) - configMonoidConnectionCount <- obj ..:? "connection-count" - configMonoidHideTHLoading <- obj ..:? "hide-th-loading" - configMonoidLatestSnapshotUrl <- obj ..:? "latest-snapshot-url" - configMonoidPackageIndices <- jsonSubWarningsTT (obj ..:? "package-indices") - configMonoidSystemGHC <- obj ..:? "system-ghc" - configMonoidInstallGHC <- obj ..:? "install-ghc" - configMonoidSkipGHCCheck <- obj ..:? "skip-ghc-check" - configMonoidSkipMsys <- obj ..:? "skip-msys" + configMonoidDockerOpts <- jsonSubWarnings (obj ..:? configMonoidDockerOptsName ..!= mempty) + configMonoidConnectionCount <- obj ..:? configMonoidConnectionCountName + configMonoidHideTHLoading <- obj ..:? configMonoidHideTHLoadingName + configMonoidLatestSnapshotUrl <- obj ..:? configMonoidLatestSnapshotUrlName + configMonoidPackageIndices <- jsonSubWarningsTT (obj ..:? configMonoidPackageIndicesName) + configMonoidSystemGHC <- obj ..:? configMonoidSystemGHCName + configMonoidInstallGHC <- obj ..:? configMonoidInstallGHCName + configMonoidSkipGHCCheck <- obj ..:? configMonoidSkipGHCCheckName + configMonoidSkipMsys <- obj ..:? configMonoidSkipMsysName configMonoidRequireStackVersion <- unVersionRangeJSON <$> - obj ..:? "require-stack-version" + obj ..:? configMonoidRequireStackVersionName ..!= VersionRangeJSON anyVersion - configMonoidOS <- obj ..:? "os" - configMonoidArch <- obj ..:? "arch" - configMonoidGHCVariant <- obj ..:? "ghc-variant" - configMonoidJobs <- obj ..:? "jobs" - configMonoidExtraIncludeDirs <- obj ..:? "extra-include-dirs" ..!= Set.empty - configMonoidExtraLibDirs <- obj ..:? "extra-lib-dirs" ..!= Set.empty - configMonoidConcurrentTests <- obj ..:? "concurrent-tests" - configMonoidLocalBinPath <- obj ..:? "local-bin-path" - configMonoidImageOpts <- jsonSubWarnings (obj ..:? "image" ..!= mempty) + configMonoidOS <- obj ..:? configMonoidOSName + configMonoidArch <- obj ..:? configMonoidArchName + configMonoidGHCVariant <- obj ..:? configMonoidGHCVariantName + configMonoidJobs <- obj ..:? configMonoidJobsName + configMonoidExtraIncludeDirs <- obj ..:? configMonoidExtraIncludeDirsName ..!= Set.empty + configMonoidExtraLibDirs <- obj ..:? configMonoidExtraLibDirsName ..!= Set.empty + configMonoidConcurrentTests <- obj ..:? configMonoidConcurrentTestsName + configMonoidLocalBinPath <- obj ..:? configMonoidLocalBinPathName + configMonoidImageOpts <- jsonSubWarnings (obj ..:? configMonoidImageOptsName ..!= mempty) templates <- obj ..:? "templates" (configMonoidScmInit,configMonoidTemplateParameters) <- case templates of Nothing -> return (Nothing,M.empty) Just tobj -> do - scmInit <- tobj ..:? "scm-init" - params <- tobj ..:? "params" + scmInit <- tobj ..:? configMonoidScmInitName + params <- tobj ..:? configMonoidTemplateParametersName return (scmInit,fromMaybe M.empty params) - configMonoidCompilerCheck <- obj ..:? "compiler-check" + configMonoidCompilerCheck <- obj ..:? configMonoidCompilerCheckName - mghcoptions <- obj ..:? "ghc-options" + mghcoptions <- obj ..:? configMonoidGhcOptionsName configMonoidGhcOptions <- case mghcoptions of Nothing -> return mempty Just m -> fmap Map.fromList $ mapM handleGhcOptions $ Map.toList m - extraPath <- obj ..:? "extra-path" ..!= [] + extraPath <- obj ..:? configMonoidExtraPathName ..!= [] configMonoidExtraPath <- forM extraPath $ either (fail . show) return . parseAbsDir . T.unpack configMonoidSetupInfoLocations <- - maybeToList <$> jsonSubWarningsT (obj ..:? "setup-info") - - configMonoidPvpBounds <- obj ..:? "pvp-bounds" - configMonoidModifyCodePage <- obj ..:? "modify-code-page" + maybeToList <$> jsonSubWarningsT (obj ..:? configMonoidSetupInfoLocationsName) + configMonoidPvpBounds <- obj ..:? configMonoidPvpBoundsName + configMonoidModifyCodePage <- obj ..:? configMonoidModifyCodePageName configMonoidExplicitSetupDeps <- - (obj ..:? "explicit-setup-deps" ..!= mempty) + (obj ..:? configMonoidExplicitSetupDepsName ..!= mempty) >>= fmap Map.fromList . mapM handleExplicitSetupDep . Map.toList - configMonoidRebuildGhcOptions <- obj ..:? "rebuild-ghc-options" - configMonoidApplyGhcOptions <- obj ..:? "apply-ghc-options" + configMonoidRebuildGhcOptions <- obj ..:? configMonoidRebuildGhcOptionsName + configMonoidApplyGhcOptions <- obj ..:? configMonoidApplyGhcOptionsName + configMonoidAllowNewer <- obj ..:? configMonoidAllowNewerName return ConfigMonoid {..} where @@ -760,16 +916,99 @@ Right x -> return $ Just x return (name, b) --- | Newtype for non-orphan FromJSON instance. -newtype VersionRangeJSON = VersionRangeJSON { unVersionRangeJSON :: VersionRange } +configMonoidDockerOptsName :: Text +configMonoidDockerOptsName = "docker" --- | Parse VersionRange. -instance FromJSON VersionRangeJSON where - parseJSON = withText "VersionRange" - (\s -> maybe (fail ("Invalid cabal-style VersionRange: " ++ T.unpack s)) - (return . VersionRangeJSON) - (Distribution.Text.simpleParse (T.unpack s))) +configMonoidConnectionCountName :: Text +configMonoidConnectionCountName = "connection-count" +configMonoidHideTHLoadingName :: Text +configMonoidHideTHLoadingName = "hide-th-loading" + +configMonoidLatestSnapshotUrlName :: Text +configMonoidLatestSnapshotUrlName = "latest-snapshot-url" + +configMonoidPackageIndicesName :: Text +configMonoidPackageIndicesName = "package-indices" + +configMonoidSystemGHCName :: Text +configMonoidSystemGHCName = "system-ghc" + +configMonoidInstallGHCName :: Text +configMonoidInstallGHCName = "install-ghc" + +configMonoidSkipGHCCheckName :: Text +configMonoidSkipGHCCheckName = "skip-ghc-check" + +configMonoidSkipMsysName :: Text +configMonoidSkipMsysName = "skip-msys" + +configMonoidRequireStackVersionName :: Text +configMonoidRequireStackVersionName = "require-stack-version" + +configMonoidOSName :: Text +configMonoidOSName = "os" + +configMonoidArchName :: Text +configMonoidArchName = "arch" + +configMonoidGHCVariantName :: Text +configMonoidGHCVariantName = "ghc-variant" + +configMonoidJobsName :: Text +configMonoidJobsName = "jobs" + +configMonoidExtraIncludeDirsName :: Text +configMonoidExtraIncludeDirsName = "extra-include-dirs" + +configMonoidExtraLibDirsName :: Text +configMonoidExtraLibDirsName = "extra-lib-dirs" + +configMonoidConcurrentTestsName :: Text +configMonoidConcurrentTestsName = "concurrent-tests" + +configMonoidLocalBinPathName :: Text +configMonoidLocalBinPathName = "local-bin-path" + +configMonoidImageOptsName :: Text +configMonoidImageOptsName = "image" + +configMonoidScmInitName :: Text +configMonoidScmInitName = "scm-init" + +configMonoidTemplateParametersName :: Text +configMonoidTemplateParametersName = "params" + +configMonoidCompilerCheckName :: Text +configMonoidCompilerCheckName = "compiler-check" + +configMonoidGhcOptionsName :: Text +configMonoidGhcOptionsName = "ghc-options" + +configMonoidExtraPathName :: Text +configMonoidExtraPathName = "extra-path" + +configMonoidSetupInfoLocationsName :: Text +configMonoidSetupInfoLocationsName = "setup-info" + +configMonoidPvpBoundsName :: Text +configMonoidPvpBoundsName = "pvp-bounds" + +configMonoidModifyCodePageName :: Text +configMonoidModifyCodePageName = "modify-code-page" + +configMonoidExplicitSetupDepsName :: Text +configMonoidExplicitSetupDepsName = "explicit-setup-deps" + +configMonoidRebuildGhcOptionsName :: Text +configMonoidRebuildGhcOptionsName = "rebuild-ghc-options" + +configMonoidApplyGhcOptionsName :: Text +configMonoidApplyGhcOptionsName = "apply-ghc-options" + +configMonoidAllowNewerName :: Text +configMonoidAllowNewerName = "allow-newer" + data ConfigException = ParseConfigFileException (Path Abs File) ParseException | ParseResolverException Text @@ -813,9 +1052,9 @@ [ "The version of stack you are using (" , show (fromCabalVersion Meta.version) , ") is outside the required\n" - ,"version range (" + ,"version range specified in stack.yaml (" , T.unpack (versionRangeText requiredRange) - , ") specified in stack.yaml." ] + , ")." ] show (NoMatchingSnapshot names) = concat [ "There was no snapshot found that matched the package " , "bounds in your .cabal files.\n" @@ -874,6 +1113,7 @@ base <- parseRelFile $ packageIdentifierString ident ++ ".tar.gz" return (root $(mkRelDir "packages") name ver base) +-- | @".stack-work"@ workDirRel :: Path Rel Dir workDirRel = $(mkRelDir ".stack-work") @@ -895,23 +1135,6 @@ platform <- asks getPlatform parseRelDir (Distribution.Text.display platform) --- | Relative directory for the platform identifier -platformVariantRelDir - :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m) - => m (Path Rel Dir) -platformVariantRelDir = do - platform <- asks getPlatform - ghcVariant <- asks getGHCVariant - parseRelDir (Distribution.Text.display platform <> ghcVariantSuffix ghcVariant) - --- | Path to .shake files. -configShakeFilesDir :: (MonadReader env m, HasBuildConfig env) => m (Path Abs Dir) -configShakeFilesDir = liftM ( $(mkRelDir "shake")) configProjectWorkDir - --- | Where to unpack packages for local build -configLocalUnpackDir :: (MonadReader env m, HasBuildConfig env) => m (Path Abs Dir) -configLocalUnpackDir = liftM ( $(mkRelDir "unpacked")) configProjectWorkDir - -- | Directory containing snapshots snapshotsDir :: (MonadReader env m, HasConfig env, HasGHCVariant env, MonadThrow m) => m (Path Abs Dir) snapshotsDir = do @@ -922,21 +1145,51 @@ -- | Installation root for dependencies installationRootDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir) installationRootDeps = do - snapshots <- snapshotsDir - bc <- asks getBuildConfig - name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc - ghc <- compilerVersionDir - return $ snapshots name ghc + config <- asks getConfig + -- TODO: also useShaPathOnWindows here, once #1173 is resolved. + psc <- platformSnapAndCompilerRel + return $ configStackRoot config $(mkRelDir "snapshots") psc -- | Installation root for locals installationRootLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir) installationRootLocal = do bc <- asks getBuildConfig + psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel + return $ configProjectWorkDir bc $(mkRelDir "install") psc + +-- | Path for platform followed by snapshot name followed by compiler +-- name. +platformSnapAndCompilerRel + :: (MonadReader env m, HasPlatform env, HasEnvConfig env, MonadThrow m) + => m (Path Rel Dir) +platformSnapAndCompilerRel = do + bc <- asks getBuildConfig + platform <- platformVariantRelDir name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc ghc <- compilerVersionDir - platform <- platformVariantRelDir - return $ configProjectWorkDir bc $(mkRelDir "install") platform name ghc + useShaPathOnWindows (platform name ghc) +-- | Relative directory for the platform identifier +platformVariantRelDir + :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m) + => m (Path Rel Dir) +platformVariantRelDir = do + platform <- asks getPlatform + ghcVariant <- asks getGHCVariant + parseRelDir (Distribution.Text.display platform <> ghcVariantSuffix ghcVariant) + +-- | This is an attempt to shorten stack paths on Windows to decrease our +-- chances of hitting 260 symbol path limit. The idea is to calculate +-- SHA1 hash of the path used on other architectures, encode with base +-- 16 and take first 8 symbols of it. +useShaPathOnWindows :: MonadThrow m => Path Rel Dir -> m (Path Rel Dir) +useShaPathOnWindows = +#ifdef mingw32_HOST_OS + parseRelDir . S8.unpack . S8.take 8 . B16.encode . SHA1.hash . encodeUtf8 . T.pack . toFilePath +#else + return +#endif + compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir) compilerVersionDir = do compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig) @@ -1039,6 +1292,7 @@ flags <- o ..:? "flags" ..!= mempty resolver <- jsonSubWarnings (o ..: "resolver") + compiler <- o ..:? "compiler" config <- parseConfigMonoidJSON o extraPackageDBs <- o ..:? "extra-package-dbs" ..!= [] let project = Project @@ -1046,6 +1300,7 @@ , projectExtraDeps = extraDeps , projectFlags = flags , projectResolver = resolver + , projectCompiler = compiler , projectExtraPackageDBs = extraPackageDBs } return $ ProjectAndConfigMonoid project config @@ -1267,3 +1522,9 @@ case Map.lookup Nothing m of Just b -> b Nothing -> False -- default value + +-- | Data passed into Docker container for the Docker entrypoint's use +data DockerEntrypoint = DockerEntrypoint + { deUidGid :: !(Maybe (UserID, GroupID)) + -- ^ UID/GID of host user, if we wish to perform UID/GID switch in container + } deriving (Read,Show) diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -10,7 +10,11 @@ import Data.Aeson.Extended import Data.Monoid import Data.Text (Text) +import qualified Data.Text as T +import Distribution.Text (simpleParse) +import Distribution.Version (anyVersion) import Path +import Stack.Types.Version -- | Docker configuration. data DockerOpts = DockerOpts @@ -46,6 +50,8 @@ -- ^ Location of container-compatible stack executable ,dockerSetUser :: !(Maybe Bool) -- ^ Set in-container user to match host's + ,dockerRequireDockerVersion :: !VersionRange + -- ^ Require a version of Docker within this range. } deriving (Show) @@ -86,6 +92,8 @@ -- ^ Location of container-compatible stack executable ,dockerMonoidSetUser :: !(Maybe Bool) -- ^ Set in-container user to match host's + ,dockerMonoidRequireDockerVersion :: !VersionRange + -- ^ See: 'dockerRequireDockerVersion' } deriving (Show) @@ -110,6 +118,10 @@ dockerMonoidDatabasePath <- o ..:? dockerDatabasePathArgName dockerMonoidStackExe <- o ..:? dockerStackExeArgName dockerMonoidSetUser <- o ..:? dockerSetUserArgName + dockerMonoidRequireDockerVersion + <- unVersionRangeJSON <$> + o ..:? dockerRequireDockerVersionArgName + ..!= VersionRangeJSON anyVersion return DockerOptsMonoid{..}) -- | Left-biased combine Docker options @@ -131,6 +143,7 @@ ,dockerMonoidDatabasePath = Nothing ,dockerMonoidStackExe = Nothing ,dockerMonoidSetUser = Nothing + ,dockerMonoidRequireDockerVersion = anyVersion } mappend l r = DockerOptsMonoid {dockerMonoidDefaultEnable = dockerMonoidDefaultEnable l || dockerMonoidDefaultEnable r @@ -149,6 +162,9 @@ ,dockerMonoidDatabasePath = dockerMonoidDatabasePath l <|> dockerMonoidDatabasePath r ,dockerMonoidStackExe = dockerMonoidStackExe l <|> dockerMonoidStackExe r ,dockerMonoidSetUser = dockerMonoidSetUser l <|> dockerMonoidSetUser r + ,dockerMonoidRequireDockerVersion + = intersectVersionRanges (dockerMonoidRequireDockerVersion l) + (dockerMonoidRequireDockerVersion r) } -- | Where to get the `stack` executable to run in Docker containers @@ -194,6 +210,16 @@ | DockerMonoidImage String deriving (Show) +-- | Newtype for non-orphan FromJSON instance. +newtype VersionRangeJSON = VersionRangeJSON { unVersionRangeJSON :: VersionRange } + +-- | Parse VersionRange. +instance FromJSON VersionRangeJSON where + parseJSON = withText "VersionRange" + (\s -> maybe (fail ("Invalid cabal-style VersionRange: " ++ T.unpack s)) + (return . VersionRangeJSON) + (Distribution.Text.simpleParse (T.unpack s))) + -- | Docker enable argument name. dockerEnableArgName :: Text dockerEnableArgName = "enable" @@ -269,3 +295,11 @@ -- | Docker @set-user@ argument name dockerSetUserArgName :: Text dockerSetUserArgName = "set-user" + +-- | Docker @require-version@ argument name +dockerRequireDockerVersionArgName :: Text +dockerRequireDockerVersionArgName = "require-docker-version" + +-- | Argument name used to pass docker entrypoint data (only used internally) +dockerEntrypointArgName :: String +dockerEntrypointArgName = "internal-docker-entrypoint" diff --git a/src/Stack/Types/FlagName.hs b/src/Stack/Types/FlagName.hs --- a/src/Stack/Types/FlagName.hs +++ b/src/Stack/Types/FlagName.hs @@ -57,7 +57,7 @@ deriving (Typeable,Data,Generic,Hashable,Binary,NFData) instance HasStructuralInfo FlagName instance Eq FlagName where - x == y = (compare x y) == EQ + x == y = compare x y == EQ instance Ord FlagName where compare (FlagName x) (FlagName y) = compare (S.map Word8.toLower x) (S.map Word8.toLower y) diff --git a/src/Stack/Types/GhcPkgId.hs b/src/Stack/Types/GhcPkgId.hs --- a/src/Stack/Types/GhcPkgId.hs +++ b/src/Stack/Types/GhcPkgId.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -23,8 +23,10 @@ import Data.Maybe import Data.Monoid import Data.Set (Set) +import qualified Data.Set as Set import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Distribution.InstalledPackageInfo (PError) import Distribution.ModuleName (ModuleName) import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier) @@ -105,11 +107,20 @@ -> Path Abs File -> m (Map NamedComponent (Set ModuleName) ,Map NamedComponent (Set DotCabalPath) - ,Map NamedComponent [String],[String]) + ,Map NamedComponent BuildInfoOpts) } instance Show GetPackageOpts where show _ = "" +data BuildInfoOpts = BuildInfoOpts + { bioGhcOpts :: [String] + -- ^ Options from the ghc-options cabal field + , bioGeneratedOpts :: [String] + -- ^ Other options from cabal information. These options can safely have + -- 'nubOrd' applied to them, as there are no multi-word options (see + -- https://github.com/commercialhaskell/stack/issues/1255) + } deriving Show + -- | Files to get for a cabal package. data CabalFileType = AllFiles @@ -137,18 +148,18 @@ concat [ "module not listed in " , toFilePath (filename cabalfp) - , (case component of + , case component of Nothing -> " for library" - Just c -> " for '" ++ c ++ "'") + Just c -> " for '" ++ c ++ "'" , " component (add to other-modules): " , display unlistedModule] show (UnlistedModulesWarning cabalfp component unlistedModules) = concat [ "modules not listed in " , toFilePath (filename cabalfp) - , (case component of + , case component of Nothing -> " for library" - Just c -> " for '" ++ c ++ "'") + Just c -> " for '" ++ c ++ "'" , " component (add to other-modules):\n " , intercalate "\n " (map display unlistedModules)] @@ -193,45 +204,41 @@ piiVersion :: a -> Version piiLocation :: a -> InstallLocation --- | Second-stage build information: tests and benchmarks -data LocalPackageTB = LocalPackageTB - { lptbPackage :: !Package - -- ^ Package resolved with dependencies for tests and benchmarks, depending - -- on which components are active - , lptbTests :: !(Set Text) - -- ^ Test components - , lptbBenches :: !(Set Text) - -- ^ Benchmark components - } - deriving Show - -- | Information on a locally available package of source code data LocalPackage = LocalPackage - { lpPackage :: !Package -- ^ The @Package@ info itself, after resolution with package flags, not including any tests or benchmarks - , lpTestDeps :: !(Map PackageName VersionRange) - -- ^ Used for determining if we can use --enable-tests in a normal build - , lpBenchDeps :: !(Map PackageName VersionRange) - -- ^ Used for determining if we can use --enable-benchmarks in a normal build - , lpExeComponents :: !(Maybe (Set Text)) -- ^ Executable components to build, Nothing if not a target - - , lpTestBench :: !(Maybe LocalPackageTB) - - , lpDir :: !(Path Abs Dir) -- ^ Directory of the package. - , lpCabalFile :: !(Path Abs File) -- ^ The .cabal file - , lpDirtyFiles :: !(Maybe (Set FilePath)) + { lpPackage :: !Package + -- ^ The @Package@ info itself, after resolution with package flags, + -- with tests and benchmarks disabled + , lpComponents :: !(Set NamedComponent) + -- ^ Components to build, not including the library component. + , lpUnbuildable :: !(Set NamedComponent) + -- ^ Components explicitly requested for build, that are marked + -- "buildable: false". + , lpWanted :: !Bool + -- ^ Whether this package is wanted as a target. + , lpTestDeps :: !(Map PackageName VersionRange) + -- ^ Used for determining if we can use --enable-tests in a normal build. + , lpBenchDeps :: !(Map PackageName VersionRange) + -- ^ Used for determining if we can use --enable-benchmarks in a normal + -- build. + , lpTestBench :: !(Maybe Package) + -- ^ This stores the 'Package' with tests and benchmarks enabled, if + -- either is asked for by the user. + , lpDir :: !(Path Abs Dir) + -- ^ Directory of the package. + , lpCabalFile :: !(Path Abs File) + -- ^ The .cabal file + , lpDirtyFiles :: !(Maybe (Set FilePath)) -- ^ Nothing == not dirty, Just == dirty. Note that the Set may be empty if -- we forced the build to treat packages as dirty. Also, the Set may not -- include all modified files. - , lpNewBuildCache :: !(Map FilePath FileCacheInfo) -- ^ current state of the files - , lpFiles :: !(Set (Path Abs File)) -- ^ all files used by this package - , lpComponents :: !(Set NamedComponent) + , lpNewBuildCache :: !(Map FilePath FileCacheInfo) + -- ^ current state of the files + , lpFiles :: !(Set (Path Abs File)) + -- ^ all files used by this package } deriving Show --- | Is the given local a target -lpWanted :: LocalPackage -> Bool -lpWanted lp = isJust (lpExeComponents lp) || isJust (lpTestBench lp) - -- | A single, fully resolved component of a package data NamedComponent = CLib @@ -246,6 +253,46 @@ renderComponent (CTest x) = "test:" <> encodeUtf8 x renderComponent (CBench x) = "bench:" <> encodeUtf8 x +renderPkgComponents :: [(PackageName, NamedComponent)] -> Text +renderPkgComponents = T.intercalate " " . map renderPkgComponent + +renderPkgComponent :: (PackageName, NamedComponent) -> Text +renderPkgComponent (pkg, comp) = packageNameText pkg <> ":" <> decodeUtf8 (renderComponent comp) + +exeComponents :: Set NamedComponent -> Set Text +exeComponents = Set.fromList . mapMaybe mExeName . Set.toList + where + mExeName (CExe name) = Just name + mExeName _ = Nothing + +testComponents :: Set NamedComponent -> Set Text +testComponents = Set.fromList . mapMaybe mTestName . Set.toList + where + mTestName (CTest name) = Just name + mTestName _ = Nothing + +benchComponents :: Set NamedComponent -> Set Text +benchComponents = Set.fromList . mapMaybe mBenchName . Set.toList + where + mBenchName (CBench name) = Just name + mBenchName _ = Nothing + +isCLib :: NamedComponent -> Bool +isCLib CLib{} = True +isCLib _ = False + +isCExe :: NamedComponent -> Bool +isCExe CExe{} = True +isCExe _ = False + +isCTest :: NamedComponent -> Bool +isCTest CTest{} = True +isCTest _ = False + +isCBench :: NamedComponent -> Bool +isCBench CBench{} = True +isCBench _ = False + -- | A location to install a package into, either snapshot or local data InstallLocation = Snap | Local deriving (Show, Eq) @@ -332,7 +379,12 @@ DotCabalFilePath fp -> fp DotCabalCFilePath fp -> fp -type InstalledMap = Map PackageName (Version, InstallLocation, Installed) -- TODO Version is now redundant and can be gleaned from Installed +type InstalledMap = Map PackageName (InstallLocation, Installed) data Installed = Library PackageIdentifier GhcPkgId | Executable PackageIdentifier deriving (Show, Eq, Ord) + +-- | Get the installed Version. +installedVersion :: Installed -> Version +installedVersion (Library (PackageIdentifier _ v) _) = v +installedVersion (Executable (PackageIdentifier _ v)) = v diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -1,22 +1,19 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# OPTIONS -fno-warn-unused-do-bind #-} -- | Package identifier (name-version). module Stack.Types.PackageIdentifier - (PackageIdentifier(..) - ,toTuple - ,fromTuple - ,parsePackageIdentifier - ,parsePackageIdentifierFromString - ,packageIdentifierVersion - ,packageIdentifierName - ,packageIdentifierParser - ,packageIdentifierString - ,packageIdentifierText) + ( PackageIdentifier(..) + , toTuple + , fromTuple + , parsePackageIdentifier + , parsePackageIdentifierFromString + , packageIdentifierParser + , packageIdentifierString + , packageIdentifierText ) where import Control.Applicative @@ -47,10 +44,12 @@ instance Exception PackageIdentifierParseFail -- | A pkg-ver combination. -data PackageIdentifier = - PackageIdentifier !PackageName - !Version - deriving (Eq,Ord,Generic,Data,Typeable) +data PackageIdentifier = PackageIdentifier + { -- | Get the name part of the identifier. + packageIdentifierName :: !PackageName + -- | Get the version part of the identifier. + , packageIdentifierVersion :: !Version + } deriving (Eq,Ord,Generic,Data,Typeable) instance NFData PackageIdentifier where rnf (PackageIdentifier !p !v) = @@ -78,14 +77,6 @@ -- | Convert from a tuple to a package identifier. fromTuple :: (PackageName,Version) -> PackageIdentifier fromTuple (n,v) = PackageIdentifier n v - --- | Get the version part of the identifier. -packageIdentifierVersion :: PackageIdentifier -> Version -packageIdentifierVersion (PackageIdentifier _ ver) = ver - --- | Get the name part of the identifier. -packageIdentifierName :: PackageIdentifier -> PackageName -packageIdentifierName (PackageIdentifier name _) = name -- | A parser for a package-version pair. packageIdentifierParser :: Parser PackageIdentifier diff --git a/src/Stack/Types/PackageIndex.hs b/src/Stack/Types/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/PackageIndex.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Stack.Types.PackageIndex + ( PackageDownload (..) + , PackageCache (..) + , PackageCacheMap (..) + ) where + +import Control.Monad (mzero) +import Data.Aeson.Extended +import qualified Data.Binary as Binary +import Data.Binary.VersionTagged +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Word (Word64) +import GHC.Generics (Generic) +import Stack.Types.PackageIdentifier + +data PackageCache = PackageCache + { pcOffset :: !Int64 + -- ^ offset in bytes into the 00-index.tar file for the .cabal file contents + , pcSize :: !Int64 + -- ^ size in bytes of the .cabal file + , pcDownload :: !(Maybe PackageDownload) + } + deriving (Generic) + +instance Binary PackageCache +instance NFData PackageCache +instance HasStructuralInfo PackageCache + +newtype PackageCacheMap = PackageCacheMap (Map PackageIdentifier PackageCache) + deriving (Generic, Binary, NFData) +instance HasStructuralInfo PackageCacheMap +instance HasSemanticVersion PackageCacheMap + +data PackageDownload = PackageDownload + { pdSHA512 :: !ByteString + , pdUrl :: !ByteString + , pdSize :: !Word64 + } + deriving (Show, Generic) +instance Binary.Binary PackageDownload +instance HasStructuralInfo PackageDownload +instance NFData PackageDownload +instance FromJSON PackageDownload where + parseJSON = withObject "Package" $ \o -> do + hashes <- o .: "package-hashes" + sha512 <- maybe mzero return (Map.lookup ("SHA512" :: Text) hashes) + locs <- o .: "package-locations" + url <- + case reverse locs of + [] -> mzero + x:_ -> return x + size <- o .: "package-size" + return PackageDownload + { pdSHA512 = encodeUtf8 sha512 + , pdUrl = encodeUtf8 url + , pdSize = size + } diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -37,6 +37,7 @@ import Data.Char (isLetter) import Data.Data import Data.Hashable +import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as Map import Data.Text (Text) @@ -88,14 +89,13 @@ -- | Attoparsec parser for a package name from bytestring. packageNameParser :: Parser PackageName packageNameParser = - fmap (PackageName . S8.pack) - (appending (many1 (satisfy isAlphaNum)) - (concating (many (alternating - (pured (satisfy isAlphaNum)) - (appending (pured (satisfy (== '-'))) - (pured (satisfy isLetter))))))) + fmap (PackageName . S8.pack . intercalate "-") + (sepBy1 word (char '-')) where - isAlphaNum c = isLetter c || isDigit c + word = concat <$> sequence [many digit, + pured letter, + many (alternating letter digit)] + letter = satisfy isLetter -- | Make a package name. mkPackageName :: String -> Q Exp diff --git a/src/Stack/Types/StackT.hs b/src/Stack/Types/StackT.hs --- a/src/Stack/Types/StackT.hs +++ b/src/Stack/Types/StackT.hs @@ -6,7 +6,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -20,6 +19,8 @@ ,runStackTGlobal ,runStackLoggingT ,runStackLoggingTGlobal + ,runInnerStackT + ,runInnerStackLoggingT ,newTLSManager ,logSticky ,logStickyDone) @@ -166,6 +167,24 @@ instance HasSupportsUnicode LoggingEnv where getSupportsUnicode = lenvSupportsUnicode +runInnerStackT :: (HasHttpManager r, HasLogLevel r, HasTerminal r, HasReExec r, MonadReader r m, MonadIO m) + => config -> StackT config IO a -> m a +runInnerStackT config inner = do + manager <- asks getHttpManager + logLevel <- asks getLogLevel + terminal <- asks getTerminal + reExec <- asks getReExec + liftIO $ runStackT manager logLevel config terminal reExec inner + +runInnerStackLoggingT :: (HasHttpManager r, HasLogLevel r, HasTerminal r, HasReExec r, MonadReader r m, MonadIO m) + => StackLoggingT IO a -> m a +runInnerStackLoggingT inner = do + manager <- asks getHttpManager + logLevel <- asks getLogLevel + terminal <- asks getTerminal + reExec <- asks getReExec + liftIO $ runStackLoggingT manager logLevel terminal reExec inner + -- | Run the logging monad, using global options. runStackLoggingTGlobal :: MonadIO m => Manager -> GlobalOpts -> StackLoggingT m a -> m a @@ -275,16 +294,18 @@ T.hPutStrLn outputChannel out)) where outputChannel = stderr getOutput maxLogLevel = - do date <- getDate + do timestamp <- getTimestamp l <- getLevel lc <- getLoc - return (T.pack date <> T.pack l <> T.decodeUtf8 (fromLogStr (toLogStr msg)) <> T.pack lc) - where getDate + return (T.pack timestamp <> T.pack l <> T.decodeUtf8 (fromLogStr (toLogStr msg)) <> T.pack lc) + where getTimestamp | maxLogLevel <= LevelDebug = - do now <- getCurrentTime - return (formatTime defaultTimeLocale "%Y-%m-%d %T%Q" now ++ - ": ") + do now <- getZonedTime + return (formatTime' now ++ ": ") | otherwise = return "" + where + formatTime' = + take timestampLength . formatTime defaultTimeLocale "%F %T.%q" getLevel | maxLogLevel <= LevelDebug = return ("[" ++ @@ -308,10 +329,16 @@ where line = show . fst . loc_start char = show . snd . loc_start +-- | The length of a timestamp in the format "YYYY-MM-DD hh:mm:ss.μμμμμμ". +-- This definition is top-level in order to avoid multiple reevaluation at runtime. +timestampLength :: Int +timestampLength = + length (formatTime defaultTimeLocale "%F %T.000000" (UTCTime (ModifiedJulianDay 0) 0)) + -- | With a sticky state, do the thing. withSticky :: (MonadIO m) => Bool -> (Sticky -> m b) -> m b -withSticky terminal m = do +withSticky terminal m = if terminal then do state <- liftIO (newMVar Nothing) originalMode <- liftIO (hGetBuffering stdout) diff --git a/src/Stack/Types/TemplateName.hs b/src/Stack/Types/TemplateName.hs --- a/src/Stack/Types/TemplateName.hs +++ b/src/Stack/Types/TemplateName.hs @@ -15,12 +15,12 @@ import Path import Path.Internal --- | A template name of the format @foo.hsfiles@. -data TemplateName = TemplateName !Text !(Path Rel File) +-- | A template name. +data TemplateName = TemplateName !Text !(Either (Path Abs File) (Path Rel File)) deriving (Ord,Eq,Show) -- | An argument which accepts a template name of the format --- @foo.hsfiles@ or @foo@, ultimately normalized to @foo.hsfiles@. +-- @foo.hsfiles@ or @foo@, ultimately normalized to @foo@. templateNameArgument :: O.Mod O.ArgumentFields TemplateName -> O.Parser TemplateName templateNameArgument = @@ -51,8 +51,11 @@ where parseValidFile prefix str = case parseRelFile str of - Nothing -> Left expected - Just fp -> return (TemplateName prefix fp) + Nothing -> + case parseAbsFile str of + Nothing -> Left expected + Just fp -> return (TemplateName prefix (Left fp)) + Just fp -> return (TemplateName prefix (Right fp)) expected = "Expected a template filename like: foo or foo.hsfiles" -- | Make a template name. @@ -60,13 +63,17 @@ mkTemplateName s = case parseTemplateNameFromString s of Left{} -> error ("Invalid template name: " ++ show s) - Right (TemplateName (T.unpack -> prefix) (Path pn)) -> - [|TemplateName (T.pack prefix) (Path pn)|] + Right (TemplateName (T.unpack -> prefix) p) -> + [|TemplateName (T.pack prefix) $(pn)|] + where pn = + case p of + Left (Path fp) -> [|Left (Path fp)|] + Right (Path fp) -> [|Right (Path fp)|] -- | Get a text representation of the template name. templateName :: TemplateName -> Text templateName (TemplateName prefix _) = prefix -- | Get the path of the template. -templatePath :: TemplateName -> Path Rel File +templatePath :: TemplateName -> Either (Path Abs File) (Path Rel File) templatePath (TemplateName _ fp) = fp diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -16,7 +16,7 @@ import qualified Data.Set as Set import qualified Data.Text as T import Development.GitRev (gitHash) -import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager) +import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Path.IO import qualified Paths_stack as Paths @@ -42,7 +42,7 @@ Just repo -> do remote <- liftIO $ readProcess "git" ["ls-remote", repo, "master"] [] let latestCommit = head . words $ remote - if (latestCommit == $gitHash) then do + if latestCommit == $gitHash then do $logInfo "Already up-to-date, no upgrade required" return Nothing else do $logInfo "Cloning stack" @@ -80,25 +80,20 @@ Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found" Just path -> return $ Just path - manager <- asks getHttpManager - logLevel <- asks getLogLevel - terminal <- asks getTerminal - reExec <- asks getReExec config <- asks getConfig - - forM_ mdir $ \dir -> liftIO $ do - bconfig <- runStackLoggingT manager logLevel terminal reExec $ do + forM_ mdir $ \dir -> do + bconfig <- runInnerStackLoggingT $ do lc <- loadConfig (configConfigMonoid config <> Data.Monoid.mempty { configMonoidInstallGHC = Just True }) (Just $ dir $(mkRelFile "stack.yaml")) - lcLoadBuildConfig lc mresolver - envConfig1 <- runStackT manager logLevel bconfig terminal reExec $ setupEnv $ Just $ + lcLoadBuildConfig lc mresolver Nothing + envConfig1 <- runInnerStackT bconfig $ setupEnv $ Just $ "Try rerunning with --install-ghc to install the correct GHC into " <> T.pack (toFilePath (configLocalPrograms config)) - runStackT manager logLevel envConfig1 terminal reExec $ - build (const $ return ()) Nothing defaultBuildOpts - { boptsTargets = ["stack"] - , boptsInstallExes = True - } + runInnerStackT envConfig1 $ + build (const $ return ()) Nothing defaultBuildOpts + { boptsTargets = ["stack"] + , boptsInstallExes = True + } diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -30,7 +30,7 @@ import Control.Applicative import Control.Exception (bracket) import qualified Control.Exception as E -import Control.Monad (when) +import Control.Monad (when, unless) import Data.Aeson (FromJSON (..), ToJSON (..), eitherDecode', encode, @@ -211,7 +211,7 @@ putStrLn "authentication failure" cfp <- credsFile config handleIO (const $ return ()) (removeFile cfp) - error $ "Authentication failure uploading to server" + error "Authentication failure uploading to server" 403 -> do putStrLn "forbidden upload" putStrLn "Usually means: you've already uploaded this package/version combination" @@ -234,7 +234,7 @@ where loop = do bs <- brRead $ responseBody res - when (not $ S.null bs) $ do + unless (S.null bs) $ do S.hPut stdout bs loop diff --git a/src/System/Process/Log.hs b/src/System/Process/Log.hs --- a/src/System/Process/Log.hs +++ b/src/System/Process/Log.hs @@ -27,7 +27,7 @@ -- | Show a process arg including speechmarks when necessary. Just for -- debugging purposes, not functionally important. -showProcessArgDebug :: [Char] -> Text +showProcessArgDebug :: String -> Text showProcessArgDebug x | any special x = T.pack (show x) | otherwise = T.pack x diff --git a/src/System/Process/PagerEditor.hs b/src/System/Process/PagerEditor.hs --- a/src/System/Process/PagerEditor.hs +++ b/src/System/Process/PagerEditor.hs @@ -97,11 +97,11 @@ -- | Run editor on a ByteString. editByteString :: String -> ByteString -> IO ByteString -editByteString f s = editReaderWriter f (flip hPut s) Data.ByteString.Lazy.readFile +editByteString f s = editReaderWriter f (`hPut` s) Data.ByteString.Lazy.readFile -- | Run editor on a String. editString :: String -> String -> IO String -editString f s = editReaderWriter f (flip hPutStr s) System.IO.readFile +editString f s = editReaderWriter f (`hPutStr` s) System.IO.readFile -- | Short-circuit first Just. orElse :: (Monad m) => m (Maybe a) -> m (Maybe a) -> m (Maybe a) diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs --- a/src/System/Process/Read.hs +++ b/src/System/Process/Read.hs @@ -53,7 +53,7 @@ import Data.IORef import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (isJust) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T @@ -71,25 +71,25 @@ import qualified System.FilePath as FP import System.Process.Log --- | Override the environment received by a child process +-- | Override the environment received by a child process. data EnvOverride = EnvOverride - { eoTextMap :: Map Text Text - , eoStringList :: [(String, String)] - , eoPath :: [FilePath] + { eoTextMap :: Map Text Text -- ^ Environment variables as map + , eoStringList :: [(String, String)] -- ^ Environment variables as association list + , eoPath :: [FilePath] -- ^ List of directories searched for executables (@PATH@) , eoExeCache :: IORef (Map FilePath (Either ReadProcessException (Path Abs File))) - , eoExeExtension :: String + , eoExeExtension :: String -- ^ @""@ or @".exe"@, depending on the platform , eoPlatform :: Platform } --- | Get the environment variables from @EnvOverride@ +-- | Get the environment variables from an 'EnvOverride'. unEnvOverride :: EnvOverride -> Map Text Text unEnvOverride = eoTextMap --- | Get the list of directories searched +-- | Get the list of directories searched (@PATH@). envSearchPath :: EnvOverride -> [FilePath] envSearchPath = eoPath --- | Modify an EnvOverride +-- | Modify the environment variables of an 'EnvOverride'. modifyEnvOverride :: MonadIO m => EnvOverride -> (Map Text Text -> Map Text Text) @@ -98,7 +98,7 @@ (eoPlatform eo) (f $ eoTextMap eo) --- | Create a new @EnvOverride@ +-- | Create a new 'EnvOverride'. mkEnvOverride :: MonadIO m => Platform -> Map Text Text @@ -126,16 +126,16 @@ Platform _ Windows -> True _ -> False --- | Helper conversion function +-- | Helper conversion function. envHelper :: EnvOverride -> Maybe [(String, String)] envHelper = Just . eoStringList -- | Read from the process, ignoring any output. readProcessNull :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => Maybe (Path Abs Dir) + => Maybe (Path Abs Dir) -- ^ Optional working directory -> EnvOverride - -> String - -> [String] + -> String -- ^ Command + -> [String] -- ^ Command line arguments -> m () readProcessNull wd menv name args = sinkProcessStdout wd menv name args CL.sinkNull @@ -143,11 +143,11 @@ -- | Run the given command in the given directory. If it exits with anything -- but success, prints an error and then calls 'exitWith' to exit the program. readInNull :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => Path Abs Dir -- ^ directory to run in - -> FilePath -- ^ command to run + => Path Abs Dir -- ^ Directory to run in + -> FilePath -- ^ Command to run -> EnvOverride - -> [String] -- ^ command line arguments - -> Maybe Text + -> [String] -- ^ Command line arguments + -> Maybe Text -- ^ Optional additional error message -> m () readInNull wd cmd menv args errMsg = do result <- try (readProcessNull (Just wd) menv cmd args) @@ -169,27 +169,28 @@ -- | Try to produce a strict 'S.ByteString' from the stdout of a -- process. tryProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => Maybe (Path Abs Dir) + => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride - -> String - -> [String] + -> String -- ^ Command + -> [String] -- ^ Command line arguments -> m (Either ReadProcessException S.ByteString) tryProcessStdout wd menv name args = try (readProcessStdout wd menv name args) --- | Produce a strict 'S.ByteString' from the stdout of a --- process. Throws a 'ProcessExitedUnsuccessfully' exception if the --- process fails. +-- | Produce a strict 'S.ByteString' from the stdout of a process. +-- +-- Throws a 'ProcessExitedUnsuccessfully' exception if the process fails. readProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => Maybe (Path Abs Dir) + => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride - -> String - -> [String] + -> String -- ^ Command + -> [String] -- ^ Command line arguments -> m S.ByteString readProcessStdout wd menv name args = sinkProcessStdout wd menv name args CL.consume >>= liftIO . evaluate . S.concat +-- | An exception while trying to read from process. data ReadProcessException = ReadProcessException CreateProcess ExitCode L.ByteString L.ByteString | NoPathFound @@ -230,10 +231,10 @@ -- lots of output; for that use 'sinkProcessStdoutLogStderr'. sinkProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => Maybe (Path Abs Dir) + => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride - -> String - -> [String] + -> String -- ^ Command + -> [String] -- ^ Command line arguments -> Sink S.ByteString IO a -- ^ Sink for stdout -> m a sinkProcessStdout wd menv name args sinkStdout = do @@ -261,10 +262,10 @@ -- | Consume the stdout and stderr of a process feeding strict 'S.ByteString's to the consumers. sinkProcessStderrStdout :: (MonadIO m, MonadLogger m) - => Maybe (Path Abs Dir) + => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride - -> String - -> [String] + -> String -- ^ Command + -> [String] -- ^ Command line arguments -> Sink S.ByteString IO e -- ^ Sink for stderr -> Sink S.ByteString IO o -- ^ Sink for stdout -> m (e,o) @@ -283,13 +284,17 @@ -- | Perform pre-call-process tasks. Ensure the working directory exists and find the -- executable path. -preProcess :: (MonadIO m) => Maybe (Path Abs Dir) -> EnvOverride -> String -> m FilePath +preProcess :: (MonadIO m) + => Maybe (Path Abs Dir) -- ^ Optional directory to create if necessary + -> EnvOverride + -> String -- ^ Command name + -> m FilePath preProcess wd menv name = do name' <- liftIO $ liftM toFilePath $ join $ findExecutable menv name maybe (return ()) createTree wd return name' --- | Check if the given executable exists on the given PATH +-- | Check if the given executable exists on the given PATH. doesExecutableExist :: MonadIO m => EnvOverride -> String -> m Bool doesExecutableExist menv name = liftM isJust $ findExecutable menv name @@ -304,7 +309,9 @@ | FP.isRelative path = fmap (FP. path) getCurrentDirectory | otherwise = return path --- | Find the complete path for the executable +-- | Find the complete path for the executable. +-- +-- Throws a 'ReadProcessException' if unsuccessful. findExecutable :: (MonadIO m, MonadThrow n) => EnvOverride -> String -> m (n (Path Abs File)) findExecutable _ name | any FP.isPathSeparator name = do exists <- liftIO $ doesFileExist name @@ -340,7 +347,7 @@ return epath return $ either throwM return epath --- | Load up an EnvOverride from the standard environment +-- | Load up an 'EnvOverride' from the standard environment. getEnvOverride :: MonadIO m => Platform -> m EnvOverride getEnvOverride platform = liftIO $ @@ -348,17 +355,12 @@ mkEnvOverride platform . Map.fromList . map (T.pack *** T.pack) --- | Augment the PATH environment variable with the given extra paths +-- | Augment the PATH environment variable with the given extra paths. augmentPath :: [FilePath] -> Maybe Text -> Text augmentPath dirs mpath = T.intercalate (T.singleton FP.searchPathSeparator) - $ map (stripTrailingSlashT . T.pack) dirs + $ map (T.pack . FP.dropTrailingPathSeparator) dirs ++ maybe [] return mpath - -stripTrailingSlashT :: Text -> Text -stripTrailingSlashT t = fromMaybe t $ T.stripSuffix - (T.singleton FP.pathSeparator) - t -- | Apply 'augmentPath' on the PATH value in the given Map. augmentPathMap :: [FilePath] -> Map Text Text -> Map Text Text diff --git a/src/System/Process/Run.hs b/src/System/Process/Run.hs --- a/src/System/Process/Run.hs +++ b/src/System/Process/Run.hs @@ -6,7 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} --- | Reading from external processes. +-- | Run sub-processes. module System.Process.Run (runIn @@ -29,8 +29,9 @@ import qualified System.Process import System.Process.Read --- | Run the given command in the given directory, inheriting stdout --- and stderr. If it exits with anything but success, prints an error +-- | Run the given command in the given directory, inheriting stdout and stderr. +-- +-- If it exits with anything but success, prints an error -- and then calls 'exitWith' to exit the program. runIn :: forall (m :: * -> *). (MonadLogger m,MonadIO m,MonadBaseControl IO m) @@ -38,7 +39,7 @@ -> FilePath -- ^ command to run -> EnvOverride -> [String] -- ^ command line arguments - -> Maybe Text + -> Maybe Text -- ^ optional additional error message -> m () runIn wd cmd menv args errMsg = do result <- try (callProcess (Just wd) menv cmd args) @@ -57,27 +58,31 @@ liftIO (exitWith ec) Right () -> return () --- | Like as @System.Process.callProcess@, but takes an optional working directory and --- environment override, and throws ProcessExitedUnsuccessfully if the --- process exits unsuccessfully. Inherits stdout and stderr. +-- | Like 'System.Process.callProcess', but takes an optional working directory and +-- environment override, and throws 'ProcessExitedUnsuccessfully' if the +-- process exits unsuccessfully. +-- +-- Inherits stdout and stderr. callProcess :: (MonadIO m, MonadLogger m) - => Maybe (Path Abs Dir) + => Maybe (Path Abs Dir) -- ^ optional directory to run in -> EnvOverride - -> String - -> [String] + -> String -- ^ command to run + -> [String] -- ^ command line arguments -> m () callProcess = callProcess' id --- | Like as @System.Process.callProcess@, but takes an optional working directory and --- environment override, and throws ProcessExitedUnsuccessfully if the --- process exits unsuccessfully. Inherits stdout and stderr. +-- | Like 'System.Process.callProcess', but takes an optional working directory and +-- environment override, and throws 'ProcessExitedUnsuccessfully' if the +-- process exits unsuccessfully. +-- +-- Inherits stdout and stderr. callProcess' :: (MonadIO m, MonadLogger m) => (CreateProcess -> CreateProcess) - -> Maybe (Path Abs Dir) + -> Maybe (Path Abs Dir) -- ^ optional directory to run in -> EnvOverride - -> String - -> [String] + -> String -- ^ command to run + -> [String] -- ^ command line arguments -> m () callProcess' modCP wd menv cmd0 args = do cmd <- preProcess wd menv cmd0 diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -25,6 +25,7 @@ import qualified Data.Map as Map import qualified Data.Map.Strict as M import Data.Maybe +import Data.Maybe.Extra (mapMaybeA) import Data.Monoid import qualified Data.Set as Set import Data.Text (Text) @@ -33,28 +34,35 @@ import Data.Traversable import Data.Typeable (Typeable) import Data.Version (showVersion) +import Development.GitRev (gitCommitCount) import Distribution.System (buildArch) import Distribution.Text (display) -import Development.GitRev (gitCommitCount) import GHC.IO.Encoding (mkTextEncoding, textEncodingName) import Network.HTTP.Client +import Options.Applicative import Options.Applicative.Args import Options.Applicative.Builder.Extra -import Options.Applicative.Simple +import Options.Applicative.Complicated +import Options.Applicative.Simple (simpleVersion) import Options.Applicative.Types (readerAsk) import Path +import Path.Extra (toFilePathNoTrailingSep) import Path.IO import qualified Paths_stack as Meta import Prelude hiding (pi, mapM) import Stack.Build -import Stack.Types.Build +import Stack.Clean (CleanOpts, clean) import Stack.Config +import Stack.ConfigCmd as ConfigCmd import Stack.Constants +import Stack.Coverage import qualified Stack.Docker as Docker import Stack.Dot import Stack.Exec import Stack.Fetch import Stack.FileWatch +import Stack.GhcPkg (getGlobalDB, mkGhcPackagePath) +import Stack.Ghci import Stack.Ide import qualified Stack.Image as Image import Stack.Init @@ -62,8 +70,6 @@ import Stack.Options import Stack.Package (getCabalFileName) import qualified Stack.PackageIndex -import Stack.Ghci -import Stack.GhcPkg (getGlobalDB, mkGhcPackagePath) import Stack.SDist (getSDistTarball) import Stack.Setup import Stack.Solver (solveExtraDeps) @@ -76,7 +82,7 @@ import System.Environment (getEnvironment, getProgName) import System.Exit import System.FileLock (lockFile, tryLockFile, unlockFile, SharedExclusive(Exclusive), FileLock) -import System.FilePath (dropTrailingPathSeparator, searchPathSeparator) +import System.FilePath (searchPathSeparator) import System.IO (hIsTerminalDevice, stderr, stdin, stdout, hSetBuffering, BufferMode(..), hPutStrLn, Handle, hGetEncoding, hSetEncoding) import System.Process.Read @@ -106,151 +112,182 @@ isTerminal <- hIsTerminalDevice stdout execExtraHelp args dockerHelpOptName - (dockerOptsParser True) + (dockerOptsParser False) ("Only showing --" ++ Docker.dockerCmdName ++ "* options.") - let versionString' = concat $ concat + let commitCount = $gitCommitCount + versionString' = concat $ concat [ [$(simpleVersion Meta.version)] -- Leave out number of commits for --depth=1 clone -- See https://github.com/commercialhaskell/stack/issues/792 - , [" (" ++ $gitCommitCount ++ " commits)" | $gitCommitCount /= ("1"::String) && - $gitCommitCount /= ("UNKNOWN" :: String)] + , [" (" ++ commitCount ++ " commits)" | commitCount /= ("1"::String) && + commitCount /= ("UNKNOWN" :: String)] , [" ", display buildArch] ] - let numericVersion :: Parser (a -> a) - numericVersion = - infoOption - (showVersion Meta.version) - (long "numeric-version" <> - help "Show only version number") - + let globalOpts hide = + extraHelpOption hide progName (Docker.dockerCmdName ++ "*") dockerHelpOptName <*> + globalOptsParser hide + addCommand' cmd title footerStr constr = + addCommand cmd title footerStr constr (globalOpts True) + addSubCommands' cmd title footerStr = + addSubCommands cmd title footerStr (globalOpts True) eGlobalRun <- try $ - simpleOptions - versionString' + complicatedOptions + Meta.version + (Just versionString') "stack - The Haskell Tool Stack" "" - (numericVersion <*> extraHelpOption progName (Docker.dockerCmdName ++ "*") dockerHelpOptName <*> - globalOptsParser isTerminal) - (do addCommand "build" - "Build the project(s) in this directory/configuration" + (globalOpts False) + (do addCommand' "build" + "Build the package(s) in this directory/configuration" + cmdFooter buildCmd (buildOptsParser Build) - addCommand "install" + addCommand' "install" "Shortcut for 'build --copy-bins'" + cmdFooter buildCmd (buildOptsParser Install) - addCommand "uninstall" + addCommand' "uninstall" "DEPRECATED: This command performs no actions, and is present for documentation only" + cmdFooter uninstallCmd (many $ strArgument $ metavar "IGNORED") - addCommand "test" + addCommand' "test" "Shortcut for 'build --test'" + cmdFooter buildCmd (buildOptsParser Test) - addCommand "bench" + addCommand' "bench" "Shortcut for 'build --bench'" + cmdFooter buildCmd (buildOptsParser Bench) - addCommand "haddock" + addCommand' "haddock" "Shortcut for 'build --haddock'" + cmdFooter buildCmd (buildOptsParser Haddock) - addCommand "new" + addCommand' "new" "Create a new project from a template. Run `stack templates' to see available templates." + cmdFooter newCmd newOptsParser - addCommand "templates" + addCommand' "templates" "List the templates available for `stack new'." + cmdFooter templatesCmd (pure ()) - addCommand "init" + addCommand' "init" "Initialize a stack project based on one or more cabal packages" + cmdFooter initCmd initOptsParser - addCommand "solver" + addCommand' "solver" "Use a dependency solver to try and determine missing extra-deps" + cmdFooter solverCmd solverOptsParser - addCommand "setup" + addCommand' "setup" "Get the appropriate GHC for your project" + cmdFooter setupCmd setupParser - addCommand "path" + addCommand' "path" "Print out handy path information" + cmdFooter pathCmd - (fmap - catMaybes - (sequenceA - (map - (\(desc,name,_) -> - flag Nothing - (Just name) - (long (T.unpack name) <> - help desc)) - paths))) - addCommand "unpack" + (mapMaybeA + (\(desc,name,_) -> + flag Nothing + (Just name) + (long (T.unpack name) <> + help desc)) + paths) + addCommand' "unpack" "Unpack one or more packages locally" + cmdFooter unpackCmd (some $ strArgument $ metavar "PACKAGE") - addCommand "update" + addCommand' "update" "Update the package index" + cmdFooter updateCmd (pure ()) - addCommand "upgrade" + addCommand' "upgrade" "Upgrade to the latest stack (experimental)" + cmdFooter upgradeCmd - ((,) <$> (switch + ((,) <$> switch ( long "git" - <> help "Clone from Git instead of downloading from Hackage (more dangerous)" - )) - <*> (strOption + <> help "Clone from Git instead of downloading from Hackage (more dangerous)" ) + <*> strOption ( long "git-repo" <> help "Clone from specified git repository" <> value "https://github.com/commercialhaskell/stack" - <> showDefault - ))) - addCommand "upload" + <> showDefault )) + addCommand' "upload" "Upload a package to Hackage" + cmdFooter uploadCmd ((,) - <$> (many $ strArgument $ metavar "TARBALL/DIR") + <$> many (strArgument $ metavar "TARBALL/DIR") <*> optional pvpBoundsOption) - addCommand "sdist" + addCommand' "sdist" "Create source distribution tarballs" + cmdFooter sdistCmd ((,) - <$> (many $ strArgument $ metavar "DIR") + <$> many (strArgument $ metavar "DIR") <*> optional pvpBoundsOption) - addCommand "dot" + addCommand' "dot" "Visualize your project's dependency graph using Graphviz dot" + cmdFooter dotCmd dotOptsParser - addCommand "exec" + addCommand' "exec" "Execute a command" + cmdFooter execCmd (execOptsParser Nothing) - addCommand "ghc" + addCommand' "ghc" "Run ghc" + cmdFooter execCmd - (execOptsParser $ Just "ghc") - addCommand "ghci" - "Run ghci in the context of project(s) (experimental)" + (execOptsParser $ Just ExecGhc) + addCommand' "ghci" + "Run ghci in the context of package(s) (experimental)" + cmdFooter ghciCmd ghciOptsParser - addCommand "runghc" + addCommand' "repl" + "Run ghci in the context of package(s) (experimental) (alias for 'ghci')" + cmdFooter + ghciCmd + ghciOptsParser + addCommand' "runghc" "Run runghc" + cmdFooter execCmd - (execOptsParser $ Just "runghc") - addCommand "eval" + (execOptsParser $ Just ExecRunGhc) + addCommand' "runhaskell" + "Run runghc (alias for 'runghc')" + cmdFooter + execCmd + (execOptsParser $ Just ExecRunGhc) + addCommand' "eval" "Evaluate some haskell code inline. Shortcut for 'stack exec ghc -- -e CODE'" + cmdFooter evalCmd - (evalOptsParser $ Just "CODE") -- metavar = "CODE" - addCommand "clean" + (evalOptsParser "CODE") + addCommand' "clean" "Clean the local packages" + cmdFooter cleanCmd - (pure ()) - addCommand "list-dependencies" + cleanOptsParser + addCommand' "list-dependencies" "List the dependencies" + cmdFooter listDependenciesCmd (textOption (long "separator" <> metavar "SEP" <> @@ -258,16 +295,19 @@ "and package version.") <> value " " <> showDefault)) - addCommand "query" + addCommand' "query" "Query general build information (experimental)" + cmdFooter queryCmd (many $ strArgument $ metavar "SELECTOR...") - addSubCommands + addSubCommands' "ide" "IDE-specific commands" - (do addCommand + cmdFooter + (do addCommand' "start" "Start the ide-backend service" + cmdFooter ideCmd ((,) <$> many (textArgument (metavar "TARGET" <> @@ -277,40 +317,69 @@ metavar "OPTION" <> help "Additional options passed to GHCi" <> value [])) - addCommand + addCommand' "packages" "List all available local loadable packages" + cmdFooter packagesCmd (pure ()) - addCommand + addCommand' "load-targets" "List all load targets for a package target" + cmdFooter targetsCmd (textArgument (metavar "TARGET"))) - addSubCommands + addSubCommands' Docker.dockerCmdName "Subcommands specific to Docker use" - (do addCommand Docker.dockerPullCmdName + cmdFooter + (do addCommand' Docker.dockerPullCmdName "Pull latest version of Docker image from registry" + cmdFooter dockerPullCmd (pure ()) - addCommand "reset" + addCommand' "reset" "Reset the Docker sandbox" + cmdFooter dockerResetCmd - (flag False True (long "keep-home" <> - help "Do not delete sandbox's home directory")) - addCommand Docker.dockerCleanupCmdName + (switch (long "keep-home" <> + help "Do not delete sandbox's home directory")) + addCommand' Docker.dockerCleanupCmdName "Clean up Docker images and containers" + cmdFooter dockerCleanupCmd dockerCleanupOptsParser) - addSubCommands + addSubCommands' + ConfigCmd.cfgCmdName + "Subcommands specific to modifying stack.yaml files" + cmdFooter + (addCommand' ConfigCmd.cfgCmdSetName + "Sets a field in the project's stack.yaml to value" + cmdFooter + cfgSetCmd + configCmdSetParser) + addSubCommands' Image.imgCmdName "Subcommands specific to imaging (EXPERIMENTAL)" - (addCommand Image.imgDockerCmdName + cmdFooter + (addCommand' Image.imgDockerCmdName "Build a Docker image for the project" + cmdFooter imgDockerCmd - (pure ()))) + (boolFlags True + "build" + "building the project before creating the container" + idm)) + addSubCommands' + "hpc" + "Subcommands specific to Haskell Program Coverage" + cmdFooter + (addCommand' "report" + "Generate HPC report a combined HPC report" + cmdFooter + hpcReportCmd + hpcReportOptsParser)) case eGlobalRun of Left (exitCode :: ExitCode) -> do when isInterpreter $ @@ -322,14 +391,15 @@ , " [options] runghc [options]' comment is required." , "\nSee https://github.com/commercialhaskell/stack/blob/release/doc/GUIDE.md#ghcrunghc" ] throwIO exitCode - Right (global,run) -> do + Right (globalMonoid,run) -> do + let global = globalOptsFromMonoid isTerminal globalMonoid when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString' case globalReExecVersion global of Just expectVersion | expectVersion /= showVersion Meta.version -> throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version) _ -> return () - run global `catch` \e -> do + run global `catch` \e -> -- This special handler stops "stack: " from being printed before the -- exception case fromException e of @@ -339,6 +409,7 @@ exitFailure where dockerHelpOptName = Docker.dockerCmdName ++ "-help" + cmdFooter = "Run 'stack --help' for global options that apply to all subcommands." -- | Print out useful path information in a human-readable format (and -- support others later). @@ -349,20 +420,31 @@ (do env <- ask let cfg = envConfig env bc = envConfigBuildConfig cfg + -- This is the modified 'bin-path', + -- including the local GHC or MSYS if not configured to operate on + -- global GHC. + -- It was set up in 'withBuildConfigAndLock -> withBuildConfigExt -> setupEnv'. + -- So it's not the *minimal* override path. menv <- getMinimalEnvOverride snap <- packageDatabaseDeps local <- packageDatabaseLocal + extra <- packageDatabaseExtra global <- getGlobalDB menv =<< getWhichCompiler snaproot <- installationRootDeps localroot <- installationRootLocal distDir <- distRelativeDir + hpcDir <- hpcReportDir forM_ + -- filter the chosen paths in flags (keys), + -- or show all of them if no specific paths chosen. (filter (\(_,key,_) -> null keys || elem key keys) paths) (\(_,key,path) -> liftIO $ T.putStrLn + -- If a single path type is requested, output it directly. + -- Otherwise, name all the paths. ((if length keys == 1 then "" else key <> ": ") <> @@ -375,18 +457,22 @@ global snaproot localroot - distDir)))) + distDir + hpcDir + extra)))) -- | Passed to all the path printers as a source of info. data PathInfo = PathInfo - {piBuildConfig :: BuildConfig - ,piEnvOverride :: EnvOverride - ,piSnapDb :: Path Abs Dir - ,piLocalDb :: Path Abs Dir - ,piGlobalDb :: Path Abs Dir - ,piSnapRoot :: Path Abs Dir - ,piLocalRoot :: Path Abs Dir - ,piDistDir :: Path Rel Dir + { piBuildConfig :: BuildConfig + , piEnvOverride :: EnvOverride + , piSnapDb :: Path Abs Dir + , piLocalDb :: Path Abs Dir + , piGlobalDb :: Path Abs Dir + , piSnapRoot :: Path Abs Dir + , piLocalRoot :: Path Abs Dir + , piDistDir :: Path Rel Dir + , piHpcDir :: Path Abs Dir + , piExtraDbs :: [Path Abs Dir] } -- | The paths of interest to a user. The first tuple string is used @@ -402,86 +488,70 @@ paths = [ ( "Global stack root directory" , "global-stack-root" - , \pi -> - T.pack (toFilePathNoTrailing (configStackRoot (bcConfig (piBuildConfig pi))))) + , T.pack . toFilePathNoTrailingSep . configStackRoot . bcConfig . piBuildConfig ) , ( "Project root (derived from stack.yaml file)" , "project-root" - , \pi -> - T.pack (toFilePathNoTrailing (bcRoot (piBuildConfig pi)))) + , T.pack . toFilePathNoTrailingSep . bcRoot . piBuildConfig ) , ( "Configuration location (where the stack.yaml file is)" , "config-location" - , \pi -> - T.pack (toFilePathNoTrailing (bcStackYaml (piBuildConfig pi)))) + , T.pack . toFilePath . bcStackYaml . piBuildConfig ) , ( "PATH environment variable" , "bin-path" - , \pi -> - T.pack (intercalate [searchPathSeparator] (eoPath (piEnvOverride pi)))) + , T.pack . intercalate [searchPathSeparator] . eoPath . piEnvOverride ) , ( "Installed GHCs (unpacked and archives)" , "ghc-paths" - , \pi -> - T.pack (toFilePathNoTrailing (configLocalPrograms (bcConfig (piBuildConfig pi))))) + , T.pack . toFilePathNoTrailingSep . configLocalPrograms . bcConfig . piBuildConfig ) , ( "Local bin path where stack installs executables" , "local-bin-path" - , \pi -> - T.pack (toFilePathNoTrailing (configLocalBin (bcConfig (piBuildConfig pi))))) + , T.pack . toFilePathNoTrailingSep . configLocalBin . bcConfig . piBuildConfig ) , ( "Extra include directories" , "extra-include-dirs" - , \pi -> - T.intercalate - ", " - (Set.elems (configExtraIncludeDirs (bcConfig (piBuildConfig pi))))) + , T.intercalate ", " . Set.elems . configExtraIncludeDirs . bcConfig . piBuildConfig ) , ( "Extra library directories" , "extra-library-dirs" - , \pi -> - T.intercalate ", " (Set.elems (configExtraLibDirs (bcConfig (piBuildConfig pi))))) + , T.intercalate ", " . Set.elems . configExtraLibDirs . bcConfig . piBuildConfig ) , ( "Snapshot package database" , "snapshot-pkg-db" - , \pi -> - T.pack (toFilePathNoTrailing (piSnapDb pi))) + , T.pack . toFilePathNoTrailingSep . piSnapDb ) , ( "Local project package database" , "local-pkg-db" - , \pi -> - T.pack (toFilePathNoTrailing (piLocalDb pi))) + , T.pack . toFilePathNoTrailingSep . piLocalDb ) , ( "Global package database" , "global-pkg-db" - , \pi -> - T.pack (toFilePathNoTrailing (piGlobalDb pi))) + , T.pack . toFilePathNoTrailingSep . piGlobalDb ) , ( "GHC_PACKAGE_PATH environment variable" , "ghc-package-path" - , \pi -> mkGhcPackagePath True (piLocalDb pi) (piSnapDb pi) (piGlobalDb pi)) + , \pi -> mkGhcPackagePath True (piLocalDb pi) (piSnapDb pi) (piExtraDbs pi) (piGlobalDb pi)) , ( "Snapshot installation root" , "snapshot-install-root" - , \pi -> - T.pack (toFilePathNoTrailing (piSnapRoot pi))) + , T.pack . toFilePathNoTrailingSep . piSnapRoot ) , ( "Local project installation root" , "local-install-root" - , \pi -> - T.pack (toFilePathNoTrailing (piLocalRoot pi))) + , T.pack . toFilePathNoTrailingSep . piLocalRoot ) , ( "Snapshot documentation root" , "snapshot-doc-root" - , \pi -> - T.pack (toFilePathNoTrailing (piSnapRoot pi docDirSuffix))) + , \pi -> T.pack (toFilePathNoTrailingSep (piSnapRoot pi docDirSuffix))) , ( "Local project documentation root" , "local-doc-root" - , \pi -> - T.pack (toFilePathNoTrailing (piLocalRoot pi docDirSuffix))) + , \pi -> T.pack (toFilePathNoTrailingSep (piLocalRoot pi docDirSuffix))) , ( "Dist work directory" , "dist-dir" - , \pi -> - T.pack (toFilePathNoTrailing (piDistDir pi)))] - where toFilePathNoTrailing = dropTrailingPathSeparator . toFilePath + , T.pack . toFilePathNoTrailingSep . piDistDir ) + , ( "Where HPC reports and tix files are stored" + , "local-hpc-root" + , T.pack . toFilePathNoTrailingSep . piHpcDir ) ] data SetupCmdOpts = SetupCmdOpts { scoCompilerVersion :: !(Maybe CompilerVersion) - , scoForceReinstall :: !Bool - , scoUpgradeCabal :: !Bool - , scoStackSetupYaml :: !String - , scoGHCBindistURL :: !(Maybe String) + , scoForceReinstall :: !Bool + , scoUpgradeCabal :: !Bool + , scoStackSetupYaml :: !String + , scoGHCBindistURL :: !(Maybe String) } setupParser :: Parser SetupCmdOpts setupParser = SetupCmdOpts - <$> (optional $ argument readVersion + <$> optional (argument readVersion (metavar "GHC_VERSION" <> help ("Version of GHC to install, e.g. 7.10.2. " ++ "The default is to install the version implied by the resolver."))) @@ -497,13 +567,11 @@ ( long "stack-setup-yaml" <> help "Location of the main stack-setup.yaml file" <> value defaultStackSetupYaml - <> showDefault - ) - <*> (optional $ strOption + <> showDefault ) + <*> optional (strOption (long "ghc-bindist" <> metavar "URL" - <> help "Alternate GHC binary distribution (requires custom --ghc-variant)" - )) + <> help "Alternate GHC binary distribution (requires custom --ghc-variant)")) where readVersion = do s <- readerAsk @@ -527,7 +595,7 @@ case scoCompilerVersion of Just v -> return (v, MatchMinor, Nothing) Nothing -> do - bc <- lcLoadBuildConfig lc globalResolver + bc <- lcLoadBuildConfig lc globalResolver globalCompiler return ( bcWantedCompiler bc , configCompilerCheck (lcConfig lc) , Just $ bcStackYaml bc @@ -537,8 +605,7 @@ ensureCompiler SetupOpts { soptsInstallIfMissing = True , soptsUseSystem = - (configSystemGHC $ lcConfig lc) - && not scoForceReinstall + configSystemGHC (lcConfig lc) && not scoForceReinstall , soptsWantedCompiler = wantedCompiler , soptsCompilerCheck = compilerCheck , soptsStackYaml = mstack @@ -592,7 +659,7 @@ -- Just in case of asynchronous exceptions, we need to be careful -- when using tryLockFile here: EL.bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive) - (\fstTry -> maybe (return ()) (liftIO . unlockFile) fstTry) + (maybe (return ()) (liftIO . unlockFile)) (\fstTry -> case fstTry of Just lk -> EL.finally (act $ Just lk) (liftIO $ unlockFile lk) @@ -625,7 +692,7 @@ -- For now the non-locking version just unlocks immediately. -- That is, there's still a serialization point. withBuildConfig :: GlobalOpts - -> (StackT EnvConfig IO ()) + -> StackT EnvConfig IO () -> IO () withBuildConfig go inner = withBuildConfigAndLock go (\lk -> do munlockFile lk @@ -672,7 +739,7 @@ let inner'' lk = do bconfig <- runStackLoggingTGlobal manager go $ - lcLoadBuildConfig lc globalResolver + lcLoadBuildConfig lc globalResolver globalCompiler envConfig <- runStackTGlobal manager bconfig go @@ -689,30 +756,24 @@ do lk' <- readIORef curLk munlockFile lk') -cleanCmd :: () -> GlobalOpts -> IO () -cleanCmd () go = withBuildConfigAndLock go (\_ -> clean) +cleanCmd :: CleanOpts -> GlobalOpts -> IO () +cleanCmd opts go = withBuildConfigAndLock go (const (clean opts)) -- | Helper for build and install commands buildCmd :: BuildOpts -> GlobalOpts -> IO () buildCmd opts go = do when (any (("-prof" `elem`) . either (const []) id . parseArgs Escaping) (boptsGhcOptions opts)) $ do hPutStrLn stderr "When building with stack, you should not use the -prof GHC option" - hPutStrLn stderr "Instead, please use --enable-library-profiling and --enable-executable-profiling" + hPutStrLn stderr "Instead, please use --library-profiling and --executable-profiling" hPutStrLn stderr "See: https://github.com/commercialhaskell/stack/issues/1015" error "-prof GHC option submitted" case boptsFileWatch opts of - FileWatchPoll -> fileWatchPoll getProjectRoot inner - FileWatch -> fileWatch getProjectRoot inner + FileWatchPoll -> fileWatchPoll inner + FileWatch -> fileWatch inner NoFileWatch -> inner $ const $ return () where inner setLocalFiles = withBuildConfigAndLock go $ \lk -> Stack.Build.build setLocalFiles lk opts - getProjectRoot = do - (manager, lc) <- loadConfigWithOpts go - bconfig <- - runStackLoggingTGlobal manager go $ - lcLoadBuildConfig lc (globalResolver go) - return (bcRoot bconfig) uninstallCmd :: [String] -> GlobalOpts -> IO () uninstallCmd _ go = withConfigAndLock go $ do @@ -746,7 +807,7 @@ return $ if r then (x:as, bs) else (as, x:bs) (files, nonFiles) <- partitionM doesFileExist args (dirs, invalid) <- partitionM doesDirectoryExist nonFiles - when (not (null invalid)) $ error $ + unless (null invalid) $ error $ "stack upload expects a list sdist tarballs or cabal directories. Can't find " ++ show invalid let getUploader :: (HasStackRoot config, HasPlatform config, HasConfig config) => StackT config IO Upload.Uploader @@ -754,8 +815,7 @@ config <- asks getConfig manager <- asks envManager let uploadSettings = - Upload.setGetManager (return manager) $ - Upload.defaultUploadSettings + Upload.setGetManager (return manager) Upload.defaultUploadSettings liftIO $ Upload.mkUploader config uploadSettings if null dirs then withConfigAndLock go $ do @@ -779,35 +839,39 @@ forM_ dirs' $ \dir -> do (tarName, tarBytes) <- getSDistTarball mpvpBounds dir distDir <- distDirFromDir dir - tarPath <- fmap (distDir ) $ parseRelFile tarName + tarPath <- (distDir ) <$> parseRelFile tarName liftIO $ createTree $ parent tarPath liftIO $ L.writeFile (toFilePath tarPath) tarBytes $logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath) -- | Execute a command. execCmd :: ExecOpts -> GlobalOpts -> IO () -execCmd ExecOpts {..} go@GlobalOpts{..} = do - (cmd, args) <- - case (eoCmd, eoArgs) of - (Just cmd, args) -> return (cmd, args) - (Nothing, cmd:args) -> return (cmd, args) - (Nothing, []) -> error "You must provide a command to exec, e.g. 'stack exec echo Hello World'" +execCmd ExecOpts {..} go@GlobalOpts{..} = case eoExtra of ExecOptsPlain -> do + (cmd, args) <- case (eoCmd, eoArgs) of + (ExecCmd cmd, args) -> return (cmd, args) + (ExecGhc, args) -> return ("ghc", args) + (ExecRunGhc, args) -> return ("runghc", args) (manager,lc) <- liftIO $ loadConfigWithOpts go withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> runStackTGlobal manager (lcConfig lc) go $ - Docker.execWithOptionalContainer + Docker.reexecWithOptionalContainer (lcProjectRoot lc) - (\_ _ -> return (cmd, args, [], [])) -- Unlock before transferring control away, whether using docker or not: (Just $ munlockFile lk) - (runStackTGlobal manager (lcConfig lc) go $ do + (runStackTGlobal manager (lcConfig lc) go $ exec plainEnvSettings cmd args) Nothing Nothing -- Unlocked already above. ExecOptsEmbellished {..} -> withBuildConfigAndLock go $ \lk -> do + (cmd, args) <- case (eoCmd, eoArgs) of + (ExecCmd cmd, args) -> return (cmd, args) + (ExecGhc, args) -> execCompiler "" args + -- NOTE: this won't currently work for GHCJS, because it doesn't have + -- a runghcjs binary. It probably will someday, though. + (ExecRunGhc, args) -> execCompiler "run" args let targets = concatMap words eoPackages unless (null targets) $ Stack.Build.build (const $ return ()) lk defaultBuildOpts @@ -815,13 +879,18 @@ } munlockFile lk -- Unlock before transferring control away. exec eoEnvSettings cmd args + where + execCompiler cmdPrefix args = do + wc <- getWhichCompiler + let cmd = cmdPrefix ++ compilerExeName wc + return (cmd, args) -- | Evaluate some haskell code inline. evalCmd :: EvalOpts -> GlobalOpts -> IO () evalCmd EvalOpts {..} go@GlobalOpts {..} = execCmd execOpts go where execOpts = - ExecOpts { eoCmd = Just "ghc" + ExecOpts { eoCmd = ExecGhc , eoArgs = ["-e", evalArg] , eoExtra = evalExtra } @@ -860,7 +929,8 @@ targetsCmd :: Text -> GlobalOpts -> IO () targetsCmd target go@GlobalOpts{..} = withBuildConfig go $ - do (_realTargets,_,pkgs) <- ghciSetup Nothing [target] + do let bopts = defaultBuildOpts { boptsTargets = [target] } + (_realTargets,_,pkgs) <- ghciSetup bopts False Nothing pwd <- getWorkingDir targets <- fmap @@ -896,13 +966,22 @@ Docker.preventInContainer $ Docker.cleanup cleanupOpts -imgDockerCmd :: () -> GlobalOpts -> IO () -imgDockerCmd () go@GlobalOpts{..} = do +cfgSetCmd :: ConfigCmd.ConfigCmdSet -> GlobalOpts -> IO () +cfgSetCmd co go@GlobalOpts{..} = + withBuildConfigAndLock + go + (\_ -> do env <- ask + runReaderT + (cfgCmdSet co) + env) + +imgDockerCmd :: Bool -> GlobalOpts -> IO () +imgDockerCmd rebuild go@GlobalOpts{..} = withBuildConfigExt go Nothing (\lk -> - do Stack.Build.build + do when rebuild $ Stack.Build.build (const (return ())) lk defaultBuildOpts @@ -920,10 +999,15 @@ Just fp -> do path <- canonicalizePath fp >>= parseAbsFile return $ Just path - lc <- runStackLoggingTGlobal - manager - go - (loadConfig globalConfigMonoid mstackYaml) + lc <- runStackLoggingTGlobal manager go $ do + lc <- loadConfig globalConfigMonoid mstackYaml + -- If we have been relaunched in a Docker container, perform in-container initialization + -- (switch UID, etc.). We do this after first loading the configuration since it must + -- happen ASAP but needs a configuration. + case globalDockerEntrypoint of + Just de -> Docker.entrypoint (lcConfig lc) de + Nothing -> return () + return lc return (manager,lc) -- | Project initialization @@ -967,6 +1051,10 @@ -- | Query build information queryCmd :: [String] -> GlobalOpts -> IO () queryCmd selectors go = withBuildConfig go $ queryBuildInfo $ map T.pack selectors + +-- | Generate a combined HPC report +hpcReportCmd :: HpcReportOpts -> GlobalOpts -> IO () +hpcReportCmd hropts go = withBuildConfig go $ generateHpcReportForTargets hropts data MainException = InvalidReExecVersion String String deriving (Typeable) diff --git a/src/test/Stack/BuildPlanSpec.hs b/src/test/Stack/BuildPlanSpec.hs --- a/src/test/Stack/BuildPlanSpec.hs +++ b/src/test/Stack/BuildPlanSpec.hs @@ -54,12 +54,10 @@ -- github still depends on failure. writeFile "stack.yaml" "resolver: lts-2.9" LoadConfig{..} <- loadConfig' manager - bconfig <- loadBuildConfigRest manager (lcLoadBuildConfig Nothing) + bconfig <- loadBuildConfigRest manager (lcLoadBuildConfig Nothing Nothing) runStackT manager logLevel bconfig False False $ do - menv <- getMinimalEnvOverride mbp <- loadMiniBuildPlan $ LTS 2 9 eres <- try $ resolveBuildPlan - menv mbp (const False) (Map.fromList diff --git a/src/test/Stack/ConfigSpec.hs b/src/test/Stack/ConfigSpec.hs --- a/src/test/Stack/ConfigSpec.hs +++ b/src/test/Stack/ConfigSpec.hs @@ -82,7 +82,7 @@ setCurrentDirectory childDir LoadConfig{..} <- loadConfig' manager bc@BuildConfig{..} <- loadBuildConfigRest manager - (lcLoadBuildConfig Nothing) + (lcLoadBuildConfig Nothing Nothing) bcRoot bc `shouldBe` parentDir it "respects the STACK_YAML env variable" $ \T{..} -> inTempDir $ do @@ -92,7 +92,7 @@ withEnvVar "STACK_YAML" stackYamlFp $ do LoadConfig{..} <- loadConfig' manager BuildConfig{..} <- loadBuildConfigRest manager - (lcLoadBuildConfig Nothing) + (lcLoadBuildConfig Nothing Nothing) bcStackYaml `shouldBe` dir stackDotYaml parent bcStackYaml `shouldBe` dir @@ -106,5 +106,5 @@ withEnvVar "STACK_YAML" (toFilePath yamlRel) $ do LoadConfig{..} <- loadConfig' manager BuildConfig{..} <- loadBuildConfigRest manager - (lcLoadBuildConfig Nothing) + (lcLoadBuildConfig Nothing Nothing) bcStackYaml `shouldBe` yamlAbs diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -80,6 +80,7 @@ , dpLibraries = ["HShaskell2010-1.1.2.0"] , dpHasExposedModules = True , dpHaddockInterfaces = ["/opt/ghc/7.8.4/share/doc/ghc/html/libraries/haskell2010-1.1.2.0/haskell2010.haddock"] + , dpHaddockHtml = Just "/opt/ghc/7.8.4/share/doc/ghc/html/libraries/haskell2010-1.1.2.0" , dpProfiling = () , dpHaddock = () , dpIsExposed = False @@ -113,6 +114,7 @@ , dpPackageIdent = pkgIdent , dpLibDirs = ["/opt/ghc/7.10.1/lib/ghc-7.10.1/ghc_EMlWrQ42XY0BNVbSrKixqY"] , dpHaddockInterfaces = ["/opt/ghc/7.10.1/share/doc/ghc/html/libraries/ghc-7.10.1/ghc.haddock"] + , dpHaddockHtml = Just "/opt/ghc/7.10.1/share/doc/ghc/html/libraries/ghc-7.10.1" , dpDepends = depends , dpLibraries = ["HSghc-7.10.1-EMlWrQ42XY0BNVbSrKixqY"] , dpHasExposedModules = True @@ -146,6 +148,7 @@ , "/usr/local/lib/" , "C:/Program Files/Example/"] , dpHaddockInterfaces = ["/Users/alexbiehl/.stack/snapshots/x86_64-osx/lts-2.13/7.8.4/doc/html/hmatrix.haddock"] + , dpHaddockHtml = Just "/Users/alexbiehl/.stack/snapshots/x86_64-osx/lts-2.13/7.8.4/doc/html" , dpDepends = depends , dpLibraries = ["HShmatrix-0.16.1.5"] , dpHasExposedModules = True diff --git a/stack.cabal b/stack.cabal --- a/stack.cabal +++ b/stack.cabal @@ -1,311 +1,326 @@ -name: stack -version: 0.1.6.0 -synopsis: The Haskell Tool Stack -description: Please see the README.md for usage information, and - the wiki on Github for more details. Also, note that - the API for the library is not currently stable, and may - change significantly, even between minor releases. It is - currently only intended for use by the executable. -license: BSD3 -license-file: LICENSE -author: Chris Done -maintainer: chrisdone@fpcomplete.com -category: Development -build-type: Simple -cabal-version: >=1.10 -homepage: https://github.com/commercialhaskell/stack -extra-source-files: README.md - ChangeLog.md - CONTRIBUTING.md - doc/GUIDE.md - doc/build_command.md - doc/install_and_upgrade.md - doc/MAINTAINER_GUIDE.md - doc/dependency_visualization.md - doc/nonstandard_project_init.md - doc/SIGNING_KEY.md - doc/docker_integration.md - doc/shell_autocompletion.md - doc/architecture.md - doc/faq.md - doc/yaml_configuration.md - - -- Glob would be nice, but apparently Cabal doesn't support it: - -- cabal: filepath wildcard 'test/package-dump/*.txt' does not match any files. - -- Happened during cabal sdist - test/package-dump/ghc-7.8.txt - test/package-dump/ghc-7.8.4-osx.txt - test/package-dump/ghc-7.10.txt +name: stack +version: 0.1.8.0 +cabal-version: >=1.10 +build-type: Simple +license: BSD3 +license-file: LICENSE +maintainer: manny@fpcomplete.com +homepage: https://github.com/commercialhaskell/stack +synopsis: The Haskell Tool Stack +description: + Please see the README.md for usage information, and + the wiki on Github for more details. Also, note that + the API for the library is not currently stable, and may + change significantly, even between minor releases. It is + currently only intended for use by the executable. +category: Development +author: Commercial Haskell SIG +extra-source-files: + CONTRIBUTING.md + ChangeLog.md + README.md + doc/GUIDE.md + doc/MAINTAINER_GUIDE.md + doc/SIGNING_KEY.md + doc/architecture.md + doc/build_command.md + doc/dependency_visualization.md + doc/docker_integration.md + doc/faq.md + doc/install_and_upgrade.md + doc/nonstandard_project_init.md + doc/shell_autocompletion.md + doc/stack_and_ghcjs.md + doc/yaml_configuration.md + test/package-dump/ghc-7.8.txt + test/package-dump/ghc-7.8.4-osx.txt + test/package-dump/ghc-7.10.txt + stack.yaml - stack.yaml +source-repository head + type: git + location: https://github.com/commercialhaskell/stack flag integration-tests - manual: True - default: False - description: Run the integration test suite + description: + Run the integration test suite + default: False + manual: True library - hs-source-dirs: src/ - ghc-options: -Wall - exposed-modules: Options.Applicative.Builder.Extra - Options.Applicative.Args - Stack.BuildPlan - Stack.Config - Stack.Config.Docker - Stack.Constants - Stack.Docker - Stack.Docker.GlobalDB - Stack.Dot - Stack.Fetch - Stack.Exec - Stack.FileWatch - Stack.GhcPkg - Stack.Init - Stack.New - Stack.Options - Stack.Package - Stack.PackageDump - Stack.PackageIndex - Stack.Ghci - Stack.Ide - Stack.Image - Stack.SDist - Stack.Setup - Stack.Setup.Installed - Stack.Solver - Stack.Types - Stack.Types.Internal - Stack.Types.BuildPlan - Stack.Types.Compiler - Stack.Types.Config - Stack.Types.Docker - Stack.Types.FlagName - Stack.Types.GhcPkgId - Stack.Types.Image - Stack.Types.PackageIdentifier - Stack.Types.PackageName - Stack.Types.TemplateName - Stack.Types.Version - Stack.Types.StackT - Stack.Types.Build - Stack.Types.Package - Stack.Build - Stack.Build.Cache - Stack.Build.Coverage - Stack.Build.ConstructPlan - Stack.Build.Execute - Stack.Build.Haddock - Stack.Build.Installed - Stack.Build.Source - Stack.Build.Target - Stack.Upgrade - Stack.Upload - System.Process.Read - System.Process.Log - System.Process.Run - Network.HTTP.Download.Verified - Data.Attoparsec.Args - Path.IO - other-modules: Network.HTTP.Download - Control.Concurrent.Execute - Path.Find - System.Process.PagerEditor - Paths_stack - Data.Aeson.Extended - Data.Attoparsec.Combinators - Data.Binary.VersionTagged - Data.IORef.RunOnce - Data.Maybe.Extra - Data.Set.Monad - Distribution.Version.Extra - build-depends: Cabal >= 1.18.1.5 - , aeson >= 0.8.0.2 - , ansi-terminal >= 0.6.2.3 - , async >= 2.0.2 - , attoparsec >= 0.12.1.5 - , base >= 4 && <5 - , base16-bytestring - , base64-bytestring - , bifunctors >= 4.2.1 - , binary >= 0.7 - , binary-tagged >= 0.1.1 - , blaze-builder - , byteable - , bytestring - , conduit-combinators >= 0.3.1 - , conduit >= 1.2.4 - , conduit-extra >= 1.1.7.1 - , containers >= 0.5.5.1 - , cryptohash >= 0.11.6 - , cryptohash-conduit - , directory >= 1.2.1.0 - , enclosed-exceptions - , exceptions >= 0.8.0.2 - , extra - , fast-logger >= 2.3.1 - , filelock >= 0.1.0.1 - , filepath >= 1.3.0.2 - , fsnotify >= 0.2.1 - , gitrev >= 1.1 - , hashable >= 1.2.3.2 - , hpc - , http-client >= 0.4.17 - , http-client-tls >= 0.2.2 - , http-conduit >= 2.1.7 - , http-types >= 0.8.6 - , ignore >= 0.1.1 - , lifted-base - , monad-control - , monad-logger >= 0.3.13.1 - , monad-loops >= 0.4.2.1 - , mtl >= 2.1.3.1 - , old-locale >= 1.0.0.6 - , optparse-applicative - , optparse-simple >= 0.0.3 - , path >= 0.5.1 - , persistent >= 2.1.2 - , persistent-sqlite >= 2.1.4 - , persistent-template >= 2.1.1 - , pretty - , process >= 1.2.0.0 - , resourcet >= 1.1.4.1 - , retry >= 0.6 - , safe >= 0.3 - , split - , stm >= 2.4.4 - , streaming-commons >= 0.1.10.0 - , tar >= 0.4.1.0 - , template-haskell - , temporary >= 1.2.0.3 - , text >= 1.2.0.4 - , time >= 1.4.2 - , transformers >= 0.3.0.0 - , transformers-base >= 0.4.4 - , unix-compat - , unordered-containers >= 0.2.5.1 - , vector >= 0.10.12.3 - , vector-binary-instances - , void >= 0.7 - , yaml >= 0.8.10.1 - , zlib >= 0.5.4.2 - , deepseq >= 1.3 - , file-embed - , word8 - , hastache - , project-template >= 0.2 - if os(windows) - cpp-options: -DWINDOWS - build-depends: Win32 - else - build-depends: unix >= 2.7.0.1 - default-language: Haskell2010 + + if os(windows) + build-depends: + Win32 >=2.3.1.0 && <2.4 + cpp-options: -DWINDOWS + else + build-depends: + unix >=2.7.0.1 && <2.8 + exposed-modules: + Options.Applicative.Builder.Extra + Options.Applicative.Args + Options.Applicative.Complicated + Stack.BuildPlan + Stack.Clean + Stack.Config + Stack.Config.Docker + Stack.ConfigCmd + Stack.Constants + Stack.Coverage + Stack.Docker + Stack.Docker.GlobalDB + Stack.Dot + Stack.Fetch + Stack.Exec + Stack.FileWatch + Stack.GhcPkg + Stack.Init + Stack.New + Stack.Options + Stack.Package + Stack.PackageDump + Stack.PackageIndex + Stack.Ghci + Stack.Ide + Stack.Image + Stack.SDist + Stack.Setup + Stack.Setup.Installed + Stack.Solver + Stack.Types + Stack.Types.Internal + Stack.Types.BuildPlan + Stack.Types.Compiler + Stack.Types.Config + Stack.Types.Docker + Stack.Types.FlagName + Stack.Types.GhcPkgId + Stack.Types.Image + Stack.Types.PackageIdentifier + Stack.Types.PackageIndex + Stack.Types.PackageName + Stack.Types.TemplateName + Stack.Types.Version + Stack.Types.StackT + Stack.Types.Build + Stack.Types.Package + Stack.Build + Stack.Build.Cache + Stack.Build.ConstructPlan + Stack.Build.Execute + Stack.Build.Haddock + Stack.Build.Installed + Stack.Build.Source + Stack.Build.Target + Stack.Upgrade + Stack.Upload + System.Process.Read + System.Process.Log + System.Process.Run + Network.HTTP.Download.Verified + Data.Attoparsec.Args + Data.Maybe.Extra + Path.IO + Path.Extra + build-depends: + Cabal >=1.18.1.5 && <1.23, + aeson >=0.8.0.2 && <0.10, + ansi-terminal >=0.6.2.3 && <0.7, + async >=2.0.2 && <2.1, + attoparsec >=0.12.1.5 && <0.14, + base ==4.*, + base16-bytestring >=0.1.1.6 && <0.2, + base64-bytestring >=1.0.0.1 && <1.1, + bifunctors >=4.2.1 && <5.1, + binary ==0.7.*, + binary-tagged >=0.1.1 && <0.2, + blaze-builder >=0.4.0.1 && <0.5, + byteable >=0.1.1 && <0.2, + bytestring >=0.10.6.0 && <0.11, + conduit-combinators >=0.3.1 && <1.1, + conduit >=1.2.4 && <1.3, + conduit-extra >=1.1.7.1 && <1.2, + containers >=0.5.5.1 && <0.6, + cryptohash >=0.11.6 && <0.12, + cryptohash-conduit >=0.1.1 && <0.2, + directory >=1.2.1.0 && <1.3, + edit-distance ==0.2.*, + either >=4.4.1 && <4.5, + enclosed-exceptions >=1.0.1.1 && <1.1, + exceptions >=0.8.0.2 && <0.9, + extra >=1.4.2 && <1.5, + fast-logger >=2.3.1 && <2.5, + filelock >=0.1.0.1 && <0.2, + filepath >=1.3.0.2 && <1.5, + fsnotify >=0.2.1 && <0.3, + gitrev ==1.1.*, + hashable >=1.2.3.2 && <1.3, + hpc >=0.6.0.2 && <0.7, + http-client >=0.4.17 && <0.5, + http-client-tls >=0.2.2 && <0.3, + http-conduit >=2.1.7 && <2.2, + http-types >=0.8.6 && <0.9, + lifted-base >=0.2.3.6 && <0.3, + monad-control >=1.0.0.4 && <1.1, + monad-logger >=0.3.13.1 && <0.4, + monad-loops >=0.4.2.1 && <0.5, + mtl >=2.1.3.1 && <2.3, + old-locale >=1.0.0.6 && <1.1, + optparse-applicative >=0.11.0.2 && <0.12, + path >=0.5.1 && <0.6, + persistent >=2.1.2 && <2.3, + persistent-sqlite >=2.1.4 && <2.3, + persistent-template >=2.1.1 && <2.2, + pretty >=1.1.2.0 && <1.2, + process >=1.2.0.0 && <1.3, + resourcet >=1.1.4.1 && <1.2, + retry >=0.6 && <0.8, + safe ==0.3.*, + semigroups >=0.5 && <0.17, + split >=0.2.2 && <0.3, + stm >=2.4.4 && <2.5, + streaming-commons >=0.1.10.0 && <0.2, + tar >=0.4.1.0 && <0.5, + template-haskell >=2.10.0.0 && <2.11, + temporary >=1.2.0.3 && <1.3, + text >=1.2.0.4 && <1.3, + time >=1.4.2 && <1.6, + transformers >=0.3.0.0 && <0.5, + transformers-base >=0.4.4 && <0.5, + unix-compat >=0.4.1.4 && <0.5, + unordered-containers >=0.2.5.1 && <0.3, + vector >=0.10.12.3 && <0.12, + vector-binary-instances >=0.2.1.0 && <0.3, + void ==0.7.*, + yaml >=0.8.10.1 && <0.9, + zlib >=0.5.4.2 && <0.6, + deepseq ==1.4.*, + file-embed >=0.0.9 && <0.1, + word8 >=0.1.2 && <0.2, + hastache >=0.6.1 && <0.7, + project-template ==0.2.* + default-language: Haskell2010 + hs-source-dirs: src/ + other-modules: + Network.HTTP.Download + Control.Concurrent.Execute + Path.Find + System.Process.PagerEditor + Paths_stack + Data.Aeson.Extended + Data.Attoparsec.Combinators + Data.Binary.VersionTagged + Data.IORef.RunOnce + Data.Set.Monad + Distribution.Version.Extra + ghc-options: -Wall executable stack - hs-source-dirs: src/main - main-is: Main.hs - ghc-options: -Wall -threaded -rtsopts - other-modules: Paths_stack - - build-depends: base >=4.7 && < 5 - , bytestring >= 0.10.4.0 - , Cabal - , containers - , exceptions - , filepath - , filelock >= 0.1.0.1 - , gitrev >= 1.1 - , http-conduit >= 2.1.5 - , lifted-base - , monad-control - , monad-logger >= 0.3.13.1 - , mtl >= 2.1.3.1 - , old-locale >= 1.0.0.6 - , optparse-applicative >= 0.11.0.2 - , optparse-simple >= 0.0.3 - , path - , process - , resourcet >= 1.1.4.1 - , stack - , text >= 1.2.0.4 - , either - , directory - , split - , unordered-containers - , hashable - , conduit - , transformers - , http-client - default-language: Haskell2010 - if os(windows) - build-depends: Win32 - cpp-options: -DWINDOWS + + if os(windows) + build-depends: + Win32 >=2.3.1.0 && <2.4 + cpp-options: -DWINDOWS + main-is: Main.hs + build-depends: + base >=4.7 && <5, + bytestring >=0.10.4.0 && <0.11, + Cabal >=1.22.4.0 && <1.23, + containers >=0.5.6.2 && <0.6, + exceptions >=0.8.0.2 && <0.9, + filepath >=1.4.0.0 && <1.5, + filelock >=0.1.0.1 && <0.2, + gitrev ==1.1.*, + http-conduit >=2.1.5 && <2.2, + lifted-base >=0.2.3.6 && <0.3, + monad-control >=1.0.0.4 && <1.1, + monad-logger >=0.3.13.1 && <0.4, + mtl >=2.1.3.1 && <2.3, + old-locale >=1.0.0.6 && <1.1, + optparse-applicative >=0.11.0.2 && <0.12, + optparse-simple >=0.0.3 && <0.1, + path >=0.5.2 && <0.6, + process >=1.2.3.0 && <1.3, + resourcet >=1.1.4.1 && <1.2, + stack >=0.1.8.0 && <0.2, + text >=1.2.0.4 && <1.3, + either >=4.4.1 && <4.5, + directory >=1.2.2.0 && <1.3, + split >=0.2.2 && <0.3, + unordered-containers >=0.2.5.1 && <0.3, + hashable >=1.2.3.3 && <1.3, + conduit >=1.2.5 && <1.3, + transformers >=0.4.2.0 && <0.5, + http-client >=0.4.24 && <0.5 + default-language: Haskell2010 + hs-source-dirs: src/main + other-modules: + Paths_stack + ghc-options: -Wall -threaded -rtsopts test-suite stack-test - type: exitcode-stdio-1.0 - hs-source-dirs: src/test - main-is: Test.hs - other-modules: Spec - , Stack.BuildPlanSpec - , Stack.Build.ExecuteSpec - , Stack.Build.TargetSpec - , Stack.ConfigSpec - , Stack.DotSpec - , Stack.PackageDumpSpec - , Stack.ArgsSpec - , Network.HTTP.Download.VerifiedSpec - ghc-options: -Wall -threaded - build-depends: base >=4.7 && <5 - , hspec - , containers - , directory - , exceptions - , filepath - , path - , temporary - , stack - , monad-logger - , http-conduit - , cryptohash - , transformers - , conduit - , conduit-extra - , resourcet - , Cabal - , text - , optparse-applicative - , bytestring - , QuickCheck - , retry >= 0.6 - default-language: Haskell2010 - + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: + base >=4.7 && <5, + hspec >=2.1.10 && <2.2, + containers >=0.5.6.2 && <0.6, + directory >=1.2.2.0 && <1.3, + exceptions >=0.8.0.2 && <0.9, + filepath >=1.4.0.0 && <1.5, + path >=0.5.2 && <0.6, + temporary >=1.2.0.3 && <1.3, + stack >=0.1.8.0 && <0.2, + monad-logger >=0.3.13.2 && <0.4, + http-conduit >=2.1.8 && <2.2, + cryptohash >=0.11.6 && <0.12, + transformers >=0.4.2.0 && <0.5, + conduit >=1.2.5 && <1.3, + conduit-extra >=1.1.9.1 && <1.2, + resourcet >=1.1.6 && <1.2, + Cabal >=1.22.4.0 && <1.23, + text >=1.2.1.3 && <1.3, + optparse-applicative >=0.11.0.2 && <0.12, + bytestring >=0.10.6.0 && <0.11, + QuickCheck >=2.8.1 && <2.9, + retry >=0.6 && <0.8 + default-language: Haskell2010 + hs-source-dirs: src/test + other-modules: + Spec + Stack.BuildPlanSpec + Stack.Build.ExecuteSpec + Stack.Build.TargetSpec + Stack.ConfigSpec + Stack.DotSpec + Stack.PackageDumpSpec + Stack.ArgsSpec + Network.HTTP.Download.VerifiedSpec + ghc-options: -Wall -threaded test-suite stack-integration-test - type: exitcode-stdio-1.0 - hs-source-dirs: test/integration - main-is: IntegrationSpec.hs - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - - if flag(integration-tests) - buildable: True - else - buildable: False - - build-depends: base >= 4.7 && < 10 - , temporary - , hspec - , process - , filepath - , directory - , text - , unix-compat - , containers - , conduit - , conduit-extra - , resourcet - , async - , transformers - , bytestring - default-language: Haskell2010 - -source-repository head - type: git - location: https://github.com/commercialhaskell/stack + + if !flag(integration-tests) + buildable: False + type: exitcode-stdio-1.0 + main-is: IntegrationSpec.hs + build-depends: + base >=4.7 && <10, + temporary >=1.2.0.3 && <1.3, + hspec >=2.1.10 && <2.2, + process >=1.2.3.0 && <1.3, + filepath >=1.4.0.0 && <1.5, + directory >=1.2.2.0 && <1.3, + text >=1.2.1.3 && <1.3, + unix-compat >=0.4.1.4 && <0.5, + containers >=0.5.6.2 && <0.6, + conduit >=1.2.5 && <1.3, + conduit-extra >=1.1.9.1 && <1.2, + resourcet >=1.1.6 && <1.2, + async >=2.0.2 && <2.1, + transformers >=0.4.2.0 && <0.5, + bytestring >=0.10.6.0 && <0.11 + default-language: Haskell2010 + hs-source-dirs: test/integration test/integration/lib + other-modules: + StackTest + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,10 +1,5 @@ resolver: lts-3.7 -extra-deps: -- ignore-0.1.1.0 -- binary-tagged-0.1.1.0 -flags: - ignore: - without-pcre: true +extra-deps: [] image: container: base: "fpco/ubuntu-with-libgmp:14.04" diff --git a/test/integration/IntegrationSpec.hs b/test/integration/IntegrationSpec.hs --- a/test/integration/IntegrationSpec.hs +++ b/test/integration/IntegrationSpec.hs @@ -15,7 +15,7 @@ import Data.Conduit.Filesystem (sourceDirectoryDeep) import qualified Data.Conduit.List as CL import Data.Conduit.Process -import Data.List (isSuffixOf, stripPrefix) +import Data.List (isSuffixOf, stripPrefix, sort) import qualified Data.Map as Map import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as TL @@ -43,7 +43,7 @@ stack <- findExe "stack" let testDir = currDir "tests" - tests <- getDirectoryContents testDir >>= filterM (hasTest testDir) + tests <- getDirectoryContents testDir >>= filterM (hasTest testDir) . sort envOrig <- getEnvironment diff --git a/test/integration/lib/StackTest.hs b/test/integration/lib/StackTest.hs new file mode 100644 --- /dev/null +++ b/test/integration/lib/StackTest.hs @@ -0,0 +1,104 @@ +module StackTest where + +import Control.Exception +import Data.List (intercalate) +import System.Environment +import System.FilePath +import System.Directory +import System.IO +import System.Process +import System.Exit + +run' :: FilePath -> [String] -> IO ExitCode +run' cmd args = do + logInfo $ "Running: " ++ cmd ++ " " ++ intercalate " " (map showProcessArgDebug args) + (Nothing, Nothing, Nothing, ph) <- createProcess (proc cmd args) + waitForProcess ph + +run :: FilePath -> [String] -> IO () +run cmd args = do + ec <- run' cmd args + if ec == ExitSuccess + then return () + else error $ "Exited with exit code: " ++ show ec + +stack' :: [String] -> IO ExitCode +stack' args = do + stack <- getEnv "STACK_EXE" + run' stack args + +stack :: [String] -> IO () +stack args = do + ec <- stack' args + if ec == ExitSuccess + then return () + else error $ "Exited with exit code: " ++ show ec + +stackErr :: [String] -> IO () +stackErr args = do + ec <- stack' args + if ec == ExitSuccess + then error "stack was supposed to fail, but didn't" + else return () + +doesNotExist :: FilePath -> IO () +doesNotExist fp = do + logInfo $ "doesNotExist " ++ fp + exists <- doesFileOrDirExist fp + case exists of + (Right msg) -> error msg + (Left _) -> return () + +doesExist :: FilePath -> IO () +doesExist fp = do + logInfo $ "doesExist " ++ fp + exists <- doesFileOrDirExist fp + case exists of + (Right msg) -> return () + (Left _) -> error "No file or directory exists" + +doesFileOrDirExist :: FilePath -> IO (Either () String) +doesFileOrDirExist fp = do + isFile <- doesFileExist fp + if isFile + then return (Right ("File exists: " ++ fp)) + else do + isDir <- doesDirectoryExist fp + if isDir + then return (Right ("Directory exists: " ++ fp)) + else return (Left ()) + +copy :: FilePath -> FilePath -> IO () +copy src dest = do + logInfo ("Copy " ++ show src ++ " to " ++ show dest) + System.Directory.copyFile src dest + +fileContentsMatch :: FilePath -> FilePath -> IO () +fileContentsMatch f1 f2 = do + doesExist f1 + doesExist f2 + f1Contents <- readFile f1 + f2Contents <- readFile f2 + if f1Contents == f2Contents + then return () + else error + ("contents do not match for " ++ + show f1 ++ + " " ++ + show f2) + +logInfo :: String -> IO () +logInfo = hPutStrLn stderr + +-- TODO: use stack's process running utilties? (better logging) +-- for now just copy+modifying this one from System.Process.Log + +-- | Show a process arg including speechmarks when necessary. Just for +-- debugging purposes, not functionally important. +showProcessArgDebug :: String -> String +showProcessArgDebug x + | any special x = show x + | otherwise = x + where special '"' = True + special ' ' = True + special _ = False