diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -7,10 +7,10 @@ The more detailed your report, the faster it can be resolved and will ensure it is resolved in the right way. Once your bug has been resolved, the responsible -will tag the issue as _Needs confirmation_ and assign the issue back to you. -Once you have tested and confirmed that the issue is resolved, close the issue. -If you are not a member of the project, you will be asked for confirmation and -we will close it. +person will tag the issue as _Needs confirmation_ and assign the issue back to +you. Once you have tested and confirmed that the issue is resolved, close the +issue. If you are not a member of the project, you will be asked for +confirmation and we will close it. ## Documentation diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,101 @@ # Changelog + +## 1.5.0 + +Behavior changes: + +* `stack profile` and `stack trace` now add their extra RTS arguments for + benchmarks and tests to the beginning of the args, instead of the end. + See [#2399](https://github.com/commercialhaskell/stack/issues/2399) +* Support for Git-based indices has been removed. + +Other enhancements: + +* `stack setup` allow to control options passed to ghcjs-boot with + `--ghcjs-boot-options` (one word at a time) and `--[no-]ghcjs-boot-clean` +* `stack setup` now accepts a `--install-cabal VERSION` option which + will install a specific version of the Cabal library globally. +* Updates to store-0.4.1, which has improved performance and better error + reporting for version tags. A side-effect of this is that all of + stack's binary caches will be invalidated. +* `stack solver` will now warn about unexpected cabal-install versions. + See [#3044](https://github.com/commercialhaskell/stack/issues/3044) +* Upstream packages unpacked to a temp dir are now deleted as soon as + possible to avoid running out of space in `/tmp`. + See [#3018](https://github.com/commercialhaskell/stack/issues/3018) +* Add short synonyms for `test-arguments` and `benchmark-arguments` options. +* Adds `STACK_WORK` environment variable, to specify work dir. + See [#3063](https://github.com/commercialhaskell/stack/issues/3063) +* Can now use relative paths for `extra-include-dirs` and `extra-lib-dirs`. + See [#2830](https://github.com/commercialhaskell/stack/issues/2830) +* Improved bash completion for many options, including `--ghc-options`, + `--flag`, targets, and project executables for `exec`. +* `--haddock-arguments` is actually used now when `haddock` is invoked + during documentation generation. +* `--[no-]haddock-hyperlink-source` flag added which allows toggling + of sources being included in Haddock output. + See [#3099](https://github.com/commercialhaskell/stack/issues/3099) +* `stack ghci` will now skip building all local targets, even if they have + downstream deps, as long as it's registered in the DB. +* The pvp-bounds feature now supports adding `-revision` to the end of + each value, e.g. `pvp-bounds: both-revision`. This means that, when + uploading to Hackage, Stack will first upload your tarball with an + unmodified `.cabal` file, and then upload a cabal file revision with + the PVP bounds added. This can be useful—especially combined + with the + [Stackage no-revisions feature](http://www.snoyman.com/blog/2017/04/stackages-no-revisions-field)—as + a method to ensure PVP compliance without having to proactively fix + bounds issues for Stackage maintenance. +* Expose a `save-hackage-creds` configuration option +* On GHC <= 7.8, filters out spurious linker warnings on windows + See [#3127](https://github.com/commercialhaskell/stack/pull/3127) +* Better error messages when creating or building packages which alias + wired-in packages. See + [#3172](https://github.com/commercialhaskell/stack/issues/3172). +* MinGW bin folder now is searched for dynamic libraries. See [#3126](https://github.com/commercialhaskell/stack/issues/3126) +* When using Nix, nix-shell now depends always on git to prevent runtime errors + while fetching metadata +* The `stack unpack` command now accepts a form where an explicit + Hackage revision hash is specified, e.g. `stack unpack + foo-1.2.3@gitsha1:deadbeef`. Note that this should be considered + _experimental_, Stack will likely move towards a different hash + format in the future. +* Binary "stack upgrade" will now warn if the installed executable is not + on the PATH or shadowed by another entry. +* Allow running tests on tarball created by sdist and upload + [#717](https://github.com/commercialhaskell/stack/issues/717). + +Bug fixes: + +* Fixes case where `stack build --profile` might not cause executables / + tests / benchmarks to be rebuilt. + See [#2984](https://github.com/commercialhaskell/stack/issues/2984) +* `stack ghci file.hs` now loads the file even if it isn't part of + your project. +* `stack clean --full` now works when docker is enabled. + See [#2010](https://github.com/commercialhaskell/stack/issues/2010) +* Fixes an issue where cyclic deps can cause benchmarks or tests to be run + before they are built. + See [#2153](https://github.com/commercialhaskell/stack/issues/2153) +* Fixes `stack build --file-watch` in cases where a directory is removed + See [#1838](https://github.com/commercialhaskell/stack/issues/1838) +* Fixes `stack dot` and `stack list-dependencies` to use info from the + package database for wired-in-packages (ghc, base, etc). + See [#3084](https://github.com/commercialhaskell/stack/issues/3084) +* Fixes `stack --docker build` when user is part of libvirt/libvirtd + groups on Ubuntu Yakkety (16.10). + See [#3092](https://github.com/commercialhaskell/stack/issues/3092) +* Switching a package between extra-dep and local package now forces + rebuild (previously it wouldn't if versions were the same). + See [#2147](https://github.com/commercialhaskell/stack/issues/2147) +* `stack upload` no longer reveals your password when you type it on + MinTTY-based Windows shells, such as Cygwin and MSYS2. + See [#3142](https://github.com/commercialhaskell/stack/issues/3142) +* `stack script`'s import parser will now properly parse files that + have Windows-style line endings (CRLF) + + ## 1.4.0 Release notes: diff --git a/doc/CONTRIBUTING.md b/doc/CONTRIBUTING.md --- a/doc/CONTRIBUTING.md +++ b/doc/CONTRIBUTING.md @@ -7,10 +7,10 @@ The more detailed your report, the faster it can be resolved and will ensure it is resolved in the right way. Once your bug has been resolved, the responsible -will tag the issue as _Needs confirmation_ and assign the issue back to you. -Once you have tested and confirmed that the issue is resolved, close the issue. -If you are not a member of the project, you will be asked for confirmation and -we will close it. +person will tag the issue as _Needs confirmation_ and assign the issue back to +you. Once you have tested and confirmed that the issue is resolved, close the +issue. If you are not a member of the project, you will be asked for +confirmation and we will close it. ## Documentation diff --git a/doc/ChangeLog.md b/doc/ChangeLog.md --- a/doc/ChangeLog.md +++ b/doc/ChangeLog.md @@ -1,5 +1,101 @@ # Changelog + +## 1.5.0 + +Behavior changes: + +* `stack profile` and `stack trace` now add their extra RTS arguments for + benchmarks and tests to the beginning of the args, instead of the end. + See [#2399](https://github.com/commercialhaskell/stack/issues/2399) +* Support for Git-based indices has been removed. + +Other enhancements: + +* `stack setup` allow to control options passed to ghcjs-boot with + `--ghcjs-boot-options` (one word at a time) and `--[no-]ghcjs-boot-clean` +* `stack setup` now accepts a `--install-cabal VERSION` option which + will install a specific version of the Cabal library globally. +* Updates to store-0.4.1, which has improved performance and better error + reporting for version tags. A side-effect of this is that all of + stack's binary caches will be invalidated. +* `stack solver` will now warn about unexpected cabal-install versions. + See [#3044](https://github.com/commercialhaskell/stack/issues/3044) +* Upstream packages unpacked to a temp dir are now deleted as soon as + possible to avoid running out of space in `/tmp`. + See [#3018](https://github.com/commercialhaskell/stack/issues/3018) +* Add short synonyms for `test-arguments` and `benchmark-arguments` options. +* Adds `STACK_WORK` environment variable, to specify work dir. + See [#3063](https://github.com/commercialhaskell/stack/issues/3063) +* Can now use relative paths for `extra-include-dirs` and `extra-lib-dirs`. + See [#2830](https://github.com/commercialhaskell/stack/issues/2830) +* Improved bash completion for many options, including `--ghc-options`, + `--flag`, targets, and project executables for `exec`. +* `--haddock-arguments` is actually used now when `haddock` is invoked + during documentation generation. +* `--[no-]haddock-hyperlink-source` flag added which allows toggling + of sources being included in Haddock output. + See [#3099](https://github.com/commercialhaskell/stack/issues/3099) +* `stack ghci` will now skip building all local targets, even if they have + downstream deps, as long as it's registered in the DB. +* The pvp-bounds feature now supports adding `-revision` to the end of + each value, e.g. `pvp-bounds: both-revision`. This means that, when + uploading to Hackage, Stack will first upload your tarball with an + unmodified `.cabal` file, and then upload a cabal file revision with + the PVP bounds added. This can be useful—especially combined + with the + [Stackage no-revisions feature](http://www.snoyman.com/blog/2017/04/stackages-no-revisions-field)—as + a method to ensure PVP compliance without having to proactively fix + bounds issues for Stackage maintenance. +* Expose a `save-hackage-creds` configuration option +* On GHC <= 7.8, filters out spurious linker warnings on windows + See [#3127](https://github.com/commercialhaskell/stack/pull/3127) +* Better error messages when creating or building packages which alias + wired-in packages. See + [#3172](https://github.com/commercialhaskell/stack/issues/3172). +* MinGW bin folder now is searched for dynamic libraries. See [#3126](https://github.com/commercialhaskell/stack/issues/3126) +* When using Nix, nix-shell now depends always on git to prevent runtime errors + while fetching metadata +* The `stack unpack` command now accepts a form where an explicit + Hackage revision hash is specified, e.g. `stack unpack + foo-1.2.3@gitsha1:deadbeef`. Note that this should be considered + _experimental_, Stack will likely move towards a different hash + format in the future. +* Binary "stack upgrade" will now warn if the installed executable is not + on the PATH or shadowed by another entry. +* Allow running tests on tarball created by sdist and upload + [#717](https://github.com/commercialhaskell/stack/issues/717). + +Bug fixes: + +* Fixes case where `stack build --profile` might not cause executables / + tests / benchmarks to be rebuilt. + See [#2984](https://github.com/commercialhaskell/stack/issues/2984) +* `stack ghci file.hs` now loads the file even if it isn't part of + your project. +* `stack clean --full` now works when docker is enabled. + See [#2010](https://github.com/commercialhaskell/stack/issues/2010) +* Fixes an issue where cyclic deps can cause benchmarks or tests to be run + before they are built. + See [#2153](https://github.com/commercialhaskell/stack/issues/2153) +* Fixes `stack build --file-watch` in cases where a directory is removed + See [#1838](https://github.com/commercialhaskell/stack/issues/1838) +* Fixes `stack dot` and `stack list-dependencies` to use info from the + package database for wired-in-packages (ghc, base, etc). + See [#3084](https://github.com/commercialhaskell/stack/issues/3084) +* Fixes `stack --docker build` when user is part of libvirt/libvirtd + groups on Ubuntu Yakkety (16.10). + See [#3092](https://github.com/commercialhaskell/stack/issues/3092) +* Switching a package between extra-dep and local package now forces + rebuild (previously it wouldn't if versions were the same). + See [#2147](https://github.com/commercialhaskell/stack/issues/2147) +* `stack upload` no longer reveals your password when you type it on + MinTTY-based Windows shells, such as Cygwin and MSYS2. + See [#3142](https://github.com/commercialhaskell/stack/issues/3142) +* `stack script`'s import parser will now properly parse files that + have Windows-style line endings (CRLF) + + ## 1.4.0 Release notes: diff --git a/doc/GUIDE.md b/doc/GUIDE.md --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -1425,7 +1425,7 @@ Please note that when adding upstream packages directly to your project it is important to distinguish _local packages_ from the upstream _dependency -packages_. Otherwise you may have trouble running `stack GHCi`. See +packages_. Otherwise you may have trouble running `stack ghci`. See [stack.yaml documentation](yaml_configuration.md#packages) for more details. ## Flags and GHC options @@ -1728,7 +1728,7 @@ ### Writing independent and reliable scripts -With the release of Stack 1.2.1, there is a new command, `script`, which will +With the release of Stack 1.4.0, there is a new command, `script`, which will automatically: * Install GHC and libraries if missing @@ -1771,6 +1771,22 @@ project and want to access the package databases and configurations used by that project. See the next section for more information on configuration files. +### Loading scripts in ghci + +Sometimes you want to load your script in ghci REPL to play around with your +program. In those cases, you can use `exec ghci` option in the script to achieve +it. Here is an example: + +``` +#!/usr/bin/env stack +{- stack + --resolver lts-8.2 + --install-ghc + exec ghci + --package text +-} +``` + ## Finding project configs, and the implicit global Whenever you run something with stack, it needs a `stack.yaml` project file. The @@ -2014,6 +2030,23 @@ and then run `stack image container` and then `docker images` to list the images. +Note that the executable will be built in the development environment +and copied to the container, so the dev OS must match that of the +container OS. This is easily accomplished using [Docker integration](docker_integration.md), +under which the exe emitted by `stack build` will be built on the +Docker container, not the local OS. + +The executable will be stored under `/usr/local/bin/-exe` +in the running container. + +If you want the container to run the executable immediately on startup +then set an entrypoint as follows: + +```yaml +entrypoints: + - -exe +``` + ### Nix stack provides an integration with [Nix](http://nixos.org/nix), @@ -2063,7 +2096,7 @@ tarball and unpacks it. * `stack sdist` generates an uploading tarball containing your package code * `stack upload` uploads an sdist to Hackage. As of - version [1.1.0](https://docs.haskellstack.org/en/latest/ChangeLog/#110) stack + version [1.1.0](https://docs.haskellstack.org/en/v1.1.0/ChangeLog/) stack will also attempt to GPG sign your packages as per [our blog post](https://www.fpcomplete.com/blog/2016/05/stack-security-gnupg-keys). diff --git a/doc/MAINTAINER_GUIDE.md b/doc/MAINTAINER_GUIDE.md --- a/doc/MAINTAINER_GUIDE.md +++ b/doc/MAINTAINER_GUIDE.md @@ -2,23 +2,30 @@ ## Next release: +* Adjust static binary build on Alpine. See + https://github.com/commercialhaskell/stack/issues/3045 +* For minor release, ensure https://github.com/commercialhaskell/stack/commit/d3637126b9045b266d2e53387e183915cb4a912d cherry-picked + ## Pre-release steps * Ensure `release` and `stable` branches merged to `master` * Check compatibility with latest nightly stackage snapshot: * Update `stack-nightly.yaml` with latest nightly and remove extra-deps - * Run `stack --stack-yaml=stack-nightly.yaml test` -* Ensure integration tests pass on a representative Windows, macOS, and Linux (Linux - is handled by Jenkins automatically): - `stack install --pedantic && stack test --pedantic --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 -* Ensure `stack haddock` works (Travis CI now does this) -* Stack builds with `stack-7.8.yaml` (Travis CI now does this) -* 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 + * Run `stack --stack-yaml=stack-nightly.yaml test --pedantic` +* Check pvp-bounds compatibility with Stackage snapshots: + * Create an sdist using `stack sdist --pvp-bounds=both` + * Temporarily replace `stack.cabal` with the `stack.cabal` in that sdist + * Run `stack --stack-yaml=stack-SNAPSHOT.yaml test --pedantic` for each + `stack-*.yaml` and adjust upper bounds in original `stack.cabal` until it + works with pvp-bounds. +* Ensure integration tests pass on a Windows, macOS, and Linux (Linux + integration tests are run + by + [Jenkins](https://jenkins-public.fpcomplete.com/job/stack-integration-tests)): + `stack install --pedantic && stack test --pedantic --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 * In master branch: * stack.cabal: bump the version number to release (even third component) @@ -27,8 +34,8 @@ * In master branch: * stack.cabal: bump version number to unstable (odd third component) * Changelog: add new "unreleased changes" section - * stack.yaml: bump to use latest LTS version, and check whether extra-deps - still needed + * stack-*.yaml: bump to use latest LTS minor version or nightly, and check + whether extra-deps still needed * In RC branch: * Update the ChangeLog: * Check for any important changes that missed getting an entry in @@ -41,13 +48,15 @@ `UNRELEASED` and replace with new version * Look for any links to "latest" documentation, replace with version tag * Ensure all documentation pages listed in `mkdocs.yaml` - * Update the ISSUE_TEMPLATE.md to point at the new version. - * (SKIP) Check that any new Linux distribution versions added to + * Update `.github/ISSUE_TEMPLATE.md` to point at the new version. + * + Check that any new Linux distribution versions added to `etc/scripts/release.hs` and `etc/scripts/vagrant-releases.sh` * [Ubuntu](https://wiki.ubuntu.com/Releases) * [Debian](https://www.debian.org/releases/) * [CentOS](https://wiki.centos.org/Download) * [Fedora](https://fedoraproject.org/wiki/Releases) + * Check for new [FreeBSD release](https://www.freebsd.org/releases/). * Check that no new entries need to be added to [releases.yaml](https://github.com/fpco/stackage-content/blob/master/stack/releases.yaml), @@ -115,17 +124,6 @@ * Upload package to Hackage: `stack upload . --pvp-bounds=both` -* On a machine with Vagrant installed: - * Run `etc/scripts/vagrant-distros.sh` - -* (SKIP) Submit a PR for the - [haskell-stack Homebrew formula](https://github.com/Homebrew/homebrew-core/blob/master/Formula/haskell-stack.rb) - * Ensure that the formula use the sdist uploaded to the Github release - * Be sure to update the SHA sum - * The commit message should just be `haskell-stack ` - -* (SKIP) [Flag the Arch Linux package as out-of-date](https://www.archlinux.org/packages/community/x86_64/stack/flag/) - * Push signed Git tag, matching Github release tag name, e.g.: `git tag -d vX.Y.Z; git tag -u 0x575159689BEFB442 vX.Y.Z && git push -f origin vX.Y.Z` * Reset the `release` branch to the released commit, e.g.: `git checkout release && git merge --ff-only vX.Y.Z && git push origin release` @@ -138,9 +136,21 @@ [readthedocs.org](https://readthedocs.org/dashboard/stack/versions/), and ensure that stable documentation has updated -* Upload haddocks to Hackage: `etc/scripts/upload-haddocks.sh` - * Merge any changes made in the RC/release/stable branches to master. + +* On a machine with Vagrant installed: + * Run `etc/scripts/vagrant-distros.sh` + +* Submit a PR for the + [haskell-stack Homebrew formula](https://github.com/Homebrew/homebrew-core/blob/master/Formula/haskell-stack.rb) + * Ensure that the formula use the sdist uploaded to the Github release + * Be sure to update the SHA sum + * The commit message should just be `haskell-stack ` + + +* [Flag the Arch Linux package as out-of-date](https://www.archlinux.org/packages/community/x86_64/stack/flag/) + +* Upload haddocks to Hackage: `etc/scripts/upload-haddocks.sh` (if they weren't auto-built) * Announce to haskell-cafe@haskell.org, haskell-stack@googlegroups.com, commercialhaskell@googlegroups.com mailing lists diff --git a/doc/README.md b/doc/README.md --- a/doc/README.md +++ b/doc/README.md @@ -23,22 +23,12 @@ wget -qO- https://get.haskellstack.org/ | sh -For detailed instructions and downloads, instructions are available by -operating system/distribution: - -* [Windows](install_and_upgrade.md#windows) -* [macOS](install_and_upgrade.md#macos) -* [Ubuntu](install_and_upgrade.md#ubuntu) -* [Debian](install_and_upgrade.md#debian) -* [CentOS / Red Hat / Amazon Linux](install_and_upgrade.md#centos) -* [Fedora](install_and_upgrade.md#fedora) -* [openSUSE / SUSE Linux Enterprise](install_and_upgrade.md#suse) -* [Arch Linux](install_and_upgrade.md#arch-linux) -* [NixOS](install_and_upgrade.md#nixos) -* [Linux (general)](install_and_upgrade.md#linux) -* [FreeBSD](install_and_upgrade.md#freebsd) +On Windows, you can download and install the +[Windows 64-bit Installer](https://www.stackage.org/stack/windows-x86_64-installer). -[Upgrade instructions](install_and_upgrade.md#upgrade) +For detailed instructions and downloads, including many additional +operating systems, check out the +[install and upgrade page](install_and_upgrade.md). #### Quick Start Guide @@ -154,23 +144,33 @@ * When using Stack Overflow, please use [the haskell-stack tag](http://stackoverflow.com/questions/tagged/haskell-stack). -#### Why stack? +#### Why Stack? -stack is a project of the [Commercial Haskell](http://commercialhaskell.com/) -group, spearheaded by [FP Complete](https://www.fpcomplete.com/). It is -designed to answer the needs of commercial Haskell users, hobbyist Haskellers, -and individuals and companies thinking about starting to use Haskell. It is -intended to be easy to use for newcomers, while providing the customizability -and power experienced developers need. +Stack is a build tool for Haskell designed to answer the needs of +Haskell users new and experienced alike. It has a strong focus on +reproducible build plans, multi-package projects, and a consistent, +easy-to-learn interface, while providing the customizability and +power experienced developers need. As a build tool, Stack does not +stand alone. It is built on the great work provided by: -While stack itself has been around since June of 2015, it is based on codebases -used by FP Complete for its corporate customers and internally for years prior. -stack is a refresh of that codebase combined with other open source efforts -like [stackage-cli](https://github.com/fpco/stackage-cli) to meet the needs of -users everywhere. +* The __Glasgow Haskell Compiler__ (GHC), the premiere Haskell + compiler. Stack will manage your GHC installations and automatically + select the appropriate compiler version for your project. +* The __Cabal build system__, a specification for defining Haskell + packages, together with a library for performing builds. +* The __Hackage package repository__, providing more than ten thousand + open source libraries and applications to help you get your work + done. +* The __Stackage package collection__, a curated set of packages from + Hackage which are regularly tested for compatibility. Stack defaults + to using Stackage package sets to avoid dependency problems. -A large impetus for the work on stack was a [large survey of people interested -in -Haskell](https://www.fpcomplete.com/blog/2015/05/thousand-user-haskell-survey), -which rated build issues as a major concern. The stack team hopes that stack -can address these concerns. +Stack is provided by a team of volunteers and companies under the +auspices of the [Commercial Haskell](http://commercialhaskell.com/) +group. The project was spearheaded by +[FP Complete](https://www.fpcomplete.com/) to answer the needs of +commercial Haskell users, and has since become a thriving open source +project meeting the needs of Haskell users of all stripes. + +If you'd like to get involved with Stack, check out the +[newcomers label on the Github issue tracker](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3Anewcomer). diff --git a/doc/build_command.md b/doc/build_command.md --- a/doc/build_command.md +++ b/doc/build_command.md @@ -86,6 +86,7 @@ * `packagename:comptype:compname` is the most explicit. The available comptypes are `exe`, `test`, and `bench`. + * Side note: When any `exe` component is specified, all of the package's executable components will be built. This is due to limitations in all currently released versions of Cabal. See [issue#1046](https://github.com/commercialhaskell/stack/issues/1406) * `packagename:compname` allows you to leave off the component type, as that will (almost?) always be redundant with the component name. For example, `stack build mypackage:mytestsuite`. diff --git a/doc/custom_snapshot.md b/doc/custom_snapshot.md --- a/doc/custom_snapshot.md +++ b/doc/custom_snapshot.md @@ -113,7 +113,7 @@ resolver: lts-7.1 packages: - text-1.2.2.1 -ghc-options: +flags: text: developer: true ``` diff --git a/doc/docker_integration.md b/doc/docker_integration.md --- a/doc/docker_integration.md +++ b/doc/docker_integration.md @@ -1,6 +1,10 @@ Docker integration =============================================================================== +**Note:** This page is mainly about building Haskell packages inside docker containers. +If you want to deploy your built Haskell programs into a docker container, +look [here](GUIDE.md#docker) instead. + `stack` has support for automatically performing builds inside a Docker container, using volume mounts and user ID switching to make it mostly seamless. FP Complete provides images for use with stack that include GHC, tools, and diff --git a/doc/faq.md b/doc/faq.md --- a/doc/faq.md +++ b/doc/faq.md @@ -4,6 +4,34 @@ below, see the [Architecture](architecture.md) page. The goal of the answers here is to be as helpful and concise as possible. +## What version of GHC is used when I run something like `stack ghci`? + +The version of GHC, as well as which packages can be installed, are +specified by the _resolver_. This may be something like `lts-8.12`, +which is from the +[Long Term Support (LTS) Haskell](https://github.com/fpco/lts-haskell/) +project. The [user guide](GUIDE.md) discusses resolvers in more +detail. + +Which resolver is used is determined by finding the relevant +`stack.yaml` configuration file for the directory you're running the +command from. This essentially works by: + +1. Check for a `STACK_YAML` environment variable or the `--stack-yaml` + command line argument +2. If none present, check for a `stack.yaml` file in the current + directory or any parents +3. If no `stack.yaml` was found, use the _implicit global_ + +The implicit global is a shared project used whenever you're outside +of another project. It's a sort of "mutable shared state" that you +should be aware of when working with Stack. The most recent request +when working with the implicit global is how to move to a more recent +LTS snapshot. You can do this by running the following from outside of +a project: + + stack config set resolver lts + ## Where is stack installed and will it interfere with `ghc` (etc) I already have installed? Stack itself is installed in normal system locations based on the mechanism you diff --git a/doc/ghcjs.md b/doc/ghcjs.md --- a/doc/ghcjs.md +++ b/doc/ghcjs.md @@ -9,6 +9,9 @@ You can also build existing stack projects which target GHC, and instead build them with GHCJS. For example: `stack build --compiler ghcjs-0.2.0.9006020_ghc-7.10.3` +There are advanced options for `stack setup`: `--ghcjs-boot-options` (one word at a time) and `--[no-]ghcjs-boot-clean` +which will passyour settings down to the `ghcjs-boot`. You will need to know exacty what you are doing with them. + Sidenote: If you receive a message like `The program 'ghcjs' version >=0.1 is required but the version of .../ghcjs could not be determined.`, then you may need to install a different version of `node`. See 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 @@ -24,54 +24,32 @@ ## 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:* 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) + * [Windows 32-bit Installer](https://www.stackage.org/stack/windows-i386-installer) +If in doubt: you should prefer the 64-bit 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) + * [Windows 32-bit](https://www.stackage.org/stack/windows-i386) * 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. - ## macOS We generally test on the current version of macOS, but Stack is known to work -on El Capitan, Yosemite and Mavericks as well, and may also work on older +on Sierra, El Capitan, Yosemite and Mavericks as well, and may also work on older versions (YMMV). -**macOS Sierra warning**: There are new limitations in the dynamic linker that -are causing problems for GHC versions earlier than 8.0.2 when building projects with many -dependencies. GHC 8.0.2 is first used in LTS 8.0. See -[#2577](https://github.com/commercialhaskell/stack/issues/2577) for more -information. - ### Installer script Run: @@ -88,10 +66,7 @@ ### Using Homebrew -**macOS Sierra warning**: Homebrew's haskell-stack formula may not currently -work on Sierra, so we suggest using the manual method above for now. - -If you have a popular [brew](http://brew.sh/) tool installed, you can just do: +If you have the popular [brew](https://brew.sh/) tool installed, you can just do: brew install haskell-stack @@ -100,7 +75,7 @@ * Normally, Homebrew will install from a pre-built binary (aka "pour from a bottle"), but if `brew` starts trying to build everything from source (which will take hours), see -[their FAQ on the topic](https://github.com/Homebrew/homebrew/blob/master/share/doc/homebrew/FAQ.md#why-do-you-compile-everything). +[their FAQ on the topic](https://github.com/Homebrew/brew/blob/master/docs/FAQ.md#why-do-you-compile-everything). ### Notes @@ -113,7 +88,10 @@ * [GHC 7.8.4 fails with `/usr/bin/ar: permission denied`](faq.md#usr-bin-ar-permission-denied) * [DYLD_LIBRARY_PATH is ignored](faq.md#dyld-library-path-ignored) + +If you are on OS X 10.12 ("Sierra") and encounter [GHC panic while building, see this issue](https://github.com/commercialhaskell/stack/issues/2577) + ## Ubuntu Use the [generic Linux option](#linux). @@ -297,10 +275,6 @@ * Extract the archive and place `stack` somewhere on your `$PATH` (see [Path section below](#path)) * Now you can run `stack` from the terminal. - -An unofficial package repository for FreeBSD 10 (amd64 only) and install -instructions are available at [http://stack-pkg.applicative.tech](http://stack-pkg.applicative.tech/). The -repository is not official and as such might lag behind new releases. ## Path diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -16,8 +16,9 @@ - The project file itself may also contain non-project specific options *Note:* When stack is invoked outside a stack project it will source project -specific options from `~/.stack/global/stack.yaml`. Options in this file will -be ignored for a project with its own `/stack.yaml`. +specific options from `~/.stack/global-project/stack.yaml`. When stack is +invoked inside a stack project, only options from `/stack.yaml` are +used, and `~/.stack/global-project/stack.yaml` is ignored. ## Project-specific config @@ -127,6 +128,11 @@ - wai ``` +If unspecified, `subdirs` defaults to `['.']` (i.e. look only in the top-level +directory). Note that if you specify a value of `subdirs`, then `'.'` is _not_ +included by default and needs to be explicitly specified if a required package +is found in the top-level directory of the repository. + #### Local dependency packages (`extra-dep`) A `location` key can be accompanied by an `extra-dep` key. When the `extra-dep` key is set to `true` it indicates that the package should be @@ -314,12 +320,13 @@ - name: Hackage download-prefix: https://s3.amazonaws.com/hackage.fpcomplete.com/package/ - # at least one of the following must be present - git: https://github.com/commercialhaskell/all-cabal-hashes.git + # HTTP location of the package index http: https://s3.amazonaws.com/hackage.fpcomplete.com/00-index.tar.gz + # Or, if using Hackage Security below, give the root URL: + http: https://s3.amazonaws.com/hackage.fpcomplete.com/ + # optional fields, both default to false - gpg-verify: false require-hashes: false # Starting with stack 1.4, we default to using Hackage Security @@ -332,6 +339,15 @@ combination by setting a different package index, this *can* have an effect on other projects by installing into your shared snapshot database. +Note that older versions of Stack supported Git-based indices. This feature has since been removed. A line such as: + +```yaml +git: https://github.com/commercialhaskell/all-cabal-hashes.git +gpg-verify: false +``` + +Will now be ignored. + ### system-ghc Enables or disables using the GHC available on the PATH. @@ -537,6 +553,16 @@ For more information, see [the announcement blog post](https://www.fpcomplete.com/blog/2015/09/stack-pvp). +__NOTE__ Since Stack 1.5.0, each of the values listed above supports +adding `-revision` to the end of each value, e.g. `pvp-bounds: +both-revision`. This means that, when uploading to Hackage, Stack will +first upload your tarball with an unmodified `.cabal` file, and then +upload a cabal file revision with the PVP bounds added. This can be +useful—especially combined with the +[Stackage no-revisions feature](http://www.snoyman.com/blog/2017/04/stackages-no-revisions-field)—as +a method to ensure PVP compliance without having to proactively fix +bounds issues for Stackage maintenance. + ### modify-code-page (Since 0.1.6) @@ -719,6 +745,17 @@ templates: scm-init: git ``` + +### save-hackage-creds + +Controls whether, when using `stack upload`, the user's Hackage +username and password are stored in a local file. Default: true. + +```yaml +save-hackage-creds: true +``` + +Since 1.5.0 # urls diff --git a/src/Data/Store/VersionTagged.hs b/src/Data/Store/VersionTagged.hs --- a/src/Data/Store/VersionTagged.hs +++ b/src/Data/Store/VersionTagged.hs @@ -25,6 +25,7 @@ import Data.Monoid ((<>)) import qualified Data.Set as S import Data.Store +import Data.Store.Core (unsafeEncodeWith) import Data.Store.Version import qualified Data.Text as T import Language.Haskell.TH @@ -33,40 +34,43 @@ import Prelude versionedEncodeFile :: Data a => VersionConfig a -> Q Exp -versionedEncodeFile vc = [e| \fp x -> storeEncodeFile fp ($(wrapVersion vc) x) |] +versionedEncodeFile vc = [e| storeEncodeFile $(encodeWithVersionQ vc) $(decodeWithVersionQ vc) |] versionedDecodeOrLoad :: Data a => VersionConfig a -> Q Exp -versionedDecodeOrLoad vc = [| versionedDecodeOrLoadImpl $(wrapVersion vc) $(checkVersion vc) |] +versionedDecodeOrLoad vc = [| versionedDecodeOrLoadImpl $(encodeWithVersionQ vc) $(decodeWithVersionQ vc) |] versionedDecodeFile :: Data a => VersionConfig a -> Q Exp -versionedDecodeFile vc = [e| versionedDecodeFileImpl $(checkVersion vc) |] +versionedDecodeFile vc = [e| versionedDecodeFileImpl $(decodeWithVersionQ vc) |] -- | Write to the given file. storeEncodeFile :: (Store a, MonadIO m, MonadLogger m, Eq a) - => Path Abs File + => (a -> (Int, Poke ())) + -> Peek a + -> Path Abs File -> a -> m () -storeEncodeFile fp x = do +storeEncodeFile pokeFunc peekFunc fp x = do let fpt = T.pack (toFilePath fp) $logDebug $ "Encoding " <> fpt ensureDir (parent fp) - let encoded = encode x - assert (decodeEx encoded == x) $ liftIO $ BS.writeFile (toFilePath fp) encoded + let (sz, poker) = pokeFunc x + encoded = unsafeEncodeWith poker sz + assert (decodeExWith peekFunc encoded == x) $ liftIO $ BS.writeFile (toFilePath fp) encoded $logDebug $ "Finished writing " <> fpt -- | 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. versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadIO m, MonadLogger m, MonadBaseControl IO m) - => (a -> WithVersion a) - -> (WithVersion a -> Either VersionCheckException a) + => (a -> (Int, Poke ())) + -> Peek a -> Path Abs File -> m a -> m a -versionedDecodeOrLoadImpl wrap check fp mx = do +versionedDecodeOrLoadImpl pokeFunc peekFunc fp mx = do let fpt = T.pack (toFilePath fp) $logDebug $ "Trying to decode " <> fpt - mres <- versionedDecodeFileImpl check fp + mres <- versionedDecodeFileImpl peekFunc fp case mres of Just x -> do $logDebug $ "Success decoding " <> fpt @@ -74,24 +78,21 @@ _ -> do $logDebug $ "Failure decoding " <> fpt x <- mx - storeEncodeFile fp (wrap x) + storeEncodeFile pokeFunc peekFunc fp x return x versionedDecodeFileImpl :: (Store a, MonadIO m, MonadLogger m, MonadBaseControl IO m) - => (WithVersion a -> Either VersionCheckException a) + => Peek a -> Path loc File -> m (Maybe a) -versionedDecodeFileImpl check fp = do +versionedDecodeFileImpl peekFunc fp = do mbs <- liftIO (Just <$> BS.readFile (toFilePath fp)) `catch` \(err :: IOException) -> do $logDebug ("Exception ignored when attempting to load " <> T.pack (toFilePath fp) <> ": " <> T.pack (show err)) return Nothing case mbs of Nothing -> return Nothing Just bs -> - liftIO (do decoded <- decodeIO bs - return $ case check decoded of - Right res -> Just res - _ -> Nothing) `catch` \(err :: PeekException) -> do + liftIO (Just <$> decodeIOWith peekFunc bs) `catch` \(err :: PeekException) -> do let fpt = T.pack (toFilePath fp) $logDebug ("Error while decoding " <> fpt <> ": " <> T.pack (show err) <> " (this might not be an error, when switching between stack versions)") return Nothing 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 @@ -1,3 +1,6 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + -- | Extra functions for optparse-applicative. module Options.Applicative.Builder.Extra @@ -17,18 +20,29 @@ ,absDirOption ,relDirOption ,eitherReader' + ,fileCompleter + ,fileExtCompleter + ,dirCompleter + ,PathCompleterOpts(..) + ,defaultPathCompleterOpts + ,pathCompleterWith + ,unescapeBashArg ) where -import Control.Monad (when) +import Control.Exception (IOException, catch) +import Control.Monad (when, forM) import Data.Either.Combinators +import Data.List (isPrefixOf) +import Data.Maybe import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T import Options.Applicative import Options.Applicative.Types (readerAsk) -import Path +import Path hiding (()) +import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist) import System.Environment (withArgs) -import System.FilePath (takeBaseName) -import Data.Text (Text) -import qualified Data.Text as T +import System.FilePath (takeBaseName, (), splitFileName, isRelative, takeExtension) -- | Enable/disable flags for a 'Bool'. boolFlags :: Bool -- ^ Default value @@ -145,17 +159,98 @@ optionalFirst = fmap First . optional absFileOption :: Mod OptionFields (Path Abs File) -> Parser (Path Abs File) -absFileOption = option (eitherReader' parseAbsFile) +absFileOption mods = option (eitherReader' parseAbsFile) $ + completer (pathCompleterWith defaultPathCompleterOpts { pcoRelative = False }) <> mods relFileOption :: Mod OptionFields (Path Rel File) -> Parser (Path Rel File) -relFileOption = option (eitherReader' parseRelFile) +relFileOption mods = option (eitherReader' parseRelFile) $ + completer (pathCompleterWith defaultPathCompleterOpts { pcoAbsolute = False }) <> mods absDirOption :: Mod OptionFields (Path Abs Dir) -> Parser (Path Abs Dir) -absDirOption = option (eitherReader' parseAbsDir) +absDirOption mods = option (eitherReader' parseAbsDir) $ + completer (pathCompleterWith defaultPathCompleterOpts { pcoRelative = False, pcoFileFilter = const False }) <> mods relDirOption :: Mod OptionFields (Path Rel Dir) -> Parser (Path Rel Dir) -relDirOption = option (eitherReader' parseRelDir) +relDirOption mods = option (eitherReader' parseRelDir) $ + completer (pathCompleterWith defaultPathCompleterOpts { pcoAbsolute = False, pcoFileFilter = const False }) <> mods -- | Like 'eitherReader', but accepting any @'Show' e@ on the 'Left'. eitherReader' :: Show e => (String -> Either e a) -> ReadM a eitherReader' f = eitherReader (mapLeft show . f) + +data PathCompleterOpts = PathCompleterOpts + { pcoAbsolute :: Bool + , pcoRelative :: Bool + , pcoRootDir :: Maybe FilePath + , pcoFileFilter :: FilePath -> Bool + , pcoDirFilter :: FilePath -> Bool + } + +defaultPathCompleterOpts :: PathCompleterOpts +defaultPathCompleterOpts = PathCompleterOpts + { pcoAbsolute = True + , pcoRelative = True + , pcoRootDir = Nothing + , pcoFileFilter = const True + , pcoDirFilter = const True + } + +fileCompleter :: Completer +fileCompleter = pathCompleterWith defaultPathCompleterOpts + +fileExtCompleter :: [String] -> Completer +fileExtCompleter exts = pathCompleterWith defaultPathCompleterOpts { pcoFileFilter = (`elem` exts) . takeExtension } + +dirCompleter :: Completer +dirCompleter = pathCompleterWith defaultPathCompleterOpts { pcoFileFilter = const False } + +pathCompleterWith :: PathCompleterOpts -> Completer +pathCompleterWith PathCompleterOpts {..} = mkCompleter $ \inputRaw -> do + -- Unescape input, to handle single and double quotes. Note that the + -- results do not need to be re-escaped, due to some fiddly bash + -- magic. + let input = unescapeBashArg inputRaw + let (inputSearchDir0, searchPrefix) = splitFileName input + inputSearchDir = if inputSearchDir0 == "./" then "" else inputSearchDir0 + msearchDir <- + case (isRelative inputSearchDir, pcoAbsolute, pcoRelative) of + (True, _, True) -> do + rootDir <- maybe getCurrentDirectory return pcoRootDir + return $ Just (rootDir inputSearchDir) + (False, True, _) -> return $ Just inputSearchDir + _ -> return Nothing + case msearchDir of + Nothing + | input == "" && pcoAbsolute -> return ["/"] + | otherwise -> return [] + Just searchDir -> do + entries <- getDirectoryContents searchDir `catch` \(_ :: IOException) -> return [] + fmap catMaybes $ forM entries $ \entry -> + -- Skip . and .. unless user is typing . or .. + if entry `elem` ["..", "."] && searchPrefix `notElem` ["..", "."] then return Nothing else + if searchPrefix `isPrefixOf` entry + then do + let path = searchDir entry + case (pcoFileFilter path, pcoDirFilter path) of + (True, True) -> return $ Just (inputSearchDir entry) + (fileAllowed, dirAllowed) -> do + isDir <- doesDirectoryExist path + if (if isDir then dirAllowed else fileAllowed) + then return $ Just (inputSearchDir entry) + else return Nothing + else return Nothing + +unescapeBashArg :: String -> String +unescapeBashArg ('\'' : rest) = rest +unescapeBashArg ('\"' : rest) = go rest + where + go [] = [] + go ('\\' : x : xs) + | x `elem` "$`\"\\\n" = x : xs + | otherwise = '\\' : x : go xs + go (x : xs) = x : go xs +unescapeBashArg input = go input + where + go [] = [] + go ('\\' : x : xs) = x : go xs + go (x : xs) = x : go xs diff --git a/src/Options/Applicative/Complicated.hs b/src/Options/Applicative/Complicated.hs --- a/src/Options/Applicative/Complicated.hs +++ b/src/Options/Applicative/Complicated.hs @@ -53,7 +53,7 @@ Failure f | Just onFailure <- mOnFailure -> onFailure f args parseResult -> handleParseResult parseResult return (mappend c a,b) - where parser = info (helpOption <*> versionOptions <*> complicatedParser commonParser commandParser) desc + where parser = info (helpOption <*> versionOptions <*> complicatedParser "COMMAND|FILE" commonParser commandParser) desc desc = fullDesc <> header h <> progDesc pd <> footer footerStr versionOptions = case versionString of @@ -106,7 +106,7 @@ footerStr (\(c1,(a,c2)) c3 -> (a,mconcat [c3, c2, c1])) commonParser - (complicatedParser commonParser commandParser) + (complicatedParser "COMMAND" commonParser commandParser) -- | Add a command to the options dispatcher. addCommand' :: String -- ^ command string @@ -124,24 +124,26 @@ -- | Generate a complicated options parser. complicatedParser :: Monoid a - => Parser a + => String + -- ^ metavar for the sub-command + -> Parser a -- ^ common settings -> EitherT b (Writer (Mod CommandFields (b,a))) () -- ^ commands (use 'addCommand') -> Parser (a,(b,a)) -complicatedParser commonParser commandParser = +complicatedParser commandMetavar commonParser commandParser = (,) <$> commonParser <*> case runWriter (runEitherT commandParser) of - (Right (),d) -> hsubparser' d + (Right (),d) -> hsubparser' commandMetavar d (Left b,_) -> pure (b,mempty) --- way to do in 'addCommand' | Subparser with @--help@ argument. Borrowed with slight modification +-- | Subparser with @--help@ argument. Borrowed with slight modification -- from Options.Applicative.Extra. -hsubparser' :: Mod CommandFields a -> Parser a -hsubparser' m = mkParser d g rdr +hsubparser' :: String -> Mod CommandFields a -> Parser a +hsubparser' commandMetavar m = mkParser d g rdr where - Mod _ d g = metavar "COMMAND|FILE" `mappend` m + Mod _ d g = metavar commandMetavar `mappend` m (groupName, cmds, subs) = mkCommand m rdr = CmdReader groupName cmds (fmap add_helper . subs) add_helper pinfo = pinfo diff --git a/src/Path/CheckInstall.hs b/src/Path/CheckInstall.hs new file mode 100644 --- /dev/null +++ b/src/Path/CheckInstall.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module Path.CheckInstall where + +import Control.Monad (unless) +import Control.Monad.Extra (anyM, (&&^)) +import Control.Monad.IO.Class +import Control.Monad.Logger +import Data.Foldable (forM_) +import Data.Text (Text) +import qualified Data.Text as T +import qualified System.Directory as D +import qualified System.FilePath as FP + +-- | Checks if the installed executable will be available on the user's +-- PATH. This doesn't use @envSearchPath menv@ because it includes paths +-- only visible when running in the stack environment. +warnInstallSearchPathIssues :: (MonadIO m, MonadLogger m) => FilePath -> [Text] -> m () +warnInstallSearchPathIssues destDir installed = do + searchPath <- liftIO FP.getSearchPath + destDirIsInPATH <- liftIO $ + anyM (\dir -> D.doesDirectoryExist dir &&^ fmap (FP.equalFilePath destDir) (D.canonicalizePath dir)) searchPath + if destDirIsInPATH + then forM_ installed $ \exe -> do + mexePath <- (liftIO . D.findExecutable . T.unpack) exe + case mexePath of + Just exePath -> do + exeDir <- (liftIO . fmap FP.takeDirectory . D.canonicalizePath) exePath + unless (exeDir `FP.equalFilePath` destDir) $ do + $logWarn "" + $logWarn $ T.concat + [ "WARNING: The \"" + , exe + , "\" executable found on the PATH environment variable is " + , T.pack exePath + , ", and not the version that was just installed." + ] + $logWarn $ T.concat + [ "This means that \"" + , exe + , "\" calls on the command line will not use this version." + ] + Nothing -> do + $logWarn "" + $logWarn $ T.concat + [ "WARNING: Installation path " + , T.pack destDir + , " is on the PATH but the \"" + , exe + , "\" executable that was just installed could not be found on the PATH." + ] + else do + $logWarn "" + $logWarn $ T.concat + [ "WARNING: Installation path " + , T.pack destDir + , " not found on the PATH environment variable" + ] diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -58,7 +58,6 @@ import Stack.Build.Source import Stack.Build.Target import Stack.Fetch as Fetch -import Stack.GhcPkg import Stack.Package import Stack.PackageIndex import Stack.PrettyPrint @@ -69,6 +68,7 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.StackT +import Stack.Types.StringError import Stack.Types.Version #ifdef WINDOWS @@ -97,7 +97,7 @@ let symbols = not (boptsLibStrip bopts || boptsExeStrip bopts) menv <- getMinimalEnvOverride - (targets, mbp, locals, extraToBuild, extraDeps, sourceMap) <- loadSourceMapFull True NeedTargets boptsCli + (targets, mbp, locals, extraToBuild, extraDeps, sourceMap) <- loadSourceMapFull NeedTargets boptsCli -- Set local files, necessary for file watching stackYaml <- view stackYamlL @@ -117,8 +117,8 @@ warnMissingExtraDeps installedMap extraDeps baseConfigOpts <- mkBaseConfigOpts boptsCli - plan <- withLoadPackage menv $ \loadPackage -> - constructPlan mbp baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap + plan <- withLoadPackage $ \loadPackage -> + constructPlan mbp baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli) allowLocals <- view $ configL.to configAllowLocals unless allowLocals $ case justLocals plan of @@ -312,12 +312,11 @@ -- | Provide a function for loading package information from the package index withLoadPackage :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) - => EnvOverride - -> ((PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -> m a) + => ((PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -> m a) -> m a -withLoadPackage menv inner = do +withLoadPackage inner = do econfig <- view envConfigL - withCabalLoader menv $ \cabalLoader -> + withCabalLoader $ \cabalLoader -> inner $ \name version flags ghcOptions -> do bs <- cabalLoader $ PackageIdentifier name version @@ -412,7 +411,7 @@ _ -> err $ "Cannot apply selector to " ++ show value where cont = select (front . (sel:)) sels - err msg = error $ msg ++ ": " ++ show (front [sel]) + err msg = errorString $ msg ++ ": " ++ show (front [sel]) -- | Get the raw build information object rawBuildInfo :: (StackM env m, HasEnvConfig env) => m Value 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 @@ -37,7 +37,7 @@ import Control.Monad (liftM) import Control.Monad.Catch (MonadThrow, MonadCatch) import Control.Monad.IO.Class -import Control.Monad.Logger (MonadLogger, logDebug) +import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader (MonadReader) import Control.Monad.Trans.Control (MonadBaseControl) import Crypto.Hash (hashWith, SHA256(..)) @@ -54,7 +54,6 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (fromMaybe, mapMaybe) -import Data.Monoid ((<>)) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Store as Store @@ -280,7 +279,6 @@ pkg hashPath - $logDebug $ "Precompiled cache input = " <> T.pack (show input) newPath <- hashToPath $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ Store.encode input return (newPath, hashToPath oldHash) 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 @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} @@ -10,6 +11,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} -- | Construct a @Plan@ for how to build module Stack.Build.ConstructPlan ( constructPlan @@ -24,7 +26,9 @@ import Control.Monad.Trans.Resource import Data.Either import Data.Function +import qualified Data.HashSet as HashSet import Data.List +import Data.List.Extra (nubOrd) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map @@ -68,8 +72,17 @@ import System.Process.Read (findExecutable) data PackageInfo - = PIOnlyInstalled InstallLocation Installed + = + -- | This indicates that the package is already installed, and + -- that we shouldn't build it from source. This is always the case + -- for snapshot packages. + PIOnlyInstalled InstallLocation Installed + -- | This indicates that the package isn't installed, and we know + -- where to find its source (either a hackage package or a local + -- directory). | PIOnlySource PackageSource + -- | This indicates that the package is installed and we know + -- where to find its source. We may want to reinstall from source. | PIBoth PackageSource Installed deriving (Show) @@ -144,6 +157,22 @@ instance HasEnvConfig Ctx where envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y }) +-- | Computes a build plan. This means figuring out which build 'Task's +-- to take, and the interdependencies among the build 'Task's. In +-- particular: +-- +-- 1) It determines which packages need to be built, based on the +-- transitive deps of the current targets. For local packages, this is +-- indicated by the 'lpWanted' boolean. For extra packages to build, +-- this comes from the @extraToBuild0@ argument of type @Set +-- PackageName@. These are usually packages that have been specified on +-- the commandline. +-- +-- 2) It will only rebuild an upstream package if it isn't present in +-- the 'InstalledMap', or if some of its dependencies have changed. +-- +-- 3) It will only rebuild a local package if its files are dirty or +-- some of its dependencies have changed. constructPlan :: forall env m. (StackM env m, HasEnvConfig env) => MiniBuildPlan -> BaseConfigOpts @@ -153,8 +182,9 @@ -> (PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -- ^ load upstream package -> SourceMap -> InstalledMap + -> Bool -> m Plan -constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap = do +constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap initialBuildSteps = do $logDebug "Constructing the build plan" getVersions0 <- getPackageVersionsIO @@ -185,7 +215,7 @@ return $ takeSubset Plan { planTasks = tasks , planFinals = M.fromList finals - , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap + , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap initialBuildSteps , planInstallExes = if boptsInstallExes $ bcoBuildOpts baseConfigOpts0 then installExes @@ -209,7 +239,7 @@ , callStack = [] , extraToBuild = extraToBuild0 , getVersions = getVersions0 - , wanted = wantedLocalPackages locals + , wanted = wantedLocalPackages locals <> extraToBuild0 , localNames = Set.fromList $ map (packageName . lpPackage) locals , logFunc = lf } @@ -235,8 +265,11 @@ -> [DumpPackage () () ()] -- ^ Local package database dump -> SourceMap + -> Bool + -- ^ If true, we're doing a special initialBuildSteps + -- build - don't unregister target packages. -> Map GhcPkgId (PackageIdentifier, Text) -mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap = +mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap initialBuildSteps = -- We'll take multiple passes through the local packages. This -- will allow us to detect that a package should be unregistered, -- as well as all packages directly or transitively depending on @@ -279,9 +312,12 @@ go' toUnregister ident deps -- If we're planning on running a task on it, then it must be - -- unregistered - | Just _ <- Map.lookup name tasks - = Just $ fromMaybe "" $ Map.lookup name dirtyReason + -- unregistered, unless it's a target and an initial-build-steps + -- build is being done. + | Just task <- Map.lookup name tasks + = if initialBuildSteps && taskIsTarget task && taskProvides task == ident + then Nothing + else Just $ fromMaybe "" $ Map.lookup name dirtyReason -- Check if we're no longer using the local version | Just (PSUpstream _ Snap _ _ _) <- Map.lookup name sourceMap = Just "Switching to snapshot installed package" @@ -293,9 +329,20 @@ where name = packageIdentifierName ident +-- | Given a 'LocalPackage' and its 'lpTestBench', adds a 'Task' for +-- running its tests and benchmarks. +-- +-- If @isAllInOne@ is 'True', then this means that the build step will +-- also build the tests. Otherwise, this indicates that there's a cyclic +-- dependency and an additional build step needs to be done. +-- +-- This will also add all the deps needed to build the tests / +-- benchmarks. If @isAllInOne@ is 'True' (the common case), then all of +-- these should have already been taken care of as part of the build +-- step. addFinal :: LocalPackage -> Package -> Bool -> M () addFinal lp package isAllInOne = do - depsRes <- addPackageDeps False package + depsRes <- addPackageDeps package res <- case depsRes of Left e -> return $ Left e Right (missing, present, _minLoc) -> do @@ -316,9 +363,20 @@ , taskPresent = present , taskType = TTLocal lp , taskAllInOne = isAllInOne + , taskCachePkgSrc = CacheSrcLocal (toFilePath (lpDir lp)) } tell mempty { wFinals = Map.singleton (packageName package) res } +-- | Given a 'PackageName', adds all of the build tasks to build the +-- package, if needed. +-- +-- 'constructPlan' invokes this on all the target packages, setting +-- @treatAsDep'@ to False, because those packages are direct build +-- targets. 'addPackageDeps' invokes this while recursing into the +-- dependencies of a package. As such, it sets @treatAsDep'@ to True, +-- forcing this package to be marked as a dependency, even if it is +-- directly wanted. This makes sense - if we left out packages that are +-- deps, it would break the --only-dependencies build plan. addDep :: Bool -- ^ is this being used by a dependency? -> PackageName -> M (Either ConstructPlanException AddDepRes) @@ -349,10 +407,10 @@ return $ Right $ ADRFound loc installed Just (PIOnlySource ps) -> do tellExecutables name ps - installPackage treatAsDep name ps Nothing + installPackage name ps Nothing Just (PIBoth ps installed) -> do tellExecutables name ps - installPackage treatAsDep name ps (Just installed) + installPackage name ps (Just installed) updateLibMap name res return res @@ -394,30 +452,32 @@ | Set.null myComps = x | otherwise = Set.intersection x myComps -installPackage :: Bool -- ^ is this being used by a dependency? - -> PackageName - -> PackageSource - -> Maybe Installed - -> M (Either ConstructPlanException AddDepRes) -installPackage treatAsDep name ps minstalled = do +-- | Given a 'PackageSource' and perhaps an 'Installed' value, adds +-- build 'Task's for the package and its dependencies. +installPackage + :: PackageName + -> PackageSource + -> Maybe Installed + -> M (Either ConstructPlanException AddDepRes) +installPackage name ps minstalled = do ctx <- ask case ps of PSUpstream version _ flags ghcOptions _ -> do planDebug $ "installPackage: Doing all-in-one build for upstream package " ++ show name package <- liftIO $ loadPackage ctx name version flags ghcOptions - resolveDepsAndInstall True treatAsDep ps package minstalled + resolveDepsAndInstall True ps package minstalled PSLocal lp -> case lpTestBench lp of Nothing -> do planDebug $ "installPackage: No test / bench component for " ++ show name ++ " so doing an all-in-one build." - resolveDepsAndInstall True treatAsDep ps (lpPackage lp) minstalled + resolveDepsAndInstall True 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 + res <- addPackageDeps tb let writerFunc w = case res of Left _ -> mempty _ -> w @@ -438,7 +498,7 @@ put s -- Otherwise, fall back on building the -- tests / benchmarks in a separate step. - res' <- resolveDepsAndInstall False treatAsDep ps (lpPackage lp) minstalled + res' <- resolveDepsAndInstall False ps (lpPackage lp) minstalled when (isRight res') $ do -- Insert it into the map so that it's -- available for addFinal. @@ -447,17 +507,19 @@ return res' resolveDepsAndInstall :: Bool - -> Bool -> PackageSource -> Package -> Maybe Installed -> M (Either ConstructPlanException AddDepRes) -resolveDepsAndInstall isAllInOne treatAsDep ps package minstalled = do - res <- addPackageDeps treatAsDep package +resolveDepsAndInstall isAllInOne ps package minstalled = do + res <- addPackageDeps package case res of Left err -> return $ Left err Right deps -> liftM Right $ installPackageGivenDeps isAllInOne ps package minstalled deps +-- | Checks if we need to install the given 'Package', given the results +-- of 'addPackageDeps'. If dependencies are missing, the package is +-- dirty, or it's not installed, then it needs to be installed. installPackageGivenDeps :: Bool -> PackageSource -> Package @@ -502,6 +564,7 @@ PSLocal lp -> TTLocal lp PSUpstream _ loc _ _ sha -> TTUpstream package (loc <> minLoc) sha , taskAllInOne = isAllInOne + , taskCachePkgSrc = toCachePkgSrc ps } -- Update response in the lib map. If it is an error, and there's @@ -517,13 +580,22 @@ | T.length t < 100 = t | otherwise = T.take 97 t <> "..." -addPackageDeps :: Bool -- ^ is this being used by a dependency? - -> Package -> M (Either ConstructPlanException (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, InstallLocation)) -addPackageDeps treatAsDep package = do +-- | Given a package, recurses into all of its dependencies. The results +-- indicate which packages are missing, meaning that their 'GhcPkgId's +-- will be figured out during the build, after they've been built. The +-- 2nd part of the tuple result indicates the packages that are already +-- installed which will be used. +-- +-- The 3rd part of the tuple is an 'InstallLocation'. If it is 'Local', +-- then the parent package must be installed locally. Otherwise, if it +-- is 'Snap', then it can either be installed locally or in the +-- snapshot. +addPackageDeps :: Package -> M (Either ConstructPlanException (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, InstallLocation)) +addPackageDeps package = do ctx <- ask deps' <- packageDepsWithTools package deps <- forM (Map.toList deps') $ \(depname, range) -> do - eres <- addDep treatAsDep depname + eres <- addDep True depname let getLatestApplicable = do vs <- liftIO $ getVersions ctx depname return (latestApplicableVersion range vs) @@ -579,6 +651,11 @@ mlatestApplicable <- getLatestApplicable return $ Left (depname, (range, mlatestApplicable, DependencyMismatch $ adrVersion adr)) case partitionEithers deps of + -- Note that the Monoid for 'InstallLocation' means that if any + -- is 'Local', the result is 'Local', indicating that the parent + -- package must be installed locally. Otherwise the result is + -- 'Snap', indicating that the parent can either be installed + -- locally or in the snapshot. ([], pairs) -> return $ Right $ mconcat pairs (errs, _) -> return $ Left $ DependencyPlanFailures package @@ -586,6 +663,8 @@ where adrVersion (ADRToInstall task) = packageIdentifierVersion $ taskProvides task adrVersion (ADRFound _ installed) = installedVersion installed + -- Update the parents map, for later use in plan construction errors + -- - see 'getShortestDepsPath'. addParent depname range mversion = tell mempty { wParents = MonoidMap $ M.singleton depname val } where val = (First mversion, [(packageIdentifier package, range)]) @@ -618,6 +697,7 @@ shouldHaddockPackage buildOpts wanted (packageName package) || -- Disabling haddocks when old config had haddocks doesn't make dirty. maybe False configCacheHaddock moldOpts + , configCachePkgSrc = toCachePkgSrc ps } let mreason = case moldOpts of @@ -637,6 +717,10 @@ describeConfigDiff :: Config -> ConfigCache -> ConfigCache -> Maybe Text describeConfigDiff config old new + | configCachePkgSrc old /= configCachePkgSrc new = Just $ + "switching from " <> + pkgSrcName (configCachePkgSrc old) <> " to " <> + pkgSrcName (configCachePkgSrc new) | not (configCacheDeps new `Set.isSubsetOf` configCacheDeps old) = Just "dependencies changed" | not $ Set.null newComponents = Just $ "components added: " `T.append` T.intercalate ", " @@ -694,6 +778,9 @@ newComponents = configCacheComponents new `Set.difference` configCacheComponents old + pkgSrcName (CacheSrcLocal fp) = T.pack fp + pkgSrcName CacheSrcUpstream = "upstream source" + psForceDirty :: PackageSource -> Bool psForceDirty (PSLocal lp) = lpForceDirty lp psForceDirty PSUpstream{} = False @@ -809,8 +896,10 @@ | DependencyPlanFailures Package (Map PackageName (VersionRange, LatestApplicableVersion, BadDependency)) | UnknownPackage PackageName -- TODO perhaps this constructor will be removed, and BadDependency will handle it all -- ^ Recommend adding to extra-deps, give a helpful version number? - deriving (Typeable, Eq, Show) + deriving (Typeable, Eq, Ord, Show) +deriving instance Ord VersionRange + -- | For display purposes only, Nothing if package not found type LatestApplicableVersion = Maybe Version @@ -819,7 +908,7 @@ = NotInBuildPlan | Couldn'tResolveItsDependencies Version | DependencyMismatch Version - deriving (Typeable, Eq, Show) + deriving (Typeable, Eq, Ord, Show) -- TODO: Consider intersecting version ranges for multiple deps on a -- package. This is why VersionRange is in the parent map. @@ -843,7 +932,7 @@ line <> "You may also want to try the 'stack solver' command" where - exceptions' = nub exceptions + exceptions' = nubOrd exceptions extras = Map.unions $ map getExtras exceptions' getExtras (DependencyCycleDetected _) = Map.empty @@ -857,20 +946,25 @@ pprintExtra (name, version) = fromString (concat ["- ", packageNameString name, "-", versionString version]) + allNotInBuildPlan = Set.fromList $ concatMap toNotInBuildPlan exceptions' + toNotInBuildPlan (DependencyPlanFailures _ pDeps) = + map fst $ filter (\(_, (_, _, badDep)) -> badDep == NotInBuildPlan) $ Map.toList pDeps + toNotInBuildPlan _ = [] + pprintException (DependencyCycleDetected pNames) = Just $ "Dependency cycle detected in packages:" <> line <> indent 4 (encloseSep "[" "]" "," (map (errorRed . fromString . packageNameString) pNames)) - pprintException (DependencyPlanFailures pkg (Map.toList -> pDeps)) = - case mapMaybe pprintDep pDeps of + pprintException (DependencyPlanFailures pkg pDeps) = + case mapMaybe pprintDep (Map.toList pDeps) of [] -> Nothing depErrors -> Just $ "In the dependencies for" <+> pkgIdent <> pprintFlags (packageFlags pkg) <> ":" <> line <> indent 4 (vsep depErrors) <> case getShortestDepsPath parentMap wanted (packageName pkg) of - [] -> mempty - [target,_] -> line <> "needed since" <+> displayTargetPkgId target <+> "is a build target." - (target:path) -> line <> "needed due to " <> encloseSep "" "" " -> " pathElems + Nothing -> line <> "needed for unknown reason - stack invariant violated." + Just [] -> line <> "needed since" <+> pkgIdent <+> "is a build target." + Just (target:path) -> line <> "needed due to " <> encloseSep "" "" " -> " pathElems where pathElems = [displayTargetPkgId target] ++ @@ -878,9 +972,12 @@ [pkgIdent] where pkgIdent = displayCurrentPkgId (packageIdentifier pkg) - -- TODO: optionally show these? - -- Skip these because they are redundant with 'NotInBuildPlan' info. - pprintException (UnknownPackage _) = Nothing + -- Skip these when they are redundant with 'NotInBuildPlan' info. + pprintException (UnknownPackage name) + | name `Set.member` allNotInBuildPlan = Nothing + | name `HashSet.member` wiredInPackages = + Just $ "Can't build a package with same name as a wired-in-package:" <+> displayCurrentPkgName name + | otherwise = Just $ "Unknown package:" <+> displayCurrentPkgName name pprintFlags flags | Map.null flags = "" @@ -921,13 +1018,15 @@ :: ParentMap -> Set PackageName -> PackageName - -> [PackageIdentifier] + -> Maybe [PackageIdentifier] getShortestDepsPath (MonoidMap parentsMap) wanted name = - case M.lookup name parentsMap of - Nothing -> [] - Just (_, parents) -> findShortest 256 paths0 - where - paths0 = M.fromList $ map (\(ident, _) -> (packageIdentifierName ident, startDepsPath ident)) parents + if Set.member name wanted + then Just [] + else case M.lookup name parentsMap of + Nothing -> Nothing + Just (_, parents) -> Just $ findShortest 256 paths0 + where + paths0 = M.fromList $ map (\(ident, _) -> (packageIdentifierName ident, startDepsPath ident)) parents where -- The 'paths' map is a map from PackageName to the shortest path -- found to get there. It is the frontier of our breadth-first 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 @@ -7,6 +7,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Perform a build module Stack.Build.Execute ( printPlan @@ -16,6 +17,7 @@ , ExecuteEnv , withExecuteEnv , withSingleContext + , ExcludeTHLoading(..) ) where import Control.Applicative @@ -27,7 +29,6 @@ import Control.Exception.Lifted import Control.Monad (liftM, when, unless, void) import Control.Monad.Catch (MonadCatch) -import Control.Monad.Extra (anyM, (&&^)) import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Trans.Control (liftBaseWith) @@ -46,6 +47,7 @@ import Data.FileEmbed (embedFile, makeRelativeToProject) import Data.Foldable (forM_, any) import Data.Function +import Data.IORef import Data.IORef.RunOnce (runOnce) import Data.List hiding (any) import Data.Map.Strict (Map) @@ -71,6 +73,7 @@ import qualified Distribution.Text as C import Language.Haskell.TH as TH (location) import Path +import Path.CheckInstall import Path.Extra (toFilePathNoTrailingSep, rejectMissingFile) import Path.IO hiding (findExecutable, makeAbsolute) import Prelude hiding (FilePath, writeFile, any) @@ -119,8 +122,7 @@ $logDebug $ T.pack $ "Prefetching: " ++ intercalate ", " (map packageIdentifierString $ Set.toList idents) - menv <- getMinimalEnvOverride - fetchPackages menv idents + fetchPackages idents where idents = Set.unions $ map toIdent $ Map.toList $ planTasks plan @@ -207,7 +209,7 @@ where missing = tcoMissing $ taskConfigOpts task -data ExecuteEnv = ExecuteEnv +data ExecuteEnv m = ExecuteEnv { eeEnvOverride :: !EnvOverride , eeConfigureLock :: !(MVar ()) , eeInstallLock :: !(MVar ()) @@ -231,6 +233,11 @@ , eeSnapshotDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () () ()))) , eeLocalDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () () ()))) , eeLogFiles :: !(TChan (Path Abs Dir, Path Abs File)) + , eeGetGhcPath :: !(m (Path Abs File)) + , eeGetGhcjsPath :: !(m (Path Abs File)) + , eeCustomBuilt :: !(IORef (Set PackageName)) + -- ^ Stores which packages with custom-setup have already had their + -- Setup.hs built. } buildSetupArgs :: [String] @@ -322,8 +329,8 @@ renameFile tmpExePath exePath return $ Just exePath --- | Execute a callback that takes an 'ExecuteEnv'. -withExecuteEnv :: (StackM env m, HasEnvConfig env) +-- | Execute a function that takes an 'ExecuteEnv'. +withExecuteEnv :: forall env m a. (StackM env m, HasEnvConfig env) => EnvOverride -> BuildOpts -> BuildOptsCLI @@ -332,7 +339,7 @@ -> [DumpPackage () () ()] -- ^ global packages -> [DumpPackage () () ()] -- ^ snapshot packages -> [DumpPackage () () ()] -- ^ local packages - -> (ExecuteEnv -> m a) + -> (ExecuteEnv m -> m a) -> m a withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages inner = do withSystemTempDir stackProgName $ \tmpdir -> do @@ -341,6 +348,10 @@ idMap <- liftIO $ newTVarIO Map.empty config <- view configL + getGhcPath <- runOnce $ getCompilerPath Ghc + getGhcjsPath <- runOnce $ getCompilerPath Ghcjs + customBuiltRef <- liftIO $ newIORef Set.empty + -- Create files for simple setup and setup shim, if necessary let setupSrcDir = configStackRoot config @@ -387,10 +398,14 @@ , eeSnapshotDumpPkgs = snapshotPackagesTVar , eeLocalDumpPkgs = localPackagesTVar , eeLogFiles = logFilesTChan + , eeGetGhcPath = getGhcPath + , eeGetGhcjsPath = getGhcjsPath + , eeCustomBuilt = customBuiltRef } `finally` dumpLogs logFilesTChan totalWanted where toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dpGhcPkgId dp, dp)) + dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> m () dumpLogs chan totalWanted = do allLogs <- fmap reverse $ liftIO $ atomically drainChan case allLogs of @@ -411,6 +426,7 @@ $logInfo $ T.pack $ "Log files have been written to: " ++ toFilePath (parent (snd firstLog)) where + drainChan :: STM [(Path Abs Dir, Path Abs File)] drainChan = do mx <- tryReadTChan chan case mx of @@ -419,6 +435,7 @@ xs <- drainChan return $ x:xs + dumpLogIfWarning :: (Path Abs Dir, Path Abs File) -> m () dumpLogIfWarning (pkgDir, filepath) = do firstWarning <- runResourceT $ CB.sourceFile (toFilePath filepath) @@ -429,15 +446,18 @@ =$ CL.take 1 unless (null firstWarning) $ dumpLog " due to warnings" (pkgDir, filepath) + isWarning :: Text -> Bool isWarning t = ": Warning:" `T.isSuffixOf` t -- prior to GHC 8 || ": warning:" `T.isInfixOf` t -- GHC 8 is slightly different + dumpLog :: String -> (Path Abs Dir, Path Abs File) -> m () dumpLog msgSuffix (pkgDir, filepath) = do $logInfo $ T.pack $ concat ["\n-- Dumping log file", msgSuffix, ": ", toFilePath filepath, "\n"] + compilerVer <- view actualCompilerVersionL runResourceT $ CB.sourceFile (toFilePath filepath) $$ CT.decodeUtf8Lenient - =$ mungeBuildOutput True True pkgDir + =$ mungeBuildOutput ExcludeTHLoading ConvertPathsToAbsolute pkgDir compilerVer =$ CL.mapM_ $logInfo $logInfo $ T.pack $ "\n-- End of log file: " ++ toFilePath filepath ++ "\n" @@ -459,100 +479,7 @@ bopts <- view buildOptsL withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages (executePlan' installedMap targets plan) - unless (Map.null $ planInstallExes plan) $ do - snapBin <- ( bindirSuffix) `liftM` installationRootDeps - localBin <- ( bindirSuffix) `liftM` installationRootLocal - destDir <- view $ configL.to configLocalBin - ensureDir destDir - - destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir - - platform <- view platformL - let ext = - case platform of - Platform _ Windows -> ".exe" - _ -> "" - - currExe <- liftIO getExecutablePath -- needed for windows, see below - - installed <- forMaybeM (Map.toList $ planInstallExes plan) $ \(name, loc) -> do - let bindir = - case loc of - Snap -> snapBin - Local -> localBin - mfp <- forgivingAbsence (resolveFile bindir $ T.unpack name ++ ext) - >>= rejectMissingFile - case mfp of - Nothing -> do - $logWarn $ T.concat - [ "Couldn't find executable " - , name - , " in directory " - , T.pack $ toFilePath bindir - ] - return Nothing - Just file -> do - let destFile = destDir' FP. T.unpack name ++ ext - $logInfo $ T.concat - [ "Copying from " - , T.pack $ toFilePath file - , " to " - , T.pack destFile - ] - - liftIO $ case platform of - Platform _ Windows | FP.equalFilePath destFile currExe -> - windowsRenameCopy (toFilePath file) destFile - _ -> D.copyFile (toFilePath file) destFile - return $ Just (name <> T.pack ext) - - unless (null installed) $ do - $logInfo "" - $logInfo $ T.concat - [ "Copied executables to " - , T.pack destDir' - , ":"] - forM_ installed $ \exe -> $logInfo ("- " <> exe) - - searchPath <- liftIO FP.getSearchPath - destDirIsInPATH <- liftIO $ - anyM (\dir -> D.doesDirectoryExist dir &&^ fmap (FP.equalFilePath destDir') (D.canonicalizePath dir)) searchPath - if destDirIsInPATH - then forM_ installed $ \exe -> do - mexePath <- (liftIO . D.findExecutable . T.unpack) exe - case mexePath of - Just exePath -> do - exeDir <- (liftIO . fmap FP.takeDirectory . D.canonicalizePath) exePath - unless (exeDir `FP.equalFilePath` destDir') $ do - $logWarn "" - $logWarn $ T.concat - [ "WARNING: The \"" - , exe - , "\" executable found on the PATH environment variable is " - , T.pack exePath - , ", and not the version that was just installed." - ] - $logWarn $ T.concat - [ "This means that \"" - , exe - , "\" calls on the command line will not use this version." - ] - Nothing -> do - $logWarn "" - $logWarn $ T.concat - [ "WARNING: Installation path " - , T.pack destDir' - , " is on the PATH but the \"" - , exe - , "\" executable that was just installed could not be found on the PATH." - ] - else do - $logWarn "" - $logWarn $ T.concat - [ "WARNING: Installation path " - , T.pack destDir' - , " not found on the PATH environment variable" - ] + copyExecutables (planInstallExes plan) config <- view configL menv' <- liftIO $ configEnvOverride config EnvSettings @@ -565,6 +492,68 @@ $withProcessTimeLog cmd args $ callProcess (Cmd Nothing cmd menv' args) +copyExecutables + :: (StackM env m, HasEnvConfig env) + => Map Text InstallLocation + -> m () +copyExecutables exes | Map.null exes = return () +copyExecutables exes = do + snapBin <- ( bindirSuffix) `liftM` installationRootDeps + localBin <- ( bindirSuffix) `liftM` installationRootLocal + destDir <- view $ configL.to configLocalBin + ensureDir destDir + + destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir + + platform <- view platformL + let ext = + case platform of + Platform _ Windows -> ".exe" + _ -> "" + + currExe <- liftIO getExecutablePath -- needed for windows, see below + + installed <- forMaybeM (Map.toList exes) $ \(name, loc) -> do + let bindir = + case loc of + Snap -> snapBin + Local -> localBin + mfp <- forgivingAbsence (resolveFile bindir $ T.unpack name ++ ext) + >>= rejectMissingFile + case mfp of + Nothing -> do + $logWarn $ T.concat + [ "Couldn't find executable " + , name + , " in directory " + , T.pack $ toFilePath bindir + ] + return Nothing + Just file -> do + let destFile = destDir' FP. T.unpack name ++ ext + $logInfo $ T.concat + [ "Copying from " + , T.pack $ toFilePath file + , " to " + , T.pack destFile + ] + + liftIO $ case platform of + Platform _ Windows | FP.equalFilePath destFile currExe -> + windowsRenameCopy (toFilePath file) destFile + _ -> D.copyFile (toFilePath file) destFile + return $ Just (name <> T.pack ext) + + unless (null installed) $ do + $logInfo "" + $logInfo $ T.concat + [ "Copied executables to " + , T.pack destDir' + , ":"] + forM_ installed $ \exe -> $logInfo ("- " <> exe) + warnInstallSearchPathIssues destDir' installed + + -- | Windows can't write over the current executable. Instead, we rename the -- current executable to something else and then do the copy. windowsRenameCopy :: FilePath -> FilePath -> IO () @@ -581,7 +570,7 @@ => InstalledMap -> Map PackageName SimpleTarget -> Plan - -> ExecuteEnv + -> ExecuteEnv m -> m () executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do when (toCoverage $ boptsTestOpts eeBuildOpts) deleteHpcReports @@ -676,7 +665,7 @@ toActions :: (StackM env m, HasEnvConfig env) => InstalledMap -> (m () -> IO ()) - -> ExecuteEnv + -> ExecuteEnv m -> (Maybe Task, Maybe Task) -- build and final -> [Action] toActions installedMap runInBase ee (mbuild, mfinal) = @@ -700,13 +689,16 @@ (if taskAllInOne then [] else [Action { actionId = ActionId taskProvides ATBuildFinal - , actionDeps = addBuild ATBuild + , actionDeps = addBuild (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 (if taskAllInOne then ATBuild else ATBuildFinal) Set.empty + , actionDeps = + if taskAllInOne + then addBuild mempty + else Set.singleton (ActionId taskProvides ATBuildFinal) , actionDo = \ac -> runInBase $ do let comps = taskComponents task tests = testComponents comps @@ -718,19 +710,19 @@ } ] where - addBuild aty = + addBuild = case mbuild of Nothing -> id - Just _ -> Set.insert $ ActionId taskProvides aty + Just _ -> Set.insert $ ActionId taskProvides ATBuild bopts = eeBuildOpts ee topts = boptsTestOpts bopts beopts = boptsBenchmarkOpts bopts -- | Generate the ConfigCache getConfigCache :: (StackM env m, HasEnvConfig env) - => ExecuteEnv -> Task -> InstalledMap -> Bool -> Bool + => ExecuteEnv m -> Task -> InstalledMap -> Bool -> Bool -> m (Map PackageIdentifier GhcPkgId, ConfigCache) -getConfigCache ExecuteEnv {..} Task {..} installedMap enableTest enableBench = do +getConfigCache ExecuteEnv {..} task@Task {..} installedMap enableTest enableBench = do useExactConf <- view $ configL.to configAllowNewer let extra = -- We enable tests if the test suite dependencies are already @@ -749,9 +741,16 @@ idMap <- liftIO $ readTVarIO eeGhcPkgIds let getMissing ident = case Map.lookup ident idMap of - Nothing -> error "singleBuild: invariant violated, missing package ID missing" - Just (Library ident' x) -> assert (ident == ident') $ Just (ident, x) - Just (Executable _) -> Nothing + Nothing + -- Expect to instead find it in installedMap if it's + -- an initialBuildSteps target. + | boptsCLIInitialBuildSteps eeBuildOptsCLI && taskIsTarget task, + Just (_, installed) <- Map.lookup (packageIdentifierName ident) installedMap + -> installedToGhcPkgId ident installed + Just installed -> installedToGhcPkgId ident installed + _ -> error "singleBuild: invariant violated, missing package ID missing" + installedToGhcPkgId ident (Library ident' x) = assert (ident == ident') $ Just (ident, x) + installedToGhcPkgId _ (Executable _) = Nothing missing' = Map.fromList $ mapMaybe getMissing $ Set.toList missing TaskConfigOpts missing mkOpts = taskConfigOpts opts = mkOpts missing' @@ -767,6 +766,7 @@ TTUpstream{} -> Set.empty , configCacheHaddock = shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides) + , configCachePkgSrc = taskCachePkgSrc } allDepsMap = Map.union missing' taskPresent return (allDepsMap, cache) @@ -775,9 +775,9 @@ ensureConfig :: (StackM env m, HasEnvConfig env) => ConfigCache -- ^ newConfigCache -> Path Abs Dir -- ^ package directory - -> ExecuteEnv + -> ExecuteEnv m -> m () -- ^ announce - -> (Bool -> [String] -> m ()) -- ^ cabal + -> (ExcludeTHLoading -> [String] -> m ()) -- ^ cabal -> Path Abs File -- ^ .cabal file -> m Bool ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp = do @@ -816,7 +816,7 @@ Just x -> return $ concat ["--with-", name, "=", toFilePath x] -- Configure cabal with arguments determined by -- Stack.Types.Build.configureOpts - cabal False $ "configure" : concat + cabal KeepTHLoading $ "configure" : concat [ concat exes , dirs , nodirs @@ -833,23 +833,34 @@ , x ] -withSingleContext :: (StackM env m, HasEnvConfig env) +-- | This sets up a context for executing build steps which need to run +-- Cabal (via a compiled Setup.hs). In particular it does the following: +-- +-- * Ensures the package exists in the file system, downloading if necessary. +-- +-- * Opens a log file if the built output shouldn't go to stderr. +-- +-- * Ensures that either a simple Setup.hs is built, or the package's +-- custom setup is built. +-- +-- * Provides the user a function with which run the Cabal process. +withSingleContext :: forall env m a. (StackM env m, HasEnvConfig env) => (m () -> IO ()) -> ActionContext - -> ExecuteEnv + -> ExecuteEnv m -> Task -> Maybe (Map PackageIdentifier GhcPkgId) -- ^ All dependencies' package ids to provide to Setup.hs. If -- Nothing, just provide global and snapshot package -- databases. -> Maybe String - -> ( Package - -> Path Abs File - -> Path Abs Dir - -> (Bool -> [String] -> m ()) - -> (Text -> m ()) - -> Bool - -> Maybe (Path Abs File, Handle) + -> ( Package -- Package info + -> Path Abs File -- Cabal file path + -> Path Abs Dir -- Package root directory file path + -> (ExcludeTHLoading -> [String] -> m ()) -- Function to run Cabal with args + -> (Text -> m ()) -- An 'announce' function, for different build phases + -> Bool -- Whether output should be directed to the console + -> Maybe (Path Abs File, Handle) -- Log file -> m a) -> m a withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 = @@ -874,7 +885,7 @@ TTLocal lp -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp) TTUpstream package _ gitSHA1 -> do mdist <- liftM Just distRelativeDir - m <- unpackPackageIdents eeEnvOverride eeTempDir mdist + m <- unpackPackageIdents eeTempDir mdist $ Map.singleton taskProvides gitSHA1 case Map.toList m of [(ident, dir)] @@ -903,6 +914,12 @@ (liftIO . hClose) $ \h -> inner (Just (logPath, h)) + withCabal + :: Package + -> Path Abs Dir + -> Maybe (Path Abs File, Handle) + -> ((ExcludeTHLoading -> [String] -> m ()) -> m a) + -> m a withCabal package pkgDir mlogFile inner = do config <- view configL @@ -916,15 +933,13 @@ , esLocaleUtf8 = True } menv <- liftIO $ configEnvOverride config envSettings - getGhcPath <- runOnce $ getCompilerPath Ghc - getGhcjsPath <- runOnce $ getCompilerPath Ghcjs distRelativeDir' <- distRelativeDir esetupexehs <- -- Avoid broken Setup.hs files causing problems for simple build -- types, see: -- https://github.com/commercialhaskell/stack/issues/370 - case (packageSimpleType package, eeSetupExe) of - (True, Just setupExe) -> return $ Left setupExe + case (packageBuildType package, eeSetupExe) of + (Just C.Simple, Just setupExe) -> return $ Left setupExe _ -> liftIO $ Right <$> getSetupHs pkgDir inner $ \stripTHLoading args -> do let cabalPackageArg @@ -946,6 +961,20 @@ : ["-hide-all-packages"] ) + warnCustomNoDeps :: m () + warnCustomNoDeps = + case (taskType, packageBuildType package) of + (TTLocal{}, Just C.Custom) -> do + $logWarn $ T.pack $ concat + [ "Package " + , packageNameString $ packageName package + , " uses a custom Cabal build, but does not use a custom-setup stanza" + ] + $logWarn "Using the explicit setup deps approach based on configuration" + $logWarn "Strongly recommend fixing the package's cabal file" + _ -> return () + + getPackageArgs :: Path Abs Dir -> m [String] getPackageArgs setupDir = case (packageSetupDeps package, mdeps) of -- The package is using the Cabal custom-setup @@ -984,13 +1013,7 @@ -- 'explicit-setup-deps' is requested in your -- stack.yaml file. (Nothing, Just deps) | explicitSetupDeps (packageName package) config -> do - $logWarn $ T.pack $ concat - [ "Package " - , packageNameString $ packageName package - , " uses a custom Cabal build, but does not use a custom-setup stanza" - ] - $logWarn "Using the explicit setup deps approach based on configuration" - $logWarn "Strongly recommend fixing the package's cabal file" + warnCustomNoDeps -- Stack always builds with the global Cabal for various -- reproducibility issues. let depsMinusCabal @@ -1019,13 +1042,7 @@ -- sdist` or when explicitly requested in the -- stack.yaml file. (Nothing, _) -> do - $logWarn $ T.pack $ concat - [ "Package " - , packageNameString $ packageName package - , " uses a custom Cabal build, but does not use a custom-setup stanza" - ] - $logWarn "Not using the explicit setup deps approach based on configuration" - $logWarn "Strongly recommend fixing the package's cabal file" + warnCustomNoDeps return $ cabalPackageArg ++ -- NOTE: This is different from -- packageDBArgs above in that it does not @@ -1037,8 +1054,11 @@ ++ ["-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)]) setupArgs = ("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args - runExe exeName fullArgs = - runAndOutput `catch` \(ProcessExitedUnsuccessfully _ ec) -> do + + runExe :: Path Abs File -> [String] -> m () + runExe exeName fullArgs = do + compilerVer <- view actualCompilerVersionL + runAndOutput compilerVer `catch` \(ProcessExitedUnsuccessfully _ ec) -> do bss <- case mlogFile of Nothing -> return [] @@ -1047,7 +1067,7 @@ runResourceT $ CB.sourceFile (toFilePath logFile) =$= CT.decodeUtf8Lenient - $$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir + $$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir compilerVer =$ CL.consume throwM $ CabalExitedUnsuccessfully ec @@ -1057,56 +1077,87 @@ (fmap fst mlogFile) bss where - runAndOutput = case mlogFile of + runAndOutput :: CompilerVersion -> m () + runAndOutput compilerVer = case mlogFile of Just (_, h) -> sinkProcessStderrStdoutHandle (Just pkgDir) menv (toFilePath exeName) fullArgs h h Nothing -> void $ sinkProcessStderrStdout (Just pkgDir) menv (toFilePath exeName) fullArgs - (outputSink False LevelWarn) - (outputSink stripTHLoading LevelInfo) - outputSink excludeTH level = + (outputSink KeepTHLoading LevelWarn compilerVer) + (outputSink stripTHLoading LevelInfo compilerVer) + outputSink + :: ExcludeTHLoading + -> LogLevel + -> CompilerVersion + -> Sink S.ByteString IO () + outputSink excludeTH level compilerVer = CT.decodeUtf8Lenient - =$ mungeBuildOutput excludeTH makeAbsolute pkgDir + =$ mungeBuildOutput excludeTH makeAbsolute pkgDir compilerVer =$ CL.mapM_ (runInBase . monadLoggerLog $(TH.location >>= liftLoc) "" level) -- If users want control, we should add a config option for this - makeAbsolute = stripTHLoading + makeAbsolute :: ConvertPathsToAbsolute + makeAbsolute = case stripTHLoading of + ExcludeTHLoading -> ConvertPathsToAbsolute + KeepTHLoading -> KeepPathsAsIs wc <- view $ actualCompilerVersionL.whichCompilerL - (exeName, fullArgs) <- case (esetupexehs, wc) of - (Left setupExe, _) -> return (setupExe, setupArgs) + exeName <- case (esetupexehs, wc) of + (Left setupExe, _) -> return setupExe (Right setuphs, compiler) -> do distDir <- distDirFromDir pkgDir let setupDir = distDir $(mkRelDir "setup") outputFile = setupDir $(mkRelFile "setup") - ensureDir setupDir - compilerPath <- - case compiler of - Ghc -> getGhcPath - Ghcjs -> getGhcjsPath - packageArgs <- getPackageArgs setupDir - runExe compilerPath $ - [ "--make" - , "-odir", toFilePathNoTrailingSep setupDir - , "-hidir", toFilePathNoTrailingSep setupDir - , "-i", "-i." - ] ++ packageArgs ++ - [ toFilePath setuphs - , toFilePath eeSetupShimHs - , "-main-is" - , "StackSetupShim.mainOverride" - , "-o", toFilePath outputFile - , "-threaded" - ] ++ - (case compiler of - Ghc -> [] - Ghcjs -> ["-build-runner"]) - return (outputFile, setupArgs) - runExe exeName $ (if boptsCabalVerbose eeBuildOpts then ("--verbose":) else id) fullArgs + customBuilt <- liftIO $ readIORef eeCustomBuilt + if Set.member (packageName package) customBuilt + then return outputFile + else do + ensureDir setupDir + compilerPath <- + case compiler of + Ghc -> eeGetGhcPath + Ghcjs -> eeGetGhcjsPath + packageArgs <- getPackageArgs setupDir + runExe compilerPath $ + [ "--make" + , "-odir", toFilePathNoTrailingSep setupDir + , "-hidir", toFilePathNoTrailingSep setupDir + , "-i", "-i." + ] ++ packageArgs ++ + [ toFilePath setuphs + , toFilePath eeSetupShimHs + , "-main-is" + , "StackSetupShim.mainOverride" + , "-o", toFilePath outputFile + , "-threaded" + ] ++ + (case compiler of + Ghc -> [] + Ghcjs -> ["-build-runner"]) + liftIO $ atomicModifyIORef' eeCustomBuilt $ + \oldCustomBuilt -> (Set.insert (packageName package) oldCustomBuilt, ()) + return outputFile + runExe exeName $ (if boptsCabalVerbose eeBuildOpts then ("--verbose":) else id) setupArgs -singleBuild :: (StackM env m, HasEnvConfig env) +-- Implements running a package's build, used to implement 'ATBuild' and +-- 'ATBuildFinal' tasks. In particular this does the following: +-- +-- * Checks if the package exists in the precompiled cache, and if so, +-- add it to the database instead of performing the build. +-- +-- * Runs the configure step if needed ('ensureConfig') +-- +-- * Runs the build step +-- +-- * Generates haddocks +-- +-- * Registers the library and copiesthe built executables into the +-- local install directory. Note that this is literally invoking Cabal +-- with @copy@, and not the copying done by @stack install@ - that is +-- handled by 'copyExecutables'. +singleBuild :: forall env m. (StackM env m, HasEnvConfig env) => (m () -> IO ()) -> ActionContext - -> ExecuteEnv + -> ExecuteEnv m -> Task -> InstalledMap -> Bool -- ^ Is this a final build? @@ -1238,27 +1289,36 @@ $ \package cabalfp pkgDir cabal announce _console _mlogFile -> do _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix)) cabal cabalfp + let installedMapHasThisPkg :: Bool + installedMapHasThisPkg = + case Map.lookup (packageName package) installedMap of + Just (_, Library ident _) -> ident == taskProvides + Just (_, Executable _) -> True + _ -> False + case ( boptsCLIOnlyConfigure eeBuildOptsCLI - , boptsCLIInitialBuildSteps eeBuildOptsCLI && isTarget - , acDownstream) of + , boptsCLIInitialBuildSteps eeBuildOptsCLI && taskIsTarget task) of -- A full build is done if there are downstream actions, -- because their configure step will require that this -- package is built. See -- https://github.com/commercialhaskell/stack/issues/2787 - (True, _, []) -> return Nothing - (_, True, []) -> do + (True, _) | null acDownstream -> return Nothing + (_, True) | null acDownstream || installedMapHasThisPkg -> do initialBuildSteps cabal announce return Nothing _ -> liftM Just $ realBuild cache package pkgDir cabal announce - isTarget = case taskType of - TTLocal lp -> lpWanted lp - _ -> False - initialBuildSteps cabal announce = do () <- announce ("initial-build-steps" <> annSuffix) - cabal False ["repl", "stack-initial-build-steps"] + cabal KeepTHLoading ["repl", "stack-initial-build-steps"] + realBuild + :: ConfigCache + -> Package + -> Path Abs Dir + -> (ExcludeTHLoading -> [String] -> m ()) + -> (Text -> m ()) + -> m Installed realBuild cache package pkgDir cabal announce = do wc <- view $ actualCompilerVersionL.whichCompilerL @@ -1298,9 +1358,12 @@ () <- announce ("build" <> annSuffix) config <- view configL extraOpts <- extraBuildOptions wc eeBuildOpts - cabal (configHideTHLoading config) (("build" :) $ (++ extraOpts) $ + let stripTHLoading + | configHideTHLoading config = ExcludeTHLoading + | otherwise = KeepTHLoading + cabal stripTHLoading (("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." + (_, True, True) -> error "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 @@ -1312,7 +1375,7 @@ when (doHaddock package) $ do announce "haddock" - sourceFlag <- do + sourceFlag <- if not (boptsHaddockHyperlinkSource eeBuildOpts) then return [] else do -- See #2429 for why the temp dir is used hyped <- tryProcessStdout (Just eeTempDir) eeEnvOverride "haddock" ["--hyperlinked-source"] case hyped of @@ -1326,18 +1389,23 @@ ("Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" <> "found on PATH (use 'stack install hscolour' to install).") return ["--hyperlink-source" | hscolourExists] - cabal False (concat [["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"] - ,sourceFlag, ["--internal" | boptsHaddockInternal eeBuildOpts]]) + cabal KeepTHLoading $ concat + [ ["haddock", "--html", "--html-location=../$pkg-$version/"] + , sourceFlag + , ["--internal" | boptsHaddockInternal eeBuildOpts] + , [ "--haddock-option=" <> opt + | opt <- hoAdditionalArgs (boptsHaddockOpts eeBuildOpts) ] + ] let shouldCopy = not isFinalBuild && (packageHasLibrary package || not (Set.null (packageExes package))) when shouldCopy $ withMVar eeInstallLock $ \() -> do announce "copy/register" - eres <- try $ cabal False ["copy"] + eres <- try $ cabal KeepTHLoading ["copy"] case eres of Left err@CabalExitedUnsuccessfully{} -> - throwM $ CabalCopyFailed (packageSimpleType package) (show err) + throwM $ CabalCopyFailed (packageBuildType package == Just C.Simple) (show err) _ -> return () - when (packageHasLibrary package) $ cabal False ["register"] + when (packageHasLibrary package) $ cabal KeepTHLoading ["register"] let (installedPkgDb, installedDumpPkgsTVar) = case taskLocation task of @@ -1365,6 +1433,15 @@ mpkgid (packageExes package) Local -> return () + case taskType of + -- For upstream packages, pkgDir is in the tmp directory. We + -- eagerly delete it if no other tasks require it, to reduce + -- space usage in tmp (#3018). + TTUpstream{} -> do + let remaining = filter (\(ActionId x _) -> x == taskProvides) (Set.toList acRemaining) + when (null remaining) $ removeDirRecur pkgDir + _ -> return () + return mpkgid loadInstalledPkg menv wc pkgDbs tvar name = do @@ -1400,12 +1477,14 @@ Nothing -> False) (Map.toList deps) +-- | Implements running a package's tests. Also handles producing +-- coverage reports if coverage is enabled. singleTest :: (StackM env m, HasEnvConfig env) => (m () -> IO ()) -> TestOpts -> [Text] -> ActionContext - -> ExecuteEnv + -> ExecuteEnv m -> Task -> InstalledMap -> m () @@ -1516,7 +1595,7 @@ _ -> Map.singleton testName $ Just ec else do $logError $ T.pack $ show $ TestSuiteExeMissing - (packageSimpleType package) + (packageBuildType package == Just C.Simple) exeName (packageNameString (packageName package)) (T.unpack testName) @@ -1543,12 +1622,13 @@ (fmap fst mlogFile) bs +-- | Implements running a package's benchmarks. singleBench :: (StackM env m, HasEnvConfig env) => (m () -> IO ()) -> BenchmarkOpts -> [Text] -> ActionContext - -> ExecuteEnv + -> ExecuteEnv m -> Task -> InstalledMap -> m () @@ -1568,41 +1648,68 @@ return True when toRun $ do - announce "benchmarks" - cabal False ("bench" : args) + announce "benchmarks" + cabal KeepTHLoading ("bench" : args) +data ExcludeTHLoading = ExcludeTHLoading | KeepTHLoading +data ConvertPathsToAbsolute = ConvertPathsToAbsolute | KeepPathsAsIs + -- | Strip Template Haskell "Loading package" lines and making paths absolute. -mungeBuildOutput :: (MonadIO m, MonadCatch m) - => Bool -- ^ exclude TH loading? - -> Bool -- ^ convert paths to absolute? - -> Path Abs Dir -- ^ package's root directory +mungeBuildOutput :: forall m. (MonadIO m, MonadCatch m, MonadBaseControl IO m) + => ExcludeTHLoading -- ^ exclude TH loading? + -> ConvertPathsToAbsolute -- ^ convert paths to absolute? + -> Path Abs Dir -- ^ package's root directory + -> CompilerVersion -- ^ compiler we're building with -> ConduitM Text Text m () -mungeBuildOutput excludeTHLoading makeAbsolute pkgDir = void $ +mungeBuildOutput excludeTHLoading makeAbsolute pkgDir compilerVer = void $ CT.lines =$ CL.map stripCR =$ CL.filter (not . isTHLoading) - =$ CL.mapM toAbsolutePath + =$ filterLinkerWarnings + =$ toAbsolute where -- | Is this line a Template Haskell "Loading package" line -- ByteString isTHLoading :: Text -> Bool - isTHLoading _ | not excludeTHLoading = False - isTHLoading bs = - "Loading package " `T.isPrefixOf` bs && - ("done." `T.isSuffixOf` bs || "done.\r" `T.isSuffixOf` bs) + isTHLoading = case excludeTHLoading of + KeepTHLoading -> const False + ExcludeTHLoading -> \bs -> + "Loading package " `T.isPrefixOf` bs && + ("done." `T.isSuffixOf` bs || "done.\r" `T.isSuffixOf` bs) + filterLinkerWarnings :: ConduitM Text Text m () + filterLinkerWarnings + -- Check for ghc 7.8 since it's the only one prone to producing + -- linker warnings on Windows x64 + | getGhcVersion compilerVer >= $(mkVersion "7.8") = doNothing + | otherwise = CL.filter (not . isLinkerWarning) + + isLinkerWarning :: Text -> Bool + isLinkerWarning str = + ("ghc.exe: warning:" `T.isPrefixOf` str || "ghc.EXE: warning:" `T.isPrefixOf` str) && + "is linked instead of __imp_" `T.isInfixOf` str + -- | Convert GHC error lines with file paths to have absolute file paths - toAbsolutePath bs | not makeAbsolute = return bs + toAbsolute :: ConduitM Text Text m () + toAbsolute = case makeAbsolute of + KeepPathsAsIs -> doNothing + ConvertPathsToAbsolute -> CL.mapM toAbsolutePath + + toAbsolutePath :: Text -> m Text toAbsolutePath bs = do let (x, y) = T.break (== ':') bs mabs <- if isValidSuffix y then liftM (fmap ((T.takeWhile isSpace x <>) . T.pack . toFilePath)) $ - forgivingAbsence (resolveFile pkgDir (T.unpack $ T.dropWhile isSpace x)) + forgivingAbsence (resolveFile pkgDir (T.unpack $ T.dropWhile isSpace x)) `catch` + \(_ :: PathParseException) -> return Nothing else return Nothing case mabs of Nothing -> return bs Just fp -> return $ fp `T.append` y + + doNothing :: ConduitM Text Text m () + doNothing = awaitForever yield -- | Match the error location format at the end of lines isValidSuffix = isRight . parseOnly lineCol 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 @@ -51,6 +51,7 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.StackT (StackM) +import Stack.Types.StringError import qualified System.FilePath as FP import System.IO.Error (isDoesNotExistError) import System.Process.Read @@ -76,7 +77,7 @@ snapExists <- doesFileExist snapDocs if snapExists then return snapDocs - else fail "No local or snapshot doc index found to open." + else throwString "No local or snapshot doc index found to open." docFile <- case (cliTargets, map (`Map.lookup` pkgLocations) (Set.toList buildTargets)) of ([_], [Just (pkgId, iloc)]) -> do 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 @@ -88,12 +88,22 @@ , SourceMap ) loadSourceMap needTargets boptsCli = do - (_, _, locals, _, _, sourceMap) <- loadSourceMapFull True needTargets boptsCli + (_, _, locals, _, _, sourceMap) <- loadSourceMapFull needTargets boptsCli return (locals, sourceMap) +-- | Given the build commandline options, does the following: +-- +-- * Parses the build targets. +-- +-- * Loads the 'MiniBuildPlan' from the resolver, with extra-deps +-- shadowing any packages that should be built locally. +-- +-- * Loads up the 'LocalPackage' info. +-- +-- * Builds a 'SourceMap', which contains info for all the packages that +-- will be involved in the build. loadSourceMapFull :: (StackM env m, HasEnvConfig env) - => Bool - -> NeedTargets + => NeedTargets -> BuildOptsCLI -> m ( Map PackageName SimpleTarget , MiniBuildPlan @@ -102,10 +112,11 @@ , Map PackageName Version -- extra-deps from configuration and cli , SourceMap ) -loadSourceMapFull omitWiredIn needTargets boptsCli = do +loadSourceMapFull needTargets boptsCli = do bconfig <- view buildConfigL rawLocals <- getLocalPackageViews (mbp0, cliExtraDeps, targets) <- parseTargetsFromBuildOptsWith rawLocals needTargets boptsCli + -- Extend extra-deps to encompass targets requested on the command line -- that are not in the snapshot. extraDeps0 <- extendExtraDeps @@ -131,10 +142,14 @@ isLocal STNonLocal = False shadowed = Map.keysSet rawLocals <> Map.keysSet extraDeps0 + + -- Ignores all packages in the MiniBuildPlan that depend on any + -- local packages or extra-deps. All packages that have + -- transitive dependenceis on these packages are treated as + -- extra-deps (extraDeps1). (mbp, extraDeps1) = shadowMiniBuildPlan mbp0 shadowed - -- Add the extra deps from the stack.yaml file to the deps grabbed from - -- the snapshot + -- Combine the extra-deps with the ones implicitly shadowed. extraDeps2 = Map.union (Map.map (\v -> (v, Map.empty, [])) extraDeps0) (Map.map (\mpi -> (mpiVersion mpi, mpiFlags mpi, mpiGhcOptions mpi)) extraDeps1) @@ -166,6 +181,8 @@ in PSUpstream v Local flags ghcOptions Nothing) extraDeps2 + -- Combine the local packages, extra-deps, and MiniBuildPlan into + -- one unified source map. let sourceMap = Map.unions [ Map.fromList $ flip map locals $ \lp -> let p = lpPackage lp @@ -175,18 +192,11 @@ let configOpts = getGhcOptions bconfig boptsCli n False False in PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi) (mpiGhcOptions mpi ++ configOpts) (mpiGitSHA1 mpi) ] - -- This conditional was introduced in order to fix "stack - -- list-dependencies --license" (#2871) for wired-in-packages. - -- Normally, they are omitted as they shouldn't be considered - -- as packages available for installation. - sourceMap' = - if omitWiredIn - then sourceMap `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages)) - else sourceMap + `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages)) - return (targets, mbp, locals, nonLocalTargets, extraDeps0, sourceMap') + return (targets, mbp, locals, nonLocalTargets, extraDeps0, sourceMap) --- | All flags for a local package +-- | All flags for a local package. getLocalFlags :: BuildConfig -> BuildOptsCLI @@ -200,6 +210,8 @@ where cliFlags = boptsCLIFlags boptsCli +-- | Get the configured options to pass from GHC, based on the build +-- configuration and commandline. getGhcOptions :: BuildConfig -> BuildOptsCLI -> PackageName -> Bool -> Bool -> [Text] getGhcOptions bconfig boptsCli name isTarget isLocal = concat [ ghcOptionsFor name (configGhcOptions config) @@ -227,6 +239,12 @@ -- -- If the local packages views are already known, use 'parseTargetsFromBuildOptsWith' -- instead. +-- +-- Along with the 'Map' of targets, this yields the loaded +-- 'MiniBuildPlan' for the resolver, as well as a Map of extra-deps +-- derived from the commandline. These extra-deps targets come from when +-- the user specifies a particular package version on the commonadline, +-- or when a flag is specified for a snapshot package. parseTargetsFromBuildOpts :: (StackM env m, HasEnvConfig env) => NeedTargets @@ -371,9 +389,7 @@ let mtarget = Map.lookup name targets config <- getPackageConfig boptsCli name (isJust mtarget) True bopts <- view buildOptsL - let pkg = resolvePackage config gpkg - - (exes, tests, benches) = + let (exes, tests, benches) = case mtarget of Just (STLocalComps comps) -> splitComponents $ Set.toList comps Just STLocalAll -> @@ -408,11 +424,28 @@ , packageConfigEnableBenchmarks = True } + -- We resolve the package in 4 different configurations: + -- + -- - pkg doesn't have tests or benchmarks enabled. + -- + -- - btpkg has them enabled if they are present. + -- + -- - testpkg has tests enabled, but not benchmarks. + -- + -- - benchpkg has benchmarks enablde, but not tests. + -- + -- The latter two configurations are used to compute the deps + -- when --enable-benchmarks or --enable-tests are configured. + -- This allows us to do an optimization where these are passed + -- if the deps are present. This can avoid doing later + -- unnecessary reconfigures. + pkg = resolvePackage config gpkg btpkg | Set.null tests && Set.null benches = Nothing | otherwise = Just (resolvePackage btconfig gpkg) testpkg = resolvePackage testconfig gpkg benchpkg = resolvePackage benchconfig gpkg + mbuildCache <- tryGetBuildCache $ lpvRoot lpv (files,_) <- getPackageFilesSimple pkg (lpvCabalFP lpv) 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 @@ -296,8 +296,12 @@ erawTargets <- mapM (parseRawTargetDirs currDir locals) textTargets let (errs1, rawTargets) = partitionEithers erawTargets + -- When specific package identifiers are provided, treat these + -- as extra-deps. (errs2, unzip -> (rawTargets', newExtras)) = partitionEithers $ map (resolveIdents snap extras locals) $ concat rawTargets + -- Find targets that specify components in the local packages, + -- otherwise find package targets in snap and extra-deps. (errs3, targetTypes) = partitionEithers $ map (resolveRawTarget snap extras locals) rawTargets' (errs4, targets) = simplifyTargets targetTypes diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -281,17 +281,16 @@ -> Map PackageName (Version, Map FlagName Bool, [Text], Maybe GitSHA1) -> m (Map PackageName MiniPackageInfo, Set PackageIdentifier) addDeps allowMissing compilerVersion toCalc = do - menv <- getMinimalEnvOverride platform <- view platformL (resolvedMap, missingIdents) <- if allowMissing then do (missingNames, missingIdents, m) <- - resolvePackagesAllowMissing menv Nothing shaMap Set.empty + resolvePackagesAllowMissing Nothing shaMap Set.empty assert (Set.null missingNames) $ return (m, missingIdents) else do - m <- resolvePackages menv Nothing shaMap Set.empty + m <- resolvePackages Nothing shaMap Set.empty return (m, Set.empty) let byIndex = Map.fromListWith (++) $ flip map resolvedMap $ \rp -> @@ -869,6 +868,10 @@ userPkgs = Map.keys $ Map.unions (Map.elems (fmap deNeededBy errs)) showFlags pkg = maybe "" (showPackageFlags pkg) (Map.lookup pkg flags) +-- | Given a set of packages to shadow, this removes them, and any +-- packages that transitively depend on them, from the 'MiniBuildPlan'. +-- The 'Map' result yields all of the packages that were downstream of +-- the shadowed packages. It does not include the shadowed packages. shadowMiniBuildPlan :: MiniBuildPlan -> Set PackageName -> (MiniBuildPlan, Map PackageName MiniPackageInfo) diff --git a/src/Stack/Clean.hs b/src/Stack/Clean.hs --- a/src/Stack/Clean.hs +++ b/src/Stack/Clean.hs @@ -43,10 +43,10 @@ -> m [Path Abs Dir] dirsToDelete cleanOpts = do packages <- getLocalPackages - let localPkgDirs = Map.keys packages case cleanOpts of - CleanShallow [] -> do - mapM distDirFromDir localPkgDirs + CleanShallow [] -> + -- Filter out packages listed as extra-deps + mapM distDirFromDir . Map.keys . Map.filter (== False) $ packages CleanShallow targets -> do localPkgViews <- getLocalPackageViews let localPkgNames = Map.keys localPkgViews @@ -55,7 +55,7 @@ [] -> mapM distDirFromDir (mapMaybe getPkgDir targets) xs -> throwM (NonLocalPackages xs) CleanFull -> do - pkgWorkDirs <- mapM workDirFromDir localPkgDirs + pkgWorkDirs <- mapM workDirFromDir (Map.keys packages) projectWorkDir <- getProjectWorkDir return (projectWorkDir : pkgWorkDirs) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -30,6 +30,7 @@ ,loadConfig ,loadConfigMaybeProject ,loadMiniConfig + ,loadConfigYaml ,packagesParser ,getLocalPackages ,resolvePackageEntry @@ -43,6 +44,7 @@ ,defaultConfigYaml ,getProjectConfig ,LocalConfigStatus(..) + ,removePathFromPackageEntry ) where import qualified Codec.Archive.Tar as Tar @@ -72,7 +74,7 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) import qualified Data.Yaml as Yaml -import Distribution.System (OS (..), Platform (..), buildPlatform) +import Distribution.System (OS (..), Platform (..), buildPlatform, Arch(OtherArch)) import qualified Distribution.Text import Distribution.Version (simplifyVersionRange) import GHC.Conc (getNumProcessors) @@ -99,9 +101,10 @@ import Stack.Types.Docker import Stack.Types.Internal import Stack.Types.Nix -import Stack.Types.PackageIndex (HttpType (HTHackageSecurity), HackageSecurity (..)) +import Stack.Types.PackageIndex (IndexType (ITHackageSecurity), HackageSecurity (..)) import Stack.Types.Resolver import Stack.Types.StackT +import Stack.Types.StringError import Stack.Types.Urls import Stack.Types.Version import System.Environment @@ -194,17 +197,16 @@ config <- view configL implicitGlobalDir <- getImplicitGlobalProjectDir config let fp = implicitGlobalDir stackDotYaml - WithJSONWarnings (ProjectAndConfigMonoid project _) _warnings <- - liftIO (Yaml.decodeFileEither $ toFilePath fp) - >>= either throwM return + ProjectAndConfigMonoid project _ <- + loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp return $ projectResolver project ARLatestNightly -> return $ ResolverSnapshot $ Nightly $ snapshotsNightly snapshots ARLatestLTSMajor x -> case IntMap.lookup x $ snapshotsLts snapshots of - Nothing -> error $ "No LTS release found with major version " ++ show x + Nothing -> errorString $ "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 -> errorString "No LTS releases found" | otherwise -> let (x, y) = IntMap.findMax $ snapshotsLts snapshots in return $ ResolverSnapshot $ LTS x y @@ -253,7 +255,11 @@ configFromConfigMonoid configStackRoot configUserConfigPath configAllowLocals mresolver mproject ConfigMonoid{..} = do - let configWorkDir = fromFirst $(mkRelDir ".stack-work") configMonoidWorkDir + -- If --stack-work is passed, prefer it. Otherwise, if STACK_WORK + -- is set, use that. If neither, use the default ".stack-work" + mstackWorkEnv <- liftIO $ lookupEnv stackWorkEnvVar + configWorkDir0 <- maybe (return $(mkRelDir ".stack-work")) parseRelDir mstackWorkEnv + let configWorkDir = fromFirst configWorkDir0 configMonoidWorkDir -- This code is to handle the deprecation of latest-snapshot-url configUrls <- case (getFirst configMonoidLatestSnapshotUrl, getFirst (urlsMonoidLatestSnapshot configMonoidUrls)) of (Just url, Nothing) -> do @@ -265,10 +271,8 @@ configPackageIndices = fromFirst [PackageIndex { indexName = IndexName "Hackage" - , indexLocation = ILGitHttp - "https://github.com/commercialhaskell/all-cabal-hashes.git" - "https://s3.amazonaws.com/hackage.fpcomplete.com/" - (HTHackageSecurity HackageSecurity + , indexLocation = "https://s3.amazonaws.com/hackage.fpcomplete.com/" + , indexType = ITHackageSecurity HackageSecurity { hsKeyIds = [ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" , "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" @@ -281,9 +285,8 @@ , "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" ] , hsKeyThreshold = 3 - }) + } , indexDownloadPrefix = "https://s3.amazonaws.com/hackage.fpcomplete.com/package/" - , indexGpgVerify = False , indexRequireHashes = False }] configMonoidPackageIndices @@ -312,6 +315,10 @@ configCompilerCheck = fromFirst MatchMinor configMonoidCompilerCheck + case arch of + OtherArch unk -> $logWarn $ "Warning: Unknown value for architecture setting: " <> T.pack (show unk) + _ -> return () + configPlatformVariant <- liftIO $ maybe PlatformVariantNone PlatformVariant <$> lookupEnv platformVariantEnvVar @@ -372,7 +379,7 @@ configScmInit = getFirst configMonoidScmInit configGhcOptions = configMonoidGhcOptions configSetupInfoLocations = configMonoidSetupInfoLocations - configPvpBounds = fromFirst PvpBoundsNone configMonoidPvpBounds + configPvpBounds = fromFirst (PvpBounds PvpBoundsNone False) configMonoidPvpBounds configModifyCodePage = fromFirst True configMonoidModifyCodePage configExplicitSetupDeps = configMonoidExplicitSetupDeps configRebuildGhcOptions = fromFirst False configMonoidRebuildGhcOptions @@ -380,6 +387,7 @@ configAllowNewer = fromFirst False configMonoidAllowNewer configDefaultTemplate = getFirst configMonoidDefaultTemplate configDumpLogs = fromFirst DumpWarningLogs configMonoidDumpLogs + configSaveHackageCreds = fromFirst True configMonoidSaveHackageCreds configAllowDifferentUser <- case getFirst configMonoidAllowDifferentUser of @@ -409,9 +417,10 @@ -- location to the new one, which is undesirable. Platform _ Windows -> case Map.lookup "LOCALAPPDATA" $ unEnvOverride override of - Just t -> do - lad <- parseAbsDir $ T.unpack t - return $ lad $(mkRelDir "Programs") $(mkRelDir stackProgName) + Just t -> + case parseAbsDir $ T.unpack t of + Nothing -> throwString ("Failed to parse LOCALAPPDATA environment variable (expected absolute directory): " ++ show t) + Just lad -> return $ lad $(mkRelDir "Programs") $(mkRelDir stackProgName) Nothing -> return defaultBase _ -> return defaultBase @@ -448,7 +457,8 @@ let loadHelper mproject' = do userConfigPath <- getDefaultUserConfigPath stackRoot - extraConfigs0 <- getExtraConfigs userConfigPath >>= mapM loadConfigYaml + extraConfigs0 <- getExtraConfigs userConfigPath >>= + mapM (\file -> loadConfigYaml (parseConfigMonoid (parent file)) file) let extraConfigs = -- non-project config files' existence of a docker section should never default docker -- to enabled, so make it look like they didn't exist @@ -533,7 +543,7 @@ exists <- doesFileExist dest if exists then do - ProjectAndConfigMonoid project _ <- loadConfigYaml dest + ProjectAndConfigMonoid project _ <- loadConfigYaml (parseProjectAndConfigMonoid destDir) dest when (view terminalL env) $ case mresolver of Nothing -> @@ -782,7 +792,31 @@ throwM $ UnexpectedArchiveContents dirs files _ -> return dir +-- | Remove path from package entry. If the package entry contains subdirs, then it removes +-- the subdir. If the package entry points to the path to remove, this function returns +-- Nothing. If the package entry doesn't mention the path to remove, it is returned unchanged +removePathFromPackageEntry + :: (StackMiniM env m, HasConfig env) + => EnvOverride + -> Path Abs Dir -- ^ project root + -> Path Abs Dir -- ^ path to remove + -> PackageEntry + -> m (Maybe PackageEntry) + -- ^ Nothing if the whole package entry should be removed, otherwise + -- it returns the updated PackageEntry +removePathFromPackageEntry menv projectRoot pathToRemove packageEntry = do + locationPath <- resolvePackageLocation menv projectRoot (peLocation packageEntry) + case peSubdirs packageEntry of + [] -> if locationPath == pathToRemove then return Nothing else return (Just packageEntry) + subdirPaths -> do + let shouldKeepSubdir path = do + resolvedPath <- resolveDir locationPath path + return (pathToRemove /= resolvedPath) + filteredSubdirs <- filterM shouldKeepSubdir subdirPaths + if null filteredSubdirs then return Nothing else return (Just packageEntry {peSubdirs = filteredSubdirs}) + + -- | Get the stack root, e.g. @~/.stack@, and determine whether the user owns it. -- -- On Windows, the second value is always 'True'. @@ -799,7 +833,9 @@ mstackRoot <- liftIO $ lookupEnv stackRootEnvVar case mstackRoot of Nothing -> getAppUserDataDir stackProgName - Just x -> parseAbsDir x + Just x -> case parseAbsDir x of + Nothing -> throwString ("Failed to parse STACK_ROOT environment variable (expected absolute directory): " ++ show x) + Just parsed -> return parsed (existingStackRootOrParentDir, userOwnsIt) <- do mdirAndOwnership <- findInParents getDirAndOwnership stackRoot @@ -893,25 +929,28 @@ -- | Load and parse YAML from the given config file. Throws -- 'ParseConfigFileException' when there's a decoding error. loadConfigYaml - :: (FromJSON (WithJSONWarnings a), MonadIO m, MonadLogger m) - => Path Abs File -> m a -loadConfigYaml path = do - eres <- loadYaml path + :: (MonadIO m, MonadLogger m) + => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> m a +loadConfigYaml parser path = do + eres <- loadYaml parser path case eres of Left err -> liftIO $ throwM (ParseConfigFileException path err) Right res -> return res -- | Load and parse YAML from the given file. loadYaml - :: (FromJSON (WithJSONWarnings a), MonadIO m, MonadLogger m) - => Path Abs File -> m (Either Yaml.ParseException a) -loadYaml path = do + :: (MonadIO m, MonadLogger m) + => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> m (Either Yaml.ParseException a) +loadYaml parser path = do eres <- liftIO $ Yaml.decodeFileEither (toFilePath path) case eres of Left err -> return (Left err) - Right (WithJSONWarnings res warnings) -> do - logJSONWarnings (toFilePath path) warnings - return (Right res) + Right val -> + case Yaml.parseEither parser val of + Left err -> return (Left (Yaml.AesonException err)) + Right (WithJSONWarnings res warnings) -> do + logJSONWarnings (toFilePath path) warnings + return (Right res) -- | Get the location of the project config file, if it exists. getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m) @@ -968,7 +1007,7 @@ return LCSNoConfig where load fp = do - ProjectAndConfigMonoid project config <- loadConfigYaml fp + ProjectAndConfigMonoid project config <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp return (project, fp, config) -- | Get the location of the default stack configuration file. diff --git a/src/Stack/Config/Build.hs b/src/Stack/Config/Build.hs --- a/src/Stack/Config/Build.hs +++ b/src/Stack/Config/Build.hs @@ -3,6 +3,7 @@ -- | Build configuration module Stack.Config.Build where +import Data.Maybe import Data.Monoid.Extra import Stack.Types.Config @@ -11,16 +12,20 @@ buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts { boptsLibProfile = fromFirst (boptsLibProfile defaultBuildOpts) - buildMonoidLibProfile + (buildMonoidLibProfile <> + First (if tracing || profiling then Just True else Nothing)) , boptsExeProfile = fromFirst (boptsExeProfile defaultBuildOpts) - buildMonoidExeProfile + (buildMonoidExeProfile <> + First (if tracing || profiling then Just True else Nothing)) , boptsLibStrip = fromFirst (boptsLibStrip defaultBuildOpts) - buildMonoidLibStrip + (buildMonoidLibStrip <> + First (if noStripping then Just False else Nothing)) , boptsExeStrip = fromFirst (boptsExeStrip defaultBuildOpts) - buildMonoidExeStrip + (buildMonoidExeStrip <> + First (if noStripping then Just False else Nothing)) , boptsHaddock = fromFirst (boptsHaddock defaultBuildOpts) buildMonoidHaddock @@ -32,6 +37,9 @@ , boptsHaddockInternal = fromFirst (boptsHaddockInternal defaultBuildOpts) buildMonoidHaddockInternal + , boptsHaddockHyperlinkSource = fromFirst + (boptsHaddockHyperlinkSource defaultBuildOpts) + buildMonoidHaddockHyperlinkSource , boptsInstallExes = fromFirst (boptsInstallExes defaultBuildOpts) buildMonoidInstallExes @@ -43,11 +51,13 @@ (boptsForceDirty defaultBuildOpts) buildMonoidForceDirty , boptsTests = fromFirst (boptsTests defaultBuildOpts) buildMonoidTests - , boptsTestOpts = testOptsFromMonoid buildMonoidTestOpts + , boptsTestOpts = + testOptsFromMonoid buildMonoidTestOpts additionalArgs , boptsBenchmarks = fromFirst (boptsBenchmarks defaultBuildOpts) buildMonoidBenchmarks - , boptsBenchmarkOpts = benchmarkOptsFromMonoid buildMonoidBenchmarkOpts + , boptsBenchmarkOpts = + benchmarkOptsFromMonoid buildMonoidBenchmarkOpts additionalArgs , boptsReconfigure = fromFirst (boptsReconfigure defaultBuildOpts) buildMonoidReconfigure @@ -58,26 +68,46 @@ (boptsSplitObjs defaultBuildOpts) buildMonoidSplitObjs } - + where + -- These options are not directly used in bopts, instead they + -- transform other options. + tracing = getAny buildMonoidTrace + profiling = getAny buildMonoidProfile + noStripping = getAny buildMonoidNoStrip + -- Additional args for tracing / profiling + additionalArgs = + if tracing || profiling + then Just $ "+RTS" : catMaybes [trac, prof, Just "-RTS"] + else Nothing + trac = + if tracing + then Just "-xc" + else Nothing + prof = + if profiling + then Just "-p" + else Nothing haddockOptsFromMonoid :: HaddockOptsMonoid -> HaddockOpts haddockOptsFromMonoid HaddockOptsMonoid{..} = defaultHaddockOpts {hoAdditionalArgs = hoMonoidAdditionalArgs} -testOptsFromMonoid :: TestOptsMonoid -> TestOpts -testOptsFromMonoid TestOptsMonoid{..} = +testOptsFromMonoid :: TestOptsMonoid -> Maybe [String] -> TestOpts +testOptsFromMonoid TestOptsMonoid{..} madditional = defaultTestOpts { toRerunTests = fromFirst (toRerunTests defaultTestOpts) toMonoidRerunTests - , toAdditionalArgs = toMonoidAdditionalArgs + , toAdditionalArgs = fromMaybe [] madditional <> toMonoidAdditionalArgs , toCoverage = fromFirst (toCoverage defaultTestOpts) toMonoidCoverage , toDisableRun = fromFirst (toDisableRun defaultTestOpts) toMonoidDisableRun } -benchmarkOptsFromMonoid :: BenchmarkOptsMonoid -> BenchmarkOpts -benchmarkOptsFromMonoid BenchmarkOptsMonoid{..} = +benchmarkOptsFromMonoid :: BenchmarkOptsMonoid -> Maybe [String] -> BenchmarkOpts +benchmarkOptsFromMonoid BenchmarkOptsMonoid{..} madditional = defaultBenchmarkOpts - { beoAdditionalArgs = getFirst beoMonoidAdditionalArgs + { beoAdditionalArgs = + fmap (\args -> unwords args <> " ") madditional <> + getFirst beoMonoidAdditionalArgs , beoDisableRun = fromFirst (beoDisableRun defaultBenchmarkOpts) beoMonoidDisableRun diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -16,6 +16,7 @@ import Stack.Types.Version import Stack.Types.Nix import Stack.Types.Compiler +import Stack.Types.StringError import Control.Exception.Lifted import Control.Monad.Catch (throwM,MonadCatch) import Prelude @@ -60,7 +61,7 @@ (fixMinor (versionText v))) in case compilerVersion of GhcVersion v -> nixCompilerFromVersion v - _ -> error "Only GHC is supported by now by stack --nix" + _ -> errorString "Only GHC is supported by stack --nix" -- Exceptions thown specifically by Stack.Nix data StackNixException diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -34,6 +34,7 @@ import Stack.Constants import Stack.Types.Config import Stack.Types.Resolver +import Stack.Types.StringError data ConfigCmdSet = ConfigCmdSetResolver AbstractResolver @@ -69,7 +70,7 @@ case mstackYaml of LCSProject stackYaml -> return stackYaml LCSNoProject -> liftM ( stackDotYaml) (getImplicitGlobalProjectDir conf) - LCSNoConfig -> error "config command used when no local configuration available" + LCSNoConfig -> errorString "config command used when no local configuration available" CommandScopeGlobal -> return (configUserConfigPath conf)) -- We don't need to worry about checking for a valid yaml here (config :: Yaml.Object) <- @@ -95,7 +96,7 @@ ResolverSnapshot snapName -> void $ loadMiniBuildPlan snapName ResolverCompiler _ -> return () -- TODO: custom snapshot support? Would need a way to specify on CLI - ResolverCustom _ _ -> error "'stack config set resolver' does not support custom resolvers" + ResolverCustom _ _ -> errorString "'stack config set resolver' does not support custom resolvers" return (Yaml.String (resolverName concreteResolver)) cfgCmdSetValue (ConfigCmdSetSystemGhc _ bool) = return (Yaml.Bool bool) @@ -159,4 +160,4 @@ _ -> OA.readerError ("Invalid value " ++ show s ++ ": Expected \"true\" or \"false\"") boolArgument :: OA.Parser Bool -boolArgument = OA.argument readBool (OA.metavar "true/false") +boolArgument = OA.argument readBool (OA.metavar "true|false" <> OA.completeWith ["true", "false"]) diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -12,6 +12,7 @@ ,imageStagingDir ,projectDockerSandboxDir ,stackDotYaml + ,stackWorkEnvVar ,stackRootEnvVar ,stackRootOptionName ,deprecatedStackRootOptionName @@ -200,6 +201,10 @@ -- | The filename used for the stack config file. stackDotYaml :: Path Rel File stackDotYaml = $(mkRelFile "stack.yaml") + +-- | Environment variable used to override the '.stack-work' relative dir. +stackWorkEnvVar :: String +stackWorkEnvVar = "STACK_WORK" -- | Environment variable used to override the '~/.stack' location. stackRootEnvVar :: String diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -53,6 +53,7 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.StackT (StackM) +import Stack.Types.StringError import Stack.Types.Version import System.FilePath (isPathSeparator) import System.Process.Read @@ -242,10 +243,10 @@ { boptsCLITargets = 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 " ++ + STUnknown -> throwString $ + "Error: " ++ packageNameString name ++ " isn't a known local page" + STNonLocal -> throwString $ + "Error: Expected a local package, but " ++ packageNameString name ++ " is either an extra-dep or in the snapshot." STLocalComps comps -> do @@ -270,7 +271,7 @@ else return [] tixPaths <- liftM (\xs -> xs ++ targetTixFiles) $ mapM (resolveFile' . T.unpack) tixFiles when (null tixPaths) $ - fail "Not generating combined report, because no targets or tix files are specified." + throwString "Not generating combined report, because no targets or tix files are specified." outputDir <- hpcReportDir reportDir <- case hroptsDestDir opts of Nothing -> return (outputDir $(mkRelDir "combined/custom")) diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -38,7 +38,7 @@ import Data.Char (isSpace,toUpper,isAscii,isDigit) import Data.Conduit.List (sinkNull) import Data.List (dropWhileEnd,intercalate,isPrefixOf,isInfixOf,foldl') -import Data.List.Extra (trim) +import Data.List.Extra (trim, nubOrd) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe @@ -112,7 +112,7 @@ then liftIO $ do duUid <- User.getEffectiveUserID duGid <- User.getEffectiveGroupID - duGroups <- User.getGroups + duGroups <- nubOrd <$> User.getGroups duUmask <- Files.setFileCreationMask 0o022 -- Only way to get old umask seems to be to change it, so set it back afterward _ <- Files.setFileCreationMask duUmask diff --git a/src/Stack/Docker/GlobalDB.hs b/src/Stack/Docker/GlobalDB.hs --- a/src/Stack/Docker/GlobalDB.hs +++ b/src/Stack/Docker/GlobalDB.hs @@ -32,6 +32,7 @@ import Path.IO (ensureDir) import Stack.Types.Config import Stack.Types.Docker +import Stack.Types.StringError share [mkPersist sqlSettings, mkMigrate "migrateTables"] [persistLowerCase| DockerImageProject @@ -109,7 +110,7 @@ str' = fromMaybe str $ stripPrefix "user error (" $ fromMaybe str $ stripSuffix ")" str if "ErrorReadOnly" `isInfixOf` str - then fail $ str' ++ + then throwString $ str' ++ " This likely indicates that your DB file, " ++ toFilePath db ++ ", has incorrect permissions or ownership." else throwIO (ex :: IOException) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -39,10 +39,13 @@ import Stack.Build.Target import Stack.Constants import Stack.Package +import Stack.PackageDump (DumpPackage(..)) import Stack.Types.Build import Stack.Types.Config import Stack.Types.FlagName +import Stack.Types.GhcPkgId import Stack.Types.Package +import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.StackT import Stack.Types.Version @@ -116,17 +119,21 @@ => DotOpts -> m (Map PackageName (Set PackageName, DotPayload)) createDependencyGraph dotOpts = do - (_, _, locals, _, _, sourceMap) <- loadSourceMapFull False NeedTargets defaultBuildOptsCLI + (_, _, locals, _, _, sourceMap) <- loadSourceMapFull NeedTargets defaultBuildOptsCLI { boptsCLITargets = dotTargets dotOpts , boptsCLIFlags = dotFlags dotOpts } let graph = Map.fromList (localDependencies dotOpts (filter lpWanted locals)) menv <- getMinimalEnvOverride - installedMap <- fmap snd . fst4 <$> getInstalled menv + (installedMap, globalDump, _, _) <- getInstalled menv (GetInstalledOpts False False False) sourceMap - withLoadPackage menv (\loader -> do - let depLoader = createDepLoader sourceMap installedMap loadPackageDeps + -- TODO: Can there be multiple entries for wired-in-packages? If so, + -- this will choose one arbitrarily.. + let globalDumpMap = Map.fromList $ map (\dp -> (packageIdentifierName (dpPackageIdent dp), dp)) globalDump + globalIdMap = Map.fromList $ map (\dp -> (dpGhcPkgId dp, dpPackageIdent dp)) globalDump + withLoadPackage (\loader -> do + let depLoader = createDepLoader sourceMap installedMap globalDumpMap globalIdMap loadPackageDeps loadPackageDeps name version flags ghcOptions -- Skip packages that can't be loaded - see -- https://github.com/commercialhaskell/stack/issues/2967 @@ -135,10 +142,7 @@ | otherwise = fmap (packageAllDeps &&& makePayload) (loader name version flags ghcOptions) liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader) - where fst4 :: (a,b,c,d) -> a - fst4 (x,_,_,_) = x - - makePayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) + where makePayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) listDependencies :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) => ListDepsOpts @@ -208,20 +212,34 @@ -- | Given a SourceMap and a dependency loader, load the set of dependencies for a package createDepLoader :: Applicative m => Map PackageName PackageSource - -> Map PackageName Installed + -> Map PackageName (InstallLocation, Installed) + -> Map PackageName (DumpPackage () () ()) + -> Map GhcPkgId PackageIdentifier -> (PackageName -> Version -> Map FlagName Bool -> [Text] -> m (Set PackageName, DotPayload)) -> PackageName -> m (Set PackageName, DotPayload) -createDepLoader sourceMap installed loadPackageDeps pkgName = - case Map.lookup pkgName sourceMap of - Just (PSLocal lp) -> pure (packageAllDeps pkg, payloadFromLocal pkg) - where - pkg = localPackageToPackage lp - Just (PSUpstream version _ flags ghcOptions _) -> loadPackageDeps pkgName version flags ghcOptions - Nothing -> pure (Set.empty, payloadFromInstalled (Map.lookup pkgName installed)) +createDepLoader sourceMap installed globalDumpMap globalIdMap loadPackageDeps pkgName = + if not (pkgName `HashSet.member` wiredInPackages) + then case Map.lookup pkgName sourceMap of + Just (PSLocal lp) -> pure (packageAllDeps pkg, payloadFromLocal pkg) + where + pkg = localPackageToPackage lp + Just (PSUpstream version _ flags ghcOptions _) -> + loadPackageDeps pkgName version flags ghcOptions + Nothing -> pure (Set.empty, payloadFromInstalled (Map.lookup pkgName installed)) + -- For wired-in-packages, use information from ghc-pkg (see #3084) + else case Map.lookup pkgName globalDumpMap of + Nothing -> error ("Invariant violated: Expected to find wired-in-package " ++ packageNameString pkgName ++ " in global DB") + Just dp -> pure (Set.fromList deps, payloadFromDump dp) + where + deps = map (\depId -> maybe (error ("Invariant violated: Expected to find " ++ ghcPkgIdString depId ++ " in global DB")) + packageIdentifierName + (Map.lookup depId globalIdMap)) + (dpDepends dp) where payloadFromLocal pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) - payloadFromInstalled maybePkg = DotPayload (fmap installedVersion maybePkg) Nothing + payloadFromInstalled maybePkg = DotPayload (fmap (installedVersion . snd) maybePkg) Nothing + payloadFromDump dp = DotPayload (Just $ packageIdentifierVersion $ dpPackageIdent dp) (dpLicense dp) -- | Resolve the direct (depth 0) external dependencies of the given local packages localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))] diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs --- a/src/Stack/Exec.hs +++ b/src/Stack/Exec.hs @@ -21,7 +21,6 @@ import Control.Exception.Lifted import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import System.Exit -import System.IO (stderr, stdin, stdout, hSetBuffering, BufferMode(..)) import System.Process.Run (callProcess, callProcessObserveStdout, Cmd(..)) #ifdef WINDOWS import System.Process.Read (EnvOverride) @@ -62,7 +61,6 @@ exec = execSpawn #else exec menv cmd0 args = do - setNoBuffering cmd <- preProcess Nothing menv cmd0 $withProcessTimeLog cmd args $ liftIO $ PID1.run cmd args (envHelper menv) @@ -75,7 +73,6 @@ execSpawn :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) => EnvOverride -> String -> [String] -> m b execSpawn menv cmd0 args = do - setNoBuffering e <- $withProcessTimeLog cmd0 args $ try (callProcess (Cmd Nothing cmd0 menv args)) liftIO $ case e of @@ -90,9 +87,3 @@ case e of Left (ProcessExitedUnsuccessfully _ ec) -> liftIO $ exitWith ec Right s -> return s - -setNoBuffering :: MonadIO m => m () -setNoBuffering = liftIO $ do - hSetBuffering stdout NoBuffering - hSetBuffering stdin NoBuffering - hSetBuffering stderr NoBuffering diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -34,7 +34,6 @@ import Control.Concurrent.MVar.Lifted (modifyMVar, newMVar) import Control.Concurrent.STM import Control.Exception (assert) -import Control.Exception.Safe (tryIO) import Control.Monad (join, liftM, unless, void, when) import Control.Monad.Catch import Control.Monad.IO.Class @@ -49,23 +48,18 @@ import Data.Either (partitionEithers) import qualified Data.Foldable as F import Data.Function (fix) -import qualified Data.Git as Git -import qualified Data.Git.Ref as Git -import qualified Data.Git.Storage as Git -import qualified Data.Git.Storage.Object as Git import qualified Data.HashMap.Strict as HashMap 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) +import Data.Maybe (maybeToList, catMaybes, isJust) import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set -import Data.String (fromString) import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Text.Metrics import Data.Typeable (Typeable) import Data.Word (Word64) @@ -74,7 +68,6 @@ import Path.Extra (toFilePathNoTrailingSep) import Path.IO import Prelude -- Fix AMP warning -import Stack.GhcPkg import Stack.PackageIndex import Stack.Types.BuildPlan import Stack.Types.Config @@ -128,11 +121,10 @@ -- | Fetch packages into the cache without unpacking fetchPackages :: (StackMiniM env m, HasConfig env) - => EnvOverride - -> Set PackageIdentifier + => Set PackageIdentifier -> m () -fetchPackages menv idents' = do - resolved <- resolvePackages menv Nothing idents Set.empty +fetchPackages idents' = do + resolved <- resolvePackages Nothing idents Set.empty ToFetchResult toFetch alreadyUnpacked <- getToFetch Nothing resolved assert (Map.null alreadyUnpacked) (return ()) nowUnpacked <- fetchPackages' Nothing toFetch @@ -144,18 +136,17 @@ -- | Intended to work for the command line command. unpackPackages :: (StackMiniM env m, HasConfig env) - => EnvOverride - -> Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan + => Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan -> FilePath -- ^ destination -> [String] -- ^ names or identifiers -> m () -unpackPackages menv mMiniBuildPlan dest input = do +unpackPackages mMiniBuildPlan dest input = do dest' <- resolveDir' dest (names, idents) <- case partitionEithers $ map parse input of ([], x) -> return $ partitionEithers x (errs, _) -> throwM $ CouldNotParsePackageSelectors errs - resolved <- resolvePackages menv mMiniBuildPlan - (Map.fromList $ map (, Nothing) idents) + resolved <- resolvePackages mMiniBuildPlan + (Map.fromList idents) (Set.fromList names) ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just dest') resolved unless (Map.null alreadyUnpacked) $ @@ -174,20 +165,23 @@ Right x -> Right $ Left x Left _ -> case parsePackageIdentifierFromString s of - Left _ -> Left s - Right x -> Right $ Right x + Right x -> Right $ Right (x, Nothing) + Left _ -> maybe (Left s) (Right . Right) $ do + (identS, '@':revisionS) <- return $ break (== '@') s + Right ident <- return $ parsePackageIdentifierFromString identS + hash <- T.stripPrefix "gitsha1:" $ T.pack revisionS + Just (ident, Just $ GitSHA1 $ encodeUtf8 hash) -- | Ensure that all of the given package idents are unpacked into the build -- unpack directory, and return the paths to all of the subdirectories. unpackPackageIdents :: (StackMiniM env m, HasConfig env) - => EnvOverride - -> Path Abs Dir -- ^ unpack directory + => Path Abs Dir -- ^ unpack directory -> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 -> Map PackageIdentifier (Maybe GitSHA1) -> m (Map PackageIdentifier (Path Abs Dir)) -unpackPackageIdents menv unpackDir mdistDir idents = do - resolved <- resolvePackages menv Nothing idents Set.empty +unpackPackageIdents unpackDir mdistDir idents = do + resolved <- resolvePackages Nothing idents Set.empty ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just unpackDir) resolved nowUnpacked <- fetchPackages' mdistDir toFetch return $ alreadyUnpacked <> nowUnpacked @@ -196,27 +190,24 @@ { rpIdent :: !PackageIdentifier , rpCache :: !PackageCache , rpIndex :: !PackageIndex - , rpGitSHA1 :: !(Maybe GitSHA1) - , rpMissingGitSHA :: !Bool } deriving Show -- | Resolve a set of package names and identifiers into @FetchPackage@ values. resolvePackages :: (StackMiniM env m, HasConfig env) - => EnvOverride - -> Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan + => Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan -> Map PackageIdentifier (Maybe GitSHA1) -> Set PackageName -> m [ResolvedPackage] -resolvePackages menv mMiniBuildPlan idents0 names0 = do +resolvePackages mMiniBuildPlan idents0 names0 = do eres <- go case eres of Left _ -> do - updateAllIndices menv + updateAllIndices go >>= either throwM return Right x -> return x where - go = r <$> resolvePackagesAllowMissing menv mMiniBuildPlan idents0 names0 + go = r <$> resolvePackagesAllowMissing mMiniBuildPlan idents0 names0 r (missingNames, missingIdents, idents) | not $ Set.null missingNames = Left $ UnknownPackageNames missingNames | not $ Set.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" @@ -224,22 +215,20 @@ resolvePackagesAllowMissing :: (StackMiniM env m, HasConfig env) - => EnvOverride - -> Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan + => Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan -> Map PackageIdentifier (Maybe GitSHA1) -> Set PackageName -> m (Set PackageName, Set PackageIdentifier, [ResolvedPackage]) -resolvePackagesAllowMissing menv mMiniBuildPlan idents0 names0 = do - res@(_, _, resolved) <- inner - if any rpMissingGitSHA resolved +resolvePackagesAllowMissing mMiniBuildPlan idents0 names0 = do + (res1, res2, resolved) <- inner + if any (isJust . snd) resolved then do $logInfo "Missing some cabal revision files, updating indices" - updateAllIndices menv - res'@(_, _, resolved') <- inner + updateAllIndices + (res1', res2', resolved') <- inner -- Print an error message if any SHAs are still missing. - F.forM_ (filter rpMissingGitSHA resolved') - $ \rp -> F.forM_ (rpGitSHA1 rp) $ \(GitSHA1 sha) -> + F.forM_ resolved' $ \(rp, missing) -> F.forM_ missing $ \(GitSHA1 sha) -> $logWarn $ mconcat [ "Did not find .cabal file for " , T.pack $ packageIdentifierString $ rpIdent rp @@ -248,8 +237,8 @@ , " in tarball-based cache" ] - return res' - else return res + return (res1', res2', map fst resolved') + else return (res1, res2, map fst resolved) where inner = do (caches, shaCaches) <- getPackageCaches @@ -281,9 +270,9 @@ case Map.lookup ident caches of Nothing -> Left ident Just (index, cache) -> - let (index', cache', mgitsha', missingGitSHA) = + let (index', cache', missingGitSHA) = case mgitsha of - Nothing -> (index, cache, mgitsha, False) + Nothing -> (index, cache, mgitsha) Just gitsha -> case HashMap.lookup gitsha shaCaches of Just (index'', offsetSize) -> @@ -293,29 +282,14 @@ -- about this SHA, don't do -- any lookups later , Nothing - , False -- not missing, we found the Git SHA ) - Nothing -> (index, cache, mgitsha, - case simplifyIndexLocation (indexLocation index) of - -- No surprise that there's - -- nothing in the cache about - -- the SHA, since this package - -- comes from a Git - -- repo. We'll look it up - -- later when we've opened up - -- the Git repo itself for - -- reading. - SILGit _ -> False - - -- Index using HTTP, so we're missing the Git SHA - SILHttp _ _ -> True) - in Right ResolvedPackage - { rpIdent = ident - , rpCache = cache' - , rpIndex = index' - , rpGitSHA1 = mgitsha' - , rpMissingGitSHA = missingGitSHA - } + -- Index using HTTP, so we're missing the Git SHA + Nothing -> (index, cache, mgitsha) + in Right (ResolvedPackage + { rpIdent = ident + , rpCache = cache' + , rpIndex = index' + }, missingGitSHA) data ToFetch = ToFetch { tfTarball :: !(Path Abs File) @@ -341,37 +315,11 @@ -> m [b] withCabalFiles name pkgs f = do indexPath <- configPackageIndex name - mgitRepo <- configPackageIndexRepo name bracket (liftIO $ openBinaryFile (toFilePath indexPath) ReadMode) - (liftIO . hClose) $ \h -> - let inner mgit = mapM (goPkg h mgit) pkgs - in case mgitRepo of - Nothing -> inner Nothing - Just repo -> bracket - (liftIO $ Git.openRepo - $ fromString - $ toFilePath repo FP. ".git") - (liftIO . Git.closeRepo) - (inner . Just) + (liftIO . hClose) $ \h -> mapM (goPkg h) pkgs where - goPkg h (Just git) (rp@(ResolvedPackage ident _pc _index (Just (GitSHA1 sha)) _missing), tf) = do - let ref = Git.fromHex sha - mobj <- liftIO $ tryIO $ Git.getObject git ref True - case mobj of - Right (Just (Git.ObjBlob (Git.Blob bs))) -> liftIO $ f ident tf (L.toStrict bs) - -- fallback when the appropriate SHA isn't found - e -> do - $logWarn $ mconcat - [ "Did not find .cabal file for " - , T.pack $ packageIdentifierString ident - , " with SHA of " - , decodeUtf8 sha - , " in the Git repository" - ] - $logDebug (T.pack (show e)) - goPkg h Nothing (rp { rpGitSHA1 = Nothing }, tf) - goPkg h _mgit (ResolvedPackage ident pc _index _mgitsha _missing, tf) = do + goPkg h (ResolvedPackage ident pc _index, tf) = do -- Did not find warning for tarballs is handled above let OffsetSize offset size = pcOffsetSize pc liftIO $ do @@ -383,10 +331,9 @@ -- package indices. withCabalLoader :: (StackMiniM env m, HasConfig env, MonadBaseUnlift IO m) - => EnvOverride - -> ((PackageIdentifier -> IO ByteString) -> m a) + => ((PackageIdentifier -> IO ByteString) -> m a) -> m a -withCabalLoader menv inner = do +withCabalLoader inner = do env <- ask -- Want to try updating the index once during a single run for missing @@ -429,7 +376,7 @@ , " in your package indices.\n" , "Updating and trying again." ] - updateAllIndices menv + updateAllIndices _ <- getPackageCaches return () return (False, doLookup ident) @@ -454,8 +401,6 @@ { rpIdent = ident , rpCache = cache , rpIndex = index - , rpGitSHA1 = Nothing - , rpMissingGitSHA = False }, ())] $ \_ _ bs -> return bs return $ Just bs @@ -486,9 +431,11 @@ let getName = packageNameText . packageIdentifierName name = getName ident in NE.nonEmpty - . Map.keys - . Map.filterWithKey (const . (== 1) . damerauLevenshtein name) - . Map.mapKeys getName + . take 10 + . map snd + . filter (\(distance, _) -> distance < 4) + . map (\(k, _) -> (damerauLevenshtein name (getName k), getName k)) + . Map.toList -- | Figure out where to fetch from. getToFetch :: (StackMiniM env m, HasConfig env) diff --git a/src/Stack/FileWatch.hs b/src/Stack/FileWatch.hs --- a/src/Stack/FileWatch.hs +++ b/src/Stack/FileWatch.hs @@ -10,7 +10,7 @@ import Blaze.ByteString.Builder.Char.Utf8 (fromShow) import Control.Concurrent.Async (race_) import Control.Concurrent.STM -import Control.Exception (Exception, fromException) +import Control.Exception (Exception, fromException, catch, throwIO) import Control.Exception.Safe (tryAny) import Control.Monad (forever, unless, when) import qualified Data.ByteString.Lazy as L @@ -20,10 +20,10 @@ import qualified Data.Set as Set import Data.String (fromString) import Data.Traversable (forM) +import GHC.IO.Exception import GHC.IO.Handle (hIsTerminalDevice) import Path import System.Console.ANSI -import System.Exit import System.FSNotify import System.IO (Handle, stdout, stderr, hPutStrLn) @@ -93,13 +93,17 @@ keepListening _dir listen () = Just $ return $ Just listen stopListening = Map.map $ \f -> do - () <- f + () <- f `catch` \ioe -> + -- Ignore invalid argument error - it can happen if + -- the directory is removed. + case ioe_type ioe of + InvalidArgument -> return () + _ -> throwIO ioe return Nothing startListening = Map.mapWithKey $ \dir () -> do let dir' = fromString $ toFilePath dir listen <- watchDir manager dir' (const True) onChange return $ Just listen - let watchInput = do line <- getLine diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -168,7 +168,7 @@ pkgs <- getGhciPkgInfos buildOptsCLI sourceMap addPkgs (fmap fst mfileTargets) localTargets checkForIssues pkgs -- Finally, do the invocation of ghci - runGhci opts localTargets mainIsTargets pkgs + runGhci opts localTargets mainIsTargets pkgs (maybe [] snd mfileTargets) preprocessTargets :: (StackM r m) => [Text] -> m (Either [Path Abs File] [Text]) preprocessTargets rawTargets = do @@ -326,8 +326,9 @@ -> [(PackageName, (Path Abs File, SimpleTarget))] -> Maybe (Map PackageName SimpleTarget) -> [GhciPkgInfo] + -> [Path Abs File] -> m () -runGhci GhciOpts{..} targets mainIsTargets pkgs = do +runGhci GhciOpts{..} targets mainIsTargets pkgs extraFiles = do config <- view configL wc <- view $ actualCompilerVersionL.whichCompilerL let pkgopts = hidePkgOpt ++ genOpts ++ ghcOpts @@ -380,7 +381,7 @@ renderFn <- interrogateExeForRenderFunction bopts <- view buildOptsL mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs - scriptPath <- writeGhciScript tmpDirectory (renderFn pkgs mainFile) + scriptPath <- writeGhciScript tmpDirectory (renderFn pkgs mainFile extraFiles) execGhci (macrosOptions ++ ["-ghci-script=" <> toFilePath scriptPath]) writeMacrosFile :: (MonadIO m) => Path Abs Dir -> [GhciPkgInfo] -> m [String] @@ -402,21 +403,21 @@ findOwningPackageForMain pkgs mainFile = find (\pkg -> toFilePath (ghciPkgDir pkg) `isPrefixOf` toFilePath mainFile) pkgs -renderScriptGhci :: [GhciPkgInfo] -> Maybe (Path Abs File) -> GhciScript -renderScriptGhci pkgs mainFile = +renderScriptGhci :: [GhciPkgInfo] -> Maybe (Path Abs File) -> [Path Abs File] -> GhciScript +renderScriptGhci pkgs mainFile extraFiles = let addPhase = mconcat $ fmap renderPkg pkgs mainPhase = case mainFile of Just path -> cmdAddFile path Nothing -> mempty modulePhase = cmdModule $ foldl' S.union S.empty (fmap ghciPkgModules pkgs) - in case getFileTargets pkgs of + in case getFileTargets pkgs <> extraFiles of [] -> addPhase <> mainPhase <> modulePhase fileTargets -> mconcat $ map cmdAddFile fileTargets where renderPkg pkg = cmdAdd (ghciPkgModules pkg) -renderScriptIntero :: [GhciPkgInfo] -> Maybe (Path Abs File) -> GhciScript -renderScriptIntero pkgs mainFile = +renderScriptIntero :: [GhciPkgInfo] -> Maybe (Path Abs File) -> [Path Abs File] -> GhciScript +renderScriptIntero pkgs mainFile extraFiles = let addPhase = mconcat $ fmap renderPkg pkgs mainPhase = case mainFile of Just path -> @@ -425,7 +426,7 @@ Nothing -> cmdAddFile path Nothing -> mempty modulePhase = cmdModule $ foldl' S.union S.empty (fmap ghciPkgModules pkgs) - in case getFileTargets pkgs of + in case getFileTargets pkgs <> extraFiles of [] -> addPhase <> mainPhase <> modulePhase fileTargets -> mconcat $ map cmdAddFile fileTargets where @@ -585,7 +586,7 @@ | otherwise = Nothing mbuildinfo <- forM mbuildinfofp readDotBuildinfo let pkg = - packageFromPackageDescription config gpkgdesc $ + packageFromPackageDescription config (C.genPackageFlags gpkgdesc) $ maybe id C.updatePackageDescription mbuildinfo $ resolvePackageDescription config gpkgdesc diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -97,10 +97,8 @@ hoogleMinIdent = PackageIdentifier hooglePackageName hoogleMinVersion hooglePackageIdentifier <- - do menv <- getMinimalEnvOverride - (_,_,resolved) <- + do (_,_,resolved) <- resolvePackagesAllowMissing - menv -- FIXME this Nothing means "do not follow any -- specific snapshot", which matches old diff --git a/src/Stack/Image.hs b/src/Stack/Image.hs --- a/src/Stack/Image.hs +++ b/src/Stack/Image.hs @@ -15,6 +15,7 @@ import Control.Monad import Control.Monad.Catch hiding (bracket) import Control.Monad.IO.Class +import Control.Monad.Logger import Data.Char (toLower) import qualified Data.Map.Strict as Map import Data.Maybe @@ -25,6 +26,7 @@ import Path.Extra import Path.IO import Stack.Constants +import Stack.PrettyPrint import Stack.Types.Config import Stack.Types.Image import Stack.Types.StackT @@ -89,7 +91,16 @@ let destBinPath = dir $(mkRelDir "usr/local/bin") ensureDir destBinPath case imgDockerExecutables opts of - Nothing -> copyDirRecur srcBinPath destBinPath + Nothing -> do + $logInfo "" + $logInfo "Note: 'executables' not specified for a image container, so every executable in the project's local bin dir will be used." + mcontents <- forgivingAbsence $ listDir srcBinPath + case mcontents of + Just (files, dirs) + | not (null files) || not (null dirs) -> copyDirRecur srcBinPath destBinPath + _ -> $prettyWarn "The project's local bin dir contains no files, so no executables will be added to the docker image." + $logInfo "" + Just exes -> forM_ exes diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -50,6 +50,7 @@ import Stack.Types.PackageName import Stack.Types.Resolver import Stack.Types.StackT (StackM) +import Stack.Types.StringError import Stack.Types.Version import qualified System.FilePath as FP @@ -67,10 +68,11 @@ reldest <- toFilePath `liftM` makeRelativeToCurrentDir dest exists <- doesFileExist dest - when (not (forceOverwrite initOpts) && exists) $ do - error ("Stack configuration file " <> reldest <> - " exists, use 'stack solver' to fix the existing config file or \ - \'--force' to overwrite it.") + when (not (forceOverwrite initOpts) && exists) $ + throwString + ("Error: Stack configuration file " <> reldest <> + " exists, use 'stack solver' to fix the existing config file or \ + \'--force' to overwrite it.") dirs <- mapM (resolveDir' . T.unpack) (searchDirs initOpts) let noPkgMsg = "In order to init, you should have an existing .cabal \ @@ -243,7 +245,7 @@ , "" , "Some commonly used options have been documented as comments in this file." , "For advanced use and comprehensive documentation of the format, please see:" - , "http://docs.haskellstack.org/en/stable/yaml_configuration/" + , "https://docs.haskellstack.org/en/stable/yaml_configuration/" ] resolverHelp = commentHelp @@ -310,7 +312,7 @@ getSnapshots' :: (StackM env m, HasConfig env) => m Snapshots -getSnapshots' = +getSnapshots' = do getSnapshots `catchAny` \e -> do $logError $ "Unable to download snapshot list, and therefore could " <> @@ -326,7 +328,7 @@ $logError " http://docs.haskellstack.org/en/stable/yaml_configuration/" $logError "" $logError $ "Exception was: " <> T.pack (show e) - error "" + errorString "" -- | Get the default resolver value getDefaultResolver diff --git a/src/Stack/New.hs b/src/Stack/New.hs --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -84,6 +84,8 @@ :: (StackM env m, HasConfig env) => NewOpts -> Bool -> m (Path Abs Dir) new opts forceOverwrite = do + when (newOptsProjectName opts `elem` wiredInPackages) $ + throwM $ Can'tUseWiredInName (newOptsProjectName opts) pwd <- getCurrentDir absDir <- if bare then return pwd else do relDir <- parseRelDir (packageNameString project) @@ -378,6 +380,7 @@ | FailedToDownloadTemplateInfo !HttpException | BadTemplateInfo !String | BadTemplateInfoResponse !Int + | Can'tUseWiredInName !PackageName deriving (Typeable) instance Exception NewException @@ -440,3 +443,5 @@ "Template info couldn't be parsed: " <> err show (BadTemplateInfoResponse code) = "Unexpected status code while retrieving templates info: " <> show code + show (Can'tUseWiredInName name) = + "The name \"" <> packageNameString name <> "\" is used by GHC wired-in packages, and so shouldn't be used as a package name" diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -83,7 +83,7 @@ inContainer <- getInContainer let pkgsInConfig = nixPackages (configNix config) ghc = nixCompiler compilerVersion - pkgs = pkgsInConfig ++ [ghc] + pkgs = pkgsInConfig ++ [ghc, "git"] pkgsStr = "[" <> T.intercalate " " pkgs <> "]" pureShell = nixPureShell (configNix config) addGCRoots = nixAddGCRoots (configNix config) diff --git a/src/Stack/Options/BenchParser.hs b/src/Stack/Options/BenchParser.hs --- a/src/Stack/Options/BenchParser.hs +++ b/src/Stack/Options/BenchParser.hs @@ -13,6 +13,7 @@ benchOptsParser :: Bool -> Parser BenchmarkOptsMonoid benchOptsParser hide0 = BenchmarkOptsMonoid <$> optionalFirst (strOption (long "benchmark-arguments" <> + long "ba" <> metavar "BENCH_ARGS" <> help ("Forward BENCH_ARGS to the benchmark suite. " <> "Supports templates from `cabal bench`") <> diff --git a/src/Stack/Options/BuildMonoidParser.hs b/src/Stack/Options/BuildMonoidParser.hs --- a/src/Stack/Options/BuildMonoidParser.hs +++ b/src/Stack/Options/BuildMonoidParser.hs @@ -1,6 +1,5 @@ module Stack.Options.BuildMonoidParser where -import Data.Maybe (catMaybes) import Data.Monoid.Extra import Options.Applicative import Options.Applicative.Builder.Extra @@ -13,94 +12,54 @@ buildOptsMonoidParser :: GlobalOptsContext -> Parser BuildOptsMonoid buildOptsMonoidParser hide0 = - transform <$> trace <*> profile <*> noStrip <*> options + BuildOptsMonoid <$> trace <*> profile <*> noStrip <*> + libProfiling <*> exeProfiling <*> libStripping <*> + exeStripping <*> haddock <*> haddockOptsParser hideBool <*> + openHaddocks <*> haddockDeps <*> haddockInternal <*> + haddockHyperlinkSource <*> copyBins <*> preFetch <*> keepGoing <*> + forceDirty <*> tests <*> testOptsParser hideBool <*> benches <*> + benchOptsParser hideBool <*> reconfigure <*> cabalVerbose <*> splitObjs where hideBool = hide0 /= BuildCmdGlobalOpts hide = hideMods hideBool hideExceptGhci = hideMods (hide0 `notElem` [BuildCmdGlobalOpts, GhciCmdGlobalOpts]) - transform tracing profiling noStripping = - enable - where - enable opts - | tracing || profiling = - opts - { buildMonoidLibProfile = First (Just True) - , buildMonoidExeProfile = First (Just True) - , buildMonoidBenchmarkOpts = bopts - { beoMonoidAdditionalArgs = First (getFirst (beoMonoidAdditionalArgs bopts) <> - Just (" " <> unwords additionalArgs)) - } - , buildMonoidTestOpts = topts - { toMonoidAdditionalArgs = toMonoidAdditionalArgs topts <> - additionalArgs - } - } - | noStripping = - opts - { buildMonoidLibStrip = First (Just False) - , buildMonoidExeStrip = First (Just False) - } - | otherwise = - opts - where - bopts = - buildMonoidBenchmarkOpts opts - topts = - buildMonoidTestOpts opts - additionalArgs = - "+RTS" : catMaybes [trac, prof, Just "-RTS"] - trac = - if tracing - then Just "-xc" - else Nothing - prof = - if profiling - then Just "-p" - else Nothing - profile = - flag - False - True - (long "profile" <> - help - "Enable profiling in libraries, executables, etc. \ - \for all expressions and generate a profiling report\ - \ in tests or benchmarks" <> - hideExceptGhci) - trace = + -- These use 'Any' because they are not settable in stack.yaml, so + -- there is no need for options like --no-profile. + trace = Any <$> flag False True (long "trace" <> help "Enable profiling in libraries, executables, etc. \ - \for all expressions and generate a backtrace on \ - \exception" <> - hideExceptGhci) - - noStrip = + \for all expressions and generate a backtrace on \ + \exception" <> + hideExceptGhci) + profile = Any <$> flag False True - (long "no-strip" <> + (long "profile" <> help - "Disable DWARF debugging symbol stripping in libraries, \ - \executables, etc. for all expressions, producing \ - \larger executables but allowing the use of standard \ - \debuggers/profiling tools/other utilities that use \ - \debugging symbols." <> + "profiling in libraries, executables, etc. \ + \for all expressions and generate a profiling report\ + \ in tests or benchmarks" <> hideExceptGhci) - - options = - BuildOptsMonoid <$> libProfiling <*> exeProfiling <*> libStripping <*> - exeStripping <*> haddock <*> haddockOptsParser hideBool <*> - openHaddocks <*> haddockDeps <*> haddockInternal <*> copyBins <*> - preFetch <*> keepGoing <*> forceDirty <*> tests <*> - testOptsParser hideBool <*> benches <*> benchOptsParser hideBool <*> - reconfigure <*> cabalVerbose <*> splitObjs + noStrip = Any <$> + flag + False + True + (long "no-strip" <> + help + "Disable DWARF debugging symbol stripping in libraries, \ + \executables, etc. for all expressions, producing \ + \larger executables but allowing the use of standard \ + \debuggers/profiling tools/other utilities that use \ + \debugging symbols." <> + hideExceptGhci) libProfiling = firstBoolFlags @@ -138,6 +97,11 @@ firstBoolFlags "haddock-internal" "building Haddocks for internal modules (like cabal haddock --internal)" + hide + haddockHyperlinkSource = + firstBoolFlags + "haddock-hyperlink-source" + "building hyperlinked source for Haddock (like haddock --hyperlinked-source)" hide copyBins = firstBoolFlags diff --git a/src/Stack/Options/BuildParser.hs b/src/Stack/Options/BuildParser.hs --- a/src/Stack/Options/BuildParser.hs +++ b/src/Stack/Options/BuildParser.hs @@ -10,6 +10,7 @@ import Options.Applicative.Args import Options.Applicative.Builder.Extra import Paths_stack as Meta +import Stack.Options.Completion import Stack.Options.PackageParser (readFlag) import Stack.Types.Config import Stack.Types.FlagName @@ -39,7 +40,8 @@ many (textOption (long "ghc-options" <> - metavar "OPTION" <> + metavar "OPTIONS" <> + completer ghcOptsCompleter <> help "Additional options passed to GHC"))) <*> flagsParser <*> (flag' @@ -87,6 +89,7 @@ many (textArgument (metavar "TARGET" <> + completer targetCompleter <> help ("If none specified, use all local packages. " <> "See https://docs.haskellstack.org/en/v" <> showVersion Meta.version <> @@ -99,6 +102,7 @@ (option readFlag (long "flag" <> + completer flagCompleter <> metavar "PACKAGE:[-]FLAG" <> help ("Override flags set in stack.yaml " <> diff --git a/src/Stack/Options/Completion.hs b/src/Stack/Options/Completion.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Options/Completion.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Stack.Options.Completion + ( ghcOptsCompleter + , targetCompleter + , flagCompleter + , projectExeCompleter + ) where + +import Control.Monad.Logger (LogLevel (LevelOther)) +import Data.Char (isSpace) +import Data.List (isPrefixOf) +import Data.List.Extra (nubOrd) +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Distribution.PackageDescription as C +import Options.Applicative +import Options.Applicative.Builder.Extra +import Stack.Build.Target (LocalPackageView(..)) +import Stack.Build.Source (getLocalPackageViews) +import Stack.Options.GlobalParser (globalOptsFromMonoid) +import Stack.Runners (loadConfigWithOpts) +import Stack.Setup +import Stack.Types.Config +import Stack.Types.FlagName +import Stack.Types.Package +import Stack.Types.PackageName +import Stack.Types.StackT +import System.Process (readProcess) +import Language.Haskell.TH.Syntax (runIO, lift) + +ghcOptsCompleter :: Completer +ghcOptsCompleter = mkCompleter $ \inputRaw -> return $ + let input = unescapeBashArg inputRaw + (curArgReversed, otherArgsReversed) = break isSpace (reverse input) + curArg = reverse curArgReversed + otherArgs = reverse otherArgsReversed + in if null curArg then [] else + map (otherArgs ++) $ + filter (curArg `isPrefixOf`) + -- Technically, we should be consulting the user's current ghc, + -- but that would require loading up a BuildConfig. + $(runIO (readProcess "ghc" ["--show-options"] "") >>= lift . lines) + +-- TODO: Ideally this would pay attention to --stack-yaml, may require +-- changes to optparse-applicative. + +buildConfigCompleter + :: (String -> StackT EnvConfig IO [String]) + -> Completer +buildConfigCompleter inner = mkCompleter $ \inputRaw -> do + let input = unescapeBashArg inputRaw + case input of + -- If it looks like a flag, skip this more costly completion. + ('-': _) -> return [] + _ -> do + let go = (globalOptsFromMonoid False mempty) + { globalLogLevel = LevelOther "silent" } + lc <- loadConfigWithOpts go + bconfig <- runStackTGlobal () go $ + lcLoadBuildConfig lc (globalCompiler go) + envConfig <- + runStackTGlobal bconfig go (setupEnv Nothing) + runStackTGlobal envConfig go (inner input) + +targetCompleter :: Completer +targetCompleter = buildConfigCompleter $ \input -> do + lpvs <- getLocalPackageViews + return $ + filter (input `isPrefixOf`) $ + concatMap allComponentNames (Map.toList lpvs) + where + allComponentNames (name, (lpv, _)) = + map (T.unpack . renderPkgComponent . (name,)) (Set.toList (lpvComponents lpv)) + +flagCompleter :: Completer +flagCompleter = buildConfigCompleter $ \input -> do + lpvs <- getLocalPackageViews + bconfig <- view buildConfigL + let wildcardFlags + = nubOrd + $ concatMap (\(name, (_, gpd)) -> + map (\fl -> "*:" ++ flagString name fl) (C.genPackageFlags gpd)) + $ Map.toList lpvs + normalFlags + = concatMap (\(name, (_, gpd)) -> + map (\fl -> packageNameString name ++ ":" ++ flagString name fl) + (C.genPackageFlags gpd)) + $ Map.toList lpvs + flagString name fl = + case C.flagName fl of + C.FlagName flname -> (if flagEnabled name fl then "-" else "") ++ flname + flagEnabled name fl = + fromMaybe (C.flagDefault fl) $ + Map.lookup (fromCabalFlagName (C.flagName fl)) $ + Map.findWithDefault Map.empty name (unPackageFlags (bcFlags bconfig)) + return $ filter (input `isPrefixOf`) $ + case input of + ('*' : ':' : _) -> wildcardFlags + ('*' : _) -> wildcardFlags + _ -> normalFlags + +projectExeCompleter :: Completer +projectExeCompleter = buildConfigCompleter $ \input -> do + lpvs <- getLocalPackageViews + return $ + filter (input `isPrefixOf`) $ + nubOrd $ + concatMap (\(_, (_, gpd)) -> map fst (C.condExecutables gpd)) $ + Map.toList lpvs diff --git a/src/Stack/Options/ConfigParser.hs b/src/Stack/Options/ConfigParser.hs --- a/src/Stack/Options/ConfigParser.hs +++ b/src/Stack/Options/ConfigParser.hs @@ -15,10 +15,11 @@ import Stack.Options.NixParser import Stack.Options.Utils import Stack.Types.Config +import qualified System.FilePath as FilePath -- | Command-line arguments parser for configuration. -configOptsParser :: GlobalOptsContext -> Parser ConfigMonoid -configOptsParser hide0 = +configOptsParser :: FilePath -> GlobalOptsContext -> Parser ConfigMonoid +configOptsParser currentDir hide0 = (\stackRoot workDir buildOpts dockerOpts nixOpts systemGHC installGHC arch ghcVariant ghcBuild jobs includes libs overrideGccPath skipGHCCheck skipMsys localBin modifyCodePage allowDifferentUser dumpLogs -> mempty { configMonoidStackRoot = stackRoot , configMonoidWorkDir = workDir @@ -51,7 +52,9 @@ <*> optionalFirst (option (eitherReader (mapLeft showWorkDirError . parseRelDir)) ( long "work-dir" <> metavar "WORK-DIR" - <> help "Override work directory (default: .stack-work)" + <> completer (pathCompleterWith (defaultPathCompleterOpts { pcoAbsolute = False, pcoFileFilter = const False })) + <> help ("Relative path of work directory " ++ + "(Overrides any STACK_WORK environment variable, default is '.stack-work')") <> hide )) <*> buildOptsMonoidParser hide0 @@ -80,15 +83,17 @@ <> help "Number of concurrent jobs to run" <> hide )) - <*> fmap Set.fromList (many (absDirOption + <*> fmap Set.fromList (many ((currentDir FilePath.) <$> strOption ( long "extra-include-dirs" <> metavar "DIR" + <> completer dirCompleter <> help "Extra directories to check for C header files" <> hide ))) - <*> fmap Set.fromList (many (absDirOption + <*> fmap Set.fromList (many ((currentDir FilePath.) <$> strOption ( long "extra-lib-dirs" <> metavar "DIR" + <> completer dirCompleter <> help "Extra directories to check for libraries" <> hide ))) @@ -109,6 +114,7 @@ <*> optionalFirst (strOption ( long "local-bin-path" <> metavar "DIR" + <> completer dirCompleter <> help "Install binaries to DIR" <> hide )) diff --git a/src/Stack/Options/DockerParser.hs b/src/Stack/Options/DockerParser.hs --- a/src/Stack/Options/DockerParser.hs +++ b/src/Stack/Options/DockerParser.hs @@ -65,6 +65,7 @@ <*> many (option auto (long (dockerOptName dockerMountArgName) <> hide <> metavar "(PATH | HOST-PATH:CONTAINER-PATH)" <> + completer dirCompleter <> help ("Mount volumes from host in container " ++ "(may specify multiple times)"))) <*> many (option str (long (dockerOptName dockerEnvArgName) <> @@ -78,13 +79,15 @@ metavar "PATH" <> help "Location of image usage tracking database")) <*> optionalFirst (option (eitherReader' parseDockerStackExe) - (long(dockerOptName dockerStackExeArgName) <> + (let specialOpts = + [ dockerStackExeDownloadVal + , dockerStackExeHostVal + , dockerStackExeImageVal + ] in + long(dockerOptName dockerStackExeArgName) <> hide <> - metavar (intercalate "|" - [ dockerStackExeDownloadVal - , dockerStackExeHostVal - , dockerStackExeImageVal - , "PATH" ]) <> + metavar (intercalate "|" (specialOpts ++ ["PATH"])) <> + completer (listCompleter specialOpts <> fileCompleter) <> help (concat [ "Location of " , stackProgName , " executable used in container" ]))) diff --git a/src/Stack/Options/ExecParser.hs b/src/Stack/Options/ExecParser.hs --- a/src/Stack/Options/ExecParser.hs +++ b/src/Stack/Options/ExecParser.hs @@ -4,6 +4,7 @@ import Options.Applicative import Options.Applicative.Builder.Extra import Options.Applicative.Args +import Stack.Options.Completion import Stack.Types.Config -- | Parser for exec command @@ -14,7 +15,7 @@ <*> eoArgsParser <*> execOptsExtraParser where - eoCmdParser = ExecCmd <$> strArgument (metavar "CMD") + eoCmdParser = ExecCmd <$> strArgument (metavar "CMD" <> completer projectExeCompleter) eoArgsParser = many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)")) evalOptsParser :: String -- ^ metavar @@ -52,7 +53,7 @@ eoPackagesParser = many (strOption (long "package" <> help "Additional packages that must be installed")) eoRtsOptionsParser :: Parser [String] - eoRtsOptionsParser = concat <$> many (argsOption + eoRtsOptionsParser = concat <$> many (argsOption ( long "rts-options" <> help "Explicit RTS options to pass to application" <> metavar "RTSFLAG")) @@ -61,4 +62,3 @@ eoPlainParser = flag' ExecOptsPlain (long "plain" <> help "Use an unmodified environment (only useful with Docker)") - diff --git a/src/Stack/Options/GhcBuildParser.hs b/src/Stack/Options/GhcBuildParser.hs --- a/src/Stack/Options/GhcBuildParser.hs +++ b/src/Stack/Options/GhcBuildParser.hs @@ -12,6 +12,7 @@ option readGHCBuild (long "ghc-build" <> metavar "BUILD" <> + completeWith ["standard", "gmp4", "nopie", "tinfo6", "tinfo6-nopie", "ncurses6", "integersimple"] <> help "Specialized GHC build, e.g. 'gmp4' or 'standard' (usually auto-detected)" <> hideMods hide diff --git a/src/Stack/Options/GhciParser.hs b/src/Stack/Options/GhciParser.hs --- a/src/Stack/Options/GhciParser.hs +++ b/src/Stack/Options/GhciParser.hs @@ -9,6 +9,7 @@ import Stack.Config (packagesParser) import Stack.Ghci (GhciOpts (..)) import Stack.Options.BuildParser (flagsParser) +import Stack.Options.Completion -- | Parser for GHCI options ghciOptsParser :: Parser GhciOpts @@ -16,18 +17,21 @@ <$> many (textArgument (metavar "TARGET/FILE" <> + completer (targetCompleter <> fileExtCompleter [".hs", ".lhs"]) <> help ("If none specified, use all local packages. " <> "See https://docs.haskellstack.org/en/v" <> showVersion Meta.version <> "/build_command/#target-syntax for details. " <> "If a path to a .hs or .lhs file is specified, it will be loaded."))) <*> fmap concat (many (argsOption (long "ghci-options" <> - metavar "OPTION" <> + metavar "OPTIONS" <> + completer ghcOptsCompleter <> help "Additional options passed to GHCi"))) <*> many (textOption (long "ghc-options" <> - metavar "OPTION" <> + metavar "OPTIONS" <> + completer ghcOptsCompleter <> help "Additional options passed to both GHC and GHCi")) <*> flagsParser <*> optional @@ -40,6 +44,7 @@ (textOption (long "main-is" <> metavar "TARGET" <> + completer targetCompleter <> help "Specify which target should contain the main \ \module to load, such as for an executable for \ \test suite or benchmark.")) diff --git a/src/Stack/Options/GlobalParser.hs b/src/Stack/Options/GlobalParser.hs --- a/src/Stack/Options/GlobalParser.hs +++ b/src/Stack/Options/GlobalParser.hs @@ -16,8 +16,8 @@ import Stack.Types.Docker -- | Parser for global command-line options. -globalOptsParser :: GlobalOptsContext -> Maybe LogLevel -> Parser GlobalOptsMonoid -globalOptsParser kind defLogLevel = +globalOptsParser :: FilePath -> GlobalOptsContext -> Maybe LogLevel -> Parser GlobalOptsMonoid +globalOptsParser currentDir kind defLogLevel = GlobalOptsMonoid <$> optionalFirst (strOption (long Docker.reExecArgName <> hidden <> internal)) <*> optionalFirst (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*> @@ -26,7 +26,7 @@ "time-in-log" "inclusion of timings in logs, for the purposes of using diff with logs" hide <*> - configOptsParser kind <*> + configOptsParser currentDir kind <*> optionalFirst (abstractResolverOptsParser hide0) <*> optionalFirst (compilerOptsParser hide0) <*> firstBoolFlags @@ -36,12 +36,14 @@ optionalFirst (option readColorWhen (long "color" <> metavar "WHEN" <> + completeWith ["always", "never", "auto"] <> help "Specify when to use color in output; WHEN is 'always', 'never', or 'auto'" <> hide)) <*> optionalFirst (strOption (long "stack-yaml" <> metavar "STACK-YAML" <> + completer (fileExtCompleter [".yaml"]) <> help ("Override project stack.yaml file " <> "(overrides any STACK_YAML environment variable)") <> hide)) @@ -71,7 +73,8 @@ where searchDirs = many (textArgument - (metavar "DIRS" <> + (metavar "DIR" <> + completer dirCompleter <> help "Directories to include, default is current directory.")) ignoreSubDirs = switch (long "ignore-subdirs" <> help "Do not search for .cabal files in sub directories") diff --git a/src/Stack/Options/HpcReportParser.hs b/src/Stack/Options/HpcReportParser.hs --- a/src/Stack/Options/HpcReportParser.hs +++ b/src/Stack/Options/HpcReportParser.hs @@ -6,21 +6,28 @@ import Options.Applicative.Builder.Extra import Options.Applicative.Types (readerAsk) import Stack.Coverage (HpcReportOpts (..)) +import Stack.Options.Completion (targetCompleter) import Stack.Types.Config -- | Parser for @stack hpc report@. hpcReportOptsParser :: Parser HpcReportOpts hpcReportOptsParser = HpcReportOpts - <$> many (textArgument $ metavar "TARGET_OR_TIX") + <$> many (textArgument $ metavar "TARGET_OR_TIX" <> + completer (targetCompleter <> fileExtCompleter [".tix"])) <*> switch (long "all" <> help "Use results from all packages and components involved in previous --coverage run") - <*> optional (strOption (long "destdir" <> help "Output directory for HTML report")) + <*> optional (strOption (long "destdir" <> + metavar "DIR" <> + completer dirCompleter <> + help "Output directory for HTML report")) <*> switch (long "open" <> help "Open the report in the browser") pvpBoundsOption :: Parser PvpBounds pvpBoundsOption = option readPvpBounds - (long "pvp-bounds" <> metavar "PVP-BOUNDS" <> + (long "pvp-bounds" <> + metavar "PVP-BOUNDS" <> + completeWith ["none", "lower", "upper", "both"] <> help "How PVP version bounds should be added to .cabal file: none, lower, upper, both") where diff --git a/src/Stack/Options/LogLevelParser.hs b/src/Stack/Options/LogLevelParser.hs --- a/src/Stack/Options/LogLevelParser.hs +++ b/src/Stack/Options/LogLevelParser.hs @@ -14,6 +14,7 @@ fmap (Just . parse) (strOption (long "verbosity" <> metavar "VERBOSITY" <> + completeWith ["silent", "error", "warn", "info", "debug"] <> help "Verbosity: silent, error, warn, info, debug" <> hideMods hide)) <|> flag' (Just verboseLevel) diff --git a/src/Stack/Options/NixParser.hs b/src/Stack/Options/NixParser.hs --- a/src/Stack/Options/NixParser.hs +++ b/src/Stack/Options/NixParser.hs @@ -29,7 +29,8 @@ (option str (long "nix-shell-file" <> - metavar "FILEPATH" <> + metavar "FILE" <> + completer (fileExtCompleter [".nix"]) <> help "Nix file to be used to launch a nix-shell (for regular Nix users)" <> hide)) <*> optionalFirst diff --git a/src/Stack/Options/SDistParser.hs b/src/Stack/Options/SDistParser.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Options/SDistParser.hs @@ -0,0 +1,29 @@ +module Stack.Options.SDistParser where + +import Data.Monoid +import Options.Applicative +import Options.Applicative.Builder.Extra +import Stack.SDist +import Stack.Options.HpcReportParser (pvpBoundsOption) + +-- | Parser for arguments to `stack sdist` and `stack upload` +sdistOptsParser :: Bool -- ^ Whether to sign by default `stack upload` does, `stack sdist` doesn't + -> Parser SDistOpts +sdistOptsParser signDefault = SDistOpts <$> + many (strArgument $ metavar "DIR" <> completer dirCompleter) <*> + optional pvpBoundsOption <*> + ignoreCheckSwitch <*> + (if signDefault + then switch (long "no-signature" <> help "Do not sign & upload signatures") + else switch (long "sign" <> help "Sign & upload signatures")) <*> + strOption + (long "sig-server" <> metavar "URL" <> showDefault <> + value "https://sig.commercialhaskell.org" <> + help "URL") <*> + buildPackageOption + where + ignoreCheckSwitch = + switch (long "ignore-check" + <> help "Do not check package for common mistakes") + buildPackageOption = + boolFlags False "test-tarball" "building of the resulting tarball" idm diff --git a/src/Stack/Options/ScriptParser.hs b/src/Stack/Options/ScriptParser.hs --- a/src/Stack/Options/ScriptParser.hs +++ b/src/Stack/Options/ScriptParser.hs @@ -2,6 +2,7 @@ import Data.Monoid ((<>)) import Options.Applicative +import Options.Applicative.Builder.Extra data ScriptOpts = ScriptOpts { soPackages :: ![String] @@ -20,7 +21,7 @@ scriptOptsParser :: Parser ScriptOpts scriptOptsParser = ScriptOpts <$> many (strOption (long "package" <> help "Additional packages that must be installed")) - <*> strArgument (metavar "FILENAME") + <*> strArgument (metavar "FILE" <> completer (fileExtCompleter [".hs", ".lhs"])) <*> many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)")) <*> (flag' SECompile ( long "compile" diff --git a/src/Stack/Options/TestParser.hs b/src/Stack/Options/TestParser.hs --- a/src/Stack/Options/TestParser.hs +++ b/src/Stack/Options/TestParser.hs @@ -22,6 +22,7 @@ (optional (argsOption (long "test-arguments" <> + long "ta" <> metavar "TEST_ARGS" <> help "Arguments passed in to the test suite program" <> hide))) diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -196,21 +196,23 @@ when (expected /= toFilePath (filename cabalfp)) $ throwM $ MismatchedCabalName cabalfp name --- | Resolve a parsed cabal file into a 'Package'. +-- | Resolve a parsed cabal file into a 'Package', which contains all of +-- the info needed for stack to build the 'Package' given the current +-- configuration. resolvePackage :: PackageConfig -> GenericPackageDescription -> Package resolvePackage packageConfig gpkg = packageFromPackageDescription packageConfig - gpkg + (genPackageFlags gpkg) (resolvePackageDescription packageConfig gpkg) packageFromPackageDescription :: PackageConfig - -> GenericPackageDescription + -> [D.Flag] -> PackageDescription -> Package -packageFromPackageDescription packageConfig gpkg pkg = +packageFromPackageDescription packageConfig pkgFlags pkg = Package { packageName = name , packageVersion = fromCabalVersion (pkgVersion pkgId) @@ -221,7 +223,7 @@ , packageGhcOptions = packageConfigGhcOptions packageConfig , packageFlags = packageConfigFlags packageConfig , packageDefaultFlags = M.fromList - [(fromCabalFlagName (flagName flag), flagDefault flag) | flag <- genPackageFlags gpkg] + [(fromCabalFlagName (flagName flag), flagDefault flag) | flag <- pkgFlags] , packageAllDeps = S.fromList (M.keys deps) , packageHasLibrary = maybe False (buildable . libBuildInfo) (library pkg) , packageTests = M.fromList @@ -233,6 +235,8 @@ , packageExes = S.fromList [T.pack (exeName biBuildInfo) | biBuildInfo <- executables pkg , buildable (buildInfo biBuildInfo)] + -- This is an action used to collect info needed for "stack ghci". + -- This info isn't usually needed, so computation of it is deferred. , packageOpts = GetPackageOpts $ \sourceMap installedMap omitPkgs addPkgs cabalfp -> do (componentsModules,componentFiles,_,_) <- getPackageFiles pkgFiles cabalfp @@ -243,10 +247,13 @@ False (not . null . exposedModules) (library pkg) - , packageSimpleType = buildType pkg == Just Simple + , packageBuildType = buildType pkg , packageSetupDeps = msetupDeps } where + -- Gets all of the modules, files, build files, and data files that + -- constitute the package. This is primarily used for dirtiness + -- checking during build, as well as use by "stack ghci" pkgFiles = GetPackageFiles $ \cabalfp -> $debugBracket ("getPackageFiles" <+> display cabalfp) $ do let pkgDir = parent cabalfp @@ -351,6 +358,7 @@ where cabalDir = parent cabalfp +-- | Input to 'generateBuildInfoOpts' data BioInput = BioInput { biSourceMap :: !SourceMap , biInstalledMap :: !InstalledMap @@ -361,12 +369,14 @@ , biAddPackages :: ![PackageName] , biBuildInfo :: !BuildInfo , biDotCabalPaths :: !(Set DotCabalPath) - , biConfigLibDirs :: !(Set (Path Abs Dir)) - , biConfigIncludeDirs :: !(Set (Path Abs Dir)) + , biConfigLibDirs :: !(Set FilePath) + , biConfigIncludeDirs :: !(Set FilePath) , biComponentName :: !NamedComponent } --- | Generate GHC options for the target. +-- | Generate GHC options for the target. Since Cabal also figures out +-- these options, currently this is only used for invoking GHCI (via +-- stack ghci). generateBuildInfoOpts :: BioInput -> BuildInfoOpts generateBuildInfoOpts BioInput {..} = BuildInfoOpts @@ -423,8 +433,7 @@ toIncludeDir relDir = concatAndColapseAbsDir biCabalDir relDir includeOpts = map ("-I" <>) (configExtraIncludeDirs <> pkgIncludeOpts) - configExtraIncludeDirs = - map toFilePathNoTrailingSep (S.toList biConfigIncludeDirs) + configExtraIncludeDirs = S.toList biConfigIncludeDirs pkgIncludeOpts = [ toFilePathNoTrailingSep absDir | dir <- includeDirs biBuildInfo @@ -433,8 +442,7 @@ libOpts = map ("-l" <>) (extraLibs biBuildInfo) <> map ("-L" <>) (configExtraLibDirs <> pkgLibDirs) - configExtraLibDirs = - map toFilePathNoTrailingSep (S.toList biConfigLibDirs) + configExtraLibDirs = S.toList biConfigLibDirs pkgLibDirs = [ toFilePathNoTrailingSep absDir | dir <- extraLibDirs biBuildInfo @@ -771,8 +779,8 @@ targetJsSources :: BuildInfo -> [FilePath] targetJsSources = jsSources --- | Get all dependencies of a package, including library, --- executables, tests, benchmarks. +-- | Evaluates the conditions of a 'GenericPackageDescription', yielding +-- a resolved 'PackageDescription'. resolvePackageDescription :: PackageConfig -> GenericPackageDescription -> PackageDescription @@ -1182,7 +1190,11 @@ when exists $ do let fpt = T.pack (toFilePath hpackFile) $logDebug $ "Running hpack on " <> fpt +#if MIN_VERSION_hpack(0,18,0) + r <- liftIO $ Hpack.hpackResult (Just $ toFilePath pkgDir) +#else r <- liftIO $ Hpack.hpackResult (toFilePath pkgDir) +#endif forM_ (Hpack.resultWarnings r) $ \w -> $logWarn ("WARNING: " <> T.pack w) let cabalFile = T.pack (Hpack.resultCabalFile r) case Hpack.resultStatus r of diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -49,7 +49,9 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Typeable (Typeable) +import qualified Distribution.License as C import qualified Distribution.System as OS +import qualified Distribution.Text as C import Path import Path.Extra (toFilePathNoTrailingSep) import Prelude -- Fix AMP warning @@ -292,6 +294,7 @@ data DumpPackage profiling haddock symbols = DumpPackage { dpGhcPkgId :: !GhcPkgId , dpPackageIdent :: !PackageIdentifier + , dpLicense :: !(Maybe C.License) , dpLibDirs :: ![FilePath] , dpLibraries :: ![Text] , dpHasExposedModules :: !Bool @@ -303,7 +306,7 @@ , dpSymbols :: !symbols , dpIsExposed :: !Bool } - deriving (Show, Eq, Ord) + deriving (Show, Eq) data PackageDumpException = MissingSingleField Text (Map Text [Line]) @@ -358,6 +361,10 @@ libraries = parseM "hs-libraries" exposedModules = parseM "exposed-modules" exposed = parseM "exposed" + license = + case parseM "license" of + [licenseText] -> C.simpleParse (T.unpack licenseText) + _ -> Nothing depends <- mapMaybeM parseDepend $ concatMap T.words $ parseM "depends" let parseQuoted key = @@ -373,6 +380,7 @@ return $ Just DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = PackageIdentifier name version + , dpLicense = license , dpLibDirs = libDirPaths , dpLibraries = T.words $ T.unwords libraries , dpHasExposedModules = not (null libraries || null exposedModules) diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -34,7 +34,7 @@ import Control.Monad.Catch (throwM) import qualified Control.Monad.Catch as C import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Logger (logDebug, logInfo, logWarn, logError) +import Control.Monad.Logger (logDebug, logInfo, logWarn) import Control.Monad.Trans.Control import Crypto.Hash as Hash (hashlazy, Digest, SHA1) import Data.Aeson.Extended @@ -56,7 +56,6 @@ import qualified Data.Set as Set import Data.Store.Version import Data.Store.VersionTagged -import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Unsafe (unsafeTail) @@ -72,7 +71,7 @@ import Network.HTTP.Client.TLS (getGlobalManager) import Network.HTTP.Download import Network.URI (parseURI) -import Path (mkRelDir, mkRelFile, parent, parseRelDir, toFilePath, parseAbsFile, ()) +import Path (toFilePath, parseAbsFile) import Path.IO import Prelude -- Fix AMP warning import Stack.Types.BuildPlan (GitSHA1 (..)) @@ -81,22 +80,19 @@ import Stack.Types.PackageIndex import Stack.Types.PackageName import Stack.Types.StackT +import Stack.Types.StringError import Stack.Types.Version import qualified System.Directory as D -import System.FilePath (takeBaseName, (<.>)) +import System.FilePath ((<.>)) import System.IO (IOMode (ReadMode, WriteMode), withBinaryFile) -import System.Process.Read (EnvOverride, ReadProcessException(..), doesExecutableExist, readProcessNull, tryProcessStdout) -import System.Process.Run (Cmd(..), callProcessInheritStderrStdout) -import System.Exit (exitFailure) -- | Populate the package index caches and return them. populateCache :: (StackMiniM env m, HasConfig env) - => EnvOverride - -> PackageIndex + => PackageIndex -> m PackageCacheMap -populateCache menv index = do - requireIndex menv index +populateCache index = do + requireIndex index -- This uses full on lazy I/O instead of ResourceT to provide some -- protections. Caveat emptor path <- configPackageIndex (indexName index) @@ -108,7 +104,7 @@ $logWarn $ "Exception encountered when parsing index tarball: " <> T.pack (show (e :: Tar.FormatError)) $logWarn "Automatically updating index and trying again" - updateIndex menv index + updateIndex index loadPIS when (indexRequireHashes index) $ forM_ (Map.toList pis) $ \(ident, pc) -> @@ -231,39 +227,31 @@ ] -- | Require that an index be present, updating if it isn't. -requireIndex :: (StackMiniM env m, HasConfig env) - => EnvOverride -> PackageIndex -> m () -requireIndex menv index = do +requireIndex :: (StackMiniM env m, HasConfig env) => PackageIndex -> m () +requireIndex index = do tarFile <- configPackageIndex $ indexName index exists <- doesFileExist tarFile - unless exists $ updateIndex menv index + unless exists $ updateIndex index -- | Update all of the package indices -updateAllIndices :: (StackMiniM env m, HasConfig env) - => EnvOverride -> m () -updateAllIndices menv = do +updateAllIndices :: (StackMiniM env m, HasConfig env) => m () +updateAllIndices = do clearPackageCaches - view packageIndicesL >>= mapM_ (updateIndex menv) + view packageIndicesL >>= mapM_ updateIndex -- | Update the index tarball -updateIndex :: (StackMiniM env m, HasConfig env) - => EnvOverride -> PackageIndex -> m () -updateIndex menv index = +updateIndex :: (StackMiniM env m, HasConfig env) => PackageIndex -> m () +updateIndex index = do let name = indexName index - sloc = simplifyIndexLocation $ indexLocation index + url = indexLocation index $logSticky $ "Updating package index " <> indexNameText (indexName index) <> " (mirrored at " - <> (case sloc of - SILGit url -> url - SILHttp url _ -> url) + <> url <> ") ..." - git <- isGitInstalled menv - case (git, sloc) of - (True, SILGit url) -> updateIndexGit menv name index url - (False, SILGit _) -> throwM (GitNotAvailable name) - (_, SILHttp url HTVanilla) -> updateIndexHTTP name index url - (_, SILHttp url (HTHackageSecurity hs)) -> updateIndexHackageSecurity name index url hs + case indexType index of + ITVanilla -> updateIndexHTTP name url + ITHackageSecurity hs -> updateIndexHackageSecurity name url hs -- Copy to the 00-index.tar filename for backwards -- compatibility. First wipe out the cache file if present. @@ -273,108 +261,12 @@ ignoringAbsence (removeFile oldCacheFile) runConduitRes $ sourceFile (toFilePath tarFile) .| sinkFile (toFilePath oldTarFile) --- | Update the index Git repo and the index tarball -updateIndexGit :: (StackMiniM env m, HasConfig env) - => EnvOverride - -> IndexName - -> PackageIndex - -> Text -- ^ Git URL - -> m () -updateIndexGit menv indexName' index gitUrl = do - tarFile <- configPackageIndex indexName' - let idxPath = parent tarFile - ensureDir idxPath - do - repoName <- parseRelDir $ takeBaseName $ T.unpack gitUrl - let cloneArgs = - ["clone" - ,T.unpack gitUrl - ,toFilePath repoName - ,"-b" -- - ,"display"] - sDir <- configPackageIndexRoot indexName' - let suDir = - sDir - $(mkRelDir "git-update") - acfDir = suDir repoName - repoExists <- doesDirExist acfDir - let doClone = readProcessNull (Just suDir) menv "git" cloneArgs - unless repoExists doClone - isShallow <- doesFileExist $ acfDir $(mkRelDir ".git") $(mkRelFile "shallow") - when isShallow $ do - $logWarn "Shallow package index repo detected, transitioning to a full clone..." - let handleUnshallowError = - C.handle $ \case - ProcessFailed{} -> do - $logInfo $ "Failed to convert to full clone, deleting and re-cloning." - ignoringAbsence (removeDirRecur acfDir) - doClone - err -> throwM err - -- See https://github.com/commercialhaskell/stack/issues/2748 - -- for an explanation of --git-dir=.git - handleUnshallowError $ - readProcessNull (Just acfDir) menv "git" - ["--git-dir=.git", "fetch", "--unshallow"] - $logSticky "Fetching package index ..." - let runFetch = callProcessInheritStderrStdout - (Cmd (Just acfDir) "git" menv ["--git-dir=.git","fetch","--tags"]) - runFetch `C.catch` \(ex :: ProcessExitedUnsuccessfully) -> do - -- we failed, so wipe the directory and try again, see #1418 - $logWarn (T.pack (show ex)) - $logStickyDone "Failed to fetch package index, retrying." - removeDirRecur acfDir - readProcessNull (Just suDir) menv "git" cloneArgs - $logSticky "Fetching package index ..." - runFetch - $logStickyDone "Fetched package index." - - when (indexGpgVerify index) $ do - result <- C.try $ readProcessNull (Just acfDir) menv "git" ["--git-dir=.git","tag","-v","current-hackage"] - case result of - Left ex -> do - $logError (T.pack (show ex)) - case ex of - ProcessFailed{} -> $logError $ 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"] - _ -> return () - liftIO exitFailure - Right () -> return () - -- generate index archive when commit id differs from cloned repo - tarId <- getTarCommitId (toFilePath tarFile) - cloneId <- getCloneCommitId acfDir - unless (tarId `equals` cloneId) - (generateArchive acfDir tarFile) - where - getTarCommitId fp = - tryProcessStdout Nothing menv "sh" ["-c","git get-tar-commit-id < "++fp] - - getCloneCommitId dir = - tryProcessStdout (Just dir) menv "git" ["rev-parse","current-hackage^{}"] - - equals (Right cid1) (Right cid2) = cid1 == cid2 - equals _ _ = False - - generateArchive acfDir tarFile = do - ignoringAbsence (removeFile tarFile) - deleteCache indexName' - $logDebug ("Exporting a tarball to " <> (T.pack . toFilePath) tarFile) - let tarFileTmp = toFilePath tarFile ++ ".tmp" - readProcessNull (Just acfDir) menv - "git" ["--git-dir=.git","archive","--format=tar","-o",tarFileTmp,"current-hackage"] - tarFileTmpPath <- parseAbsFile tarFileTmp - renameFile tarFileTmpPath tarFile - -- | Update the index tarball via HTTP updateIndexHTTP :: (StackMiniM env m, HasConfig env) => IndexName - -> PackageIndex -> Text -- ^ url -> m () -updateIndexHTTP indexName' index url = do +updateIndexHTTP indexName' url = do req <- parseRequest $ T.unpack url $logInfo ("Downloading package index from " <> url) gz <- configPackageIndexGz indexName' @@ -399,23 +291,17 @@ =$ sinkHandle output renameFile tmpPath tar - when (indexGpgVerify index) - $ $logWarn - $ "You have enabled GPG verification of the package index, " <> - "but GPG verification only works with Git downloading" - -- | Update the index tarball via Hackage Security updateIndexHackageSecurity :: (StackMiniM env m, HasConfig env) => IndexName - -> PackageIndex -> Text -- ^ base URL -> HackageSecurity -> m () -updateIndexHackageSecurity indexName' index url (HackageSecurity keyIds threshold) = do +updateIndexHackageSecurity indexName' url (HackageSecurity keyIds threshold) = do baseURI <- case parseURI $ T.unpack url of - Nothing -> error $ "Invalid Hackage Security base URL: " ++ T.unpack url + Nothing -> errorString $ "Invalid Hackage Security base URL: " ++ T.unpack url Just x -> return x manager <- liftIO getGlobalManager root <- configPackageIndexRoot indexName' @@ -457,17 +343,6 @@ $logInfo "Updated package list downloaded" HS.NoUpdates -> $logInfo "No updates to your package list were found" - when (indexGpgVerify index) - $ $logWarn - $ "You have enabled GPG verification of the package index, " <> - "but GPG verification only works with Git downloading" - --- | Is the git executable installed? -isGitInstalled :: MonadIO m - => EnvOverride - -> m Bool -isGitInstalled = flip doesExecutableExist "git" - -- | Delete the package index cache deleteCache :: (StackMiniM env m, HasConfig env) @@ -533,7 +408,6 @@ , HashMap GitSHA1 (PackageIndex, OffsetSize) ) getPackageCaches = do - menv <- getMinimalEnvOverride config <- view configL mcached <- liftIO $ readIORef (configPackageCaches config) case mcached of @@ -545,7 +419,7 @@ $(versionedDecodeOrLoad (storeVersionConfig "pkg-v2" "WlAvAaRXlIMkjSmg5G3dD16UpT8=" :: VersionConfig PackageCacheMap)) fp - (populateCache menv index) + (populateCache index) return (fmap (index,) pis', fmap (index,) gitPIs) liftIO $ writeIORef (configPackageCaches config) (Just result) return result diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs --- a/src/Stack/Path.hs +++ b/src/Stack/Path.hs @@ -159,10 +159,10 @@ , view $ configL.to configLocalBin.to toFilePathNoTrailingSep.to T.pack) , ( "Extra include directories" , "extra-include-dirs" - , T.intercalate ", " . map (T.pack . toFilePathNoTrailingSep) . Set.elems . configExtraIncludeDirs . view configL ) + , T.intercalate ", " . map T.pack . Set.elems . configExtraIncludeDirs . view configL ) , ( "Extra library directories" , "extra-library-dirs" - , T.intercalate ", " . map (T.pack . toFilePathNoTrailingSep) . Set.elems . configExtraLibDirs . view configL ) + , T.intercalate ", " . map T.pack . Set.elems . configExtraLibDirs . view configL ) , ( "Snapshot package database" , "snapshot-pkg-db" , T.pack . toFilePathNoTrailingSep . piSnapDb ) diff --git a/src/Stack/PrettyPrint.hs b/src/Stack/PrettyPrint.hs --- a/src/Stack/PrettyPrint.hs +++ b/src/Stack/PrettyPrint.hs @@ -15,7 +15,7 @@ -- | These are preferred to colors directly, so that we can -- encourage consistency of color meanings. , errorRed, goodGreen, shellMagenta - , displayTargetPkgId, displayCurrentPkgId, displayErrorPkgId + , displayTargetPkgId, displayCurrentPkgId, displayCurrentPkgName, displayErrorPkgId , displayMilliseconds -- * Formatting utils , bulletedList @@ -112,6 +112,9 @@ displayCurrentPkgId :: PackageIdentifier -> AnsiDoc displayCurrentPkgId = yellow . display + +displayCurrentPkgName :: PackageName -> AnsiDoc +displayCurrentPkgName = yellow . display displayErrorPkgId :: PackageIdentifier -> AnsiDoc displayErrorPkgId = errorRed . display diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -9,6 +9,7 @@ , withConfigAndLock , withMiniConfigAndLock , withBuildConfigAndLock + , withBuildConfigAndLockNoDocker , withBuildConfig , withBuildConfigExt , loadConfigWithOpts @@ -130,10 +131,18 @@ -> (Maybe FileLock -> StackT EnvConfig IO ()) -> IO () withBuildConfigAndLock go inner = - withBuildConfigExt go Nothing inner Nothing + withBuildConfigExt False go Nothing inner Nothing -withBuildConfigExt +withBuildConfigAndLockNoDocker :: GlobalOpts + -> (Maybe FileLock -> StackT EnvConfig IO ()) + -> IO () +withBuildConfigAndLockNoDocker go inner = + withBuildConfigExt True go Nothing inner Nothing + +withBuildConfigExt + :: Bool + -> GlobalOpts -> Maybe (StackT Config IO ()) -- ^ Action to perform before the build. This will be run on the host -- OS even if Docker is enabled for builds. The build config is not @@ -148,7 +157,7 @@ -- available in this action, since that would require build tools to be -- installed on the host OS. -> IO () -withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do +withBuildConfigExt skipDocker go@GlobalOpts{..} mbefore inner mafter = do lc <- loadConfigWithOpts go withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk0 -> do @@ -179,16 +188,21 @@ (inner' lk) let getCompilerVersion = loadCompilerVersion go lc - runStackTGlobal (lcConfig lc) go $ - Docker.reexecWithOptionalContainer - (lcProjectRoot lc) - mbefore - (runStackTGlobal (lcConfig lc) go $ - Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion (inner'' lk0)) - mafter - (Just $ liftIO $ - do lk' <- readIORef curLk - munlockFile lk') + if skipDocker + then runStackTGlobal (lcConfig lc) go $ do + forM_ mbefore id + liftIO $ inner'' lk0 + forM_ mafter id + else runStackTGlobal (lcConfig lc) go $ + Docker.reexecWithOptionalContainer + (lcProjectRoot lc) + mbefore + (runStackTGlobal (lcConfig lc) go $ + Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion (inner'' lk0)) + mafter + (Just $ liftIO $ + do lk' <- readIORef curLk + munlockFile lk') -- | Load the configuration. Convenience function used -- throughout this module. diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -11,6 +11,7 @@ ( getSDistTarball , checkSDistTarball , checkSDistTarball' + , SDistOpts (..) ) where import qualified Codec.Archive.Tar as Tar @@ -18,21 +19,26 @@ import qualified Codec.Compression.GZip as GZip import Control.Applicative import Control.Concurrent.Execute (ActionContext(..)) -import Control.Monad (unless, void, liftM) +import Control.Monad (unless, void, liftM, filterM, foldM, when) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger +import Control.Monad.Reader.Class (local) import Control.Monad.Trans.Control (liftBaseWith) +import Control.Monad.Trans.Unlift (MonadBaseUnlift) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L +import Data.Char (toLower) import Data.Data (Data, Typeable, cast, gmapT) import Data.Either (partitionEithers) +import Data.IORef (newIORef, readIORef, writeIORef) import Data.List +import Data.List.Extra (nubOrd) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes) import Data.Monoid ((<>)) import qualified Data.Set as Set import qualified Data.Text as T @@ -41,18 +47,22 @@ import qualified Data.Text.Lazy.Encoding as TLE import Data.Time.Clock.POSIX import Distribution.Package (Dependency (..)) +import qualified Distribution.PackageDescription as Cabal import qualified Distribution.PackageDescription.Check as Check import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) +import Distribution.Text (display) import Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion) import Distribution.Version.Extra +import Lens.Micro (set) import Path import Path.IO hiding (getModificationTime, getPermissions) import Prelude -- Fix redundant import warnings -import Stack.Build (mkBaseConfigOpts) +import Stack.Build (mkBaseConfigOpts, build) import Stack.Build.Execute import Stack.Build.Installed import Stack.Build.Source (loadSourceMap, getDefaultPackageConfig) import Stack.Build.Target +import Stack.Config (resolvePackageEntry, removePathFromPackageEntry) import Stack.Constants import Stack.Package import Stack.Types.Build @@ -61,6 +71,7 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.StackT +import Stack.Types.StringError import Stack.Types.Version import System.Directory (getModificationTime, getPermissions) import qualified System.FilePath as FP @@ -68,6 +79,21 @@ -- | Special exception to throw when you want to fail because of bad results -- of package check. +data SDistOpts = SDistOpts + { sdoptsDirsToWorkWith :: [String] + -- ^ Directories to package + , sdoptsPvpBounds :: Maybe PvpBounds + -- ^ PVP Bounds overrides + , sdoptsIgnoreCheck :: Bool + -- ^ Whether to ignore check of the package for common errors + , sdoptsSign :: Bool + -- ^ Whether to sign the package + , sdoptsSignServerUrl :: String + -- ^ The URL of the signature server + , sdoptsBuildTarball :: Bool + -- ^ Whether to build the tarball + } + newtype CheckException = CheckException (NonEmpty Check.PackageCheck) deriving (Typeable) @@ -89,10 +115,11 @@ :: (StackM env m, HasEnvConfig env) => Maybe PvpBounds -- ^ Override Config value -> Path Abs Dir -- ^ Path to local package - -> m (FilePath, L.ByteString) -- ^ Filename and tarball contents + -> m (FilePath, L.ByteString, Maybe (PackageIdentifier, L.ByteString)) + -- ^ Filename, tarball contents, and option cabal file revision to upload getSDistTarball mpvpBounds pkgDir = do config <- view configL - let pvpBounds = fromMaybe (configPvpBounds config) mpvpBounds + let PvpBounds pvpBounds asRevision = fromMaybe (configPvpBounds config) mpvpBounds tweakCabal = pvpBounds /= PvpBoundsNone pkgFp = toFilePath pkgDir lp <- readLocalPackage pkgDir @@ -100,35 +127,56 @@ (fileList, cabalfp) <- getSDistFileList lp $logInfo $ "Building sdist tarball for " <> T.pack pkgFp files <- normalizeTarballPaths (lines fileList) + + -- We're going to loop below and eventually find the cabal + -- file. When we do, we'll upload this reference, if the + -- mpvpBounds value indicates that we should be uploading a cabal + -- file revision. + cabalFileRevisionRef <- liftIO (newIORef Nothing) + -- NOTE: Could make this use lazy I/O to only read files as needed -- for upload (both GZip.compress and Tar.write are lazy). -- However, it seems less error prone and more predictable to read -- everything in at once, so that's what we're doing for now: - let tarPath isDir fp = either error id + let tarPath isDir fp = either throwString return (Tar.toTarPath isDir (forceUtf8Enc (pkgId FP. fp))) -- convert a String of proper characters to a String of bytes -- in UTF8 encoding masquerading as characters. This is -- necessary for tricking the tar package into proper -- character encoding. forceUtf8Enc = S8.unpack . T.encodeUtf8 . T.pack - 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 + -- This is a cabal file, we're going to tweak it, but only + -- tweak it as a revision. + | tweakCabal && isCabalFp fp && asRevision = do + lbsIdent <- getCabalLbs pvpBounds (Just 1) $ toFilePath cabalfp + liftIO (writeIORef cabalFileRevisionRef (Just lbsIdent)) + packWith packFileEntry False fp + -- Same, except we'll include the cabal file in the + -- original tarball upload. | tweakCabal && isCabalFp fp = do - lbs <- getCabalLbs pvpBounds $ toFilePath cabalfp + (_ident, lbs) <- getCabalLbs pvpBounds Nothing $ toFilePath cabalfp currTime <- liftIO getPOSIXTime -- Seconds from UNIX epoch - return $ (Tar.fileEntry (tarPath False fp) lbs) { Tar.entryTime = floor currTime } + tp <- liftIO $ tarPath False fp + return $ (Tar.fileEntry tp lbs) { Tar.entryTime = floor currTime } | otherwise = packWith packFileEntry False fp isCabalFp fp = toFilePath pkgDir FP. fp == toFilePath cabalfp tarName = pkgId FP.<.> "tar.gz" pkgId = packageIdentifierString (packageIdentifier (lpPackage lp)) dirEntries <- mapM packDir (dirsFromFiles files) fileEntries <- mapM packFile files - return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries))) + mcabalFileRevision <- liftIO (readIORef cabalFileRevisionRef) + return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries)), mcabalFileRevision) -- | Get the PVP bounds-enabled version of the given cabal file -getCabalLbs :: (StackM env m, HasEnvConfig env) => PvpBounds -> FilePath -> m L.ByteString -getCabalLbs pvpBounds fp = do +getCabalLbs :: (StackM env m, HasEnvConfig env) + => PvpBoundsType + -> Maybe Int -- ^ optional revision + -> FilePath + -> m (PackageIdentifier, L.ByteString) +getCabalLbs pvpBounds mrev fp = do bs <- liftIO $ S.readFile fp (_warnings, gpd) <- readPackageUnresolvedBS Nothing bs (_, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI @@ -140,7 +188,24 @@ } sourceMap let gpd' = gtraverseT (addBounds sourceMap installedMap) gpd - return $ TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd' + gpd'' = + case mrev of + Nothing -> gpd' + Just rev -> gpd' + { Cabal.packageDescription + = (Cabal.packageDescription gpd') + { Cabal.customFieldsPD + = (("x-revision", show rev):) + $ filter (\(x, _) -> map toLower x /= "x-revision") + $ Cabal.customFieldsPD + $ Cabal.packageDescription gpd' + } + } + ident <- parsePackageIdentifierFromString $ display $ Cabal.package $ Cabal.packageDescription gpd'' + return + ( ident + , TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd'' + ) where addBounds :: SourceMap -> InstalledMap -> Dependency -> Dependency addBounds sourceMap installedMap dep@(Dependency cname range) = @@ -221,7 +286,7 @@ $ \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] + cabal KeepTHLoading ["sdist", "--list-sources", outFile] contents <- liftIO (readFile outFile) return (contents, cabalfp) where @@ -236,6 +301,7 @@ } , taskPresent = Map.empty , taskAllInOne = True + , taskCachePkgSrc = CacheSrcLocal (toFilePath (lpDir lp)) } normalizeTarballPaths :: (StackM env m) => [FilePath] -> m [FilePath] @@ -246,7 +312,7 @@ $logWarn $ T.concat [ "Warning: These files are outside of the package directory, and will be omitted from the tarball: " , T.pack (show outsideDir)] - return files + return (nubOrd files) where (outsideDir, files) = partitionEithers (map pathToEither fps) pathToEither fp = maybe (Left fp) Right (normalizePath fp) @@ -271,13 +337,21 @@ -- and will throw an exception in case of critical errors. -- -- Note that we temporarily decompress the archive to analyze it. -checkSDistTarball :: (StackM env m, HasEnvConfig env) - => Path Abs File -- ^ Absolute path to tarball +checkSDistTarball :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) + => SDistOpts -- ^ The configuration of what to check + -> Path Abs File -- ^ Absolute path to tarball -> m () -checkSDistTarball tarball = withTempTarGzContents tarball $ \pkgDir' -> do +checkSDistTarball opts tarball = withTempTarGzContents tarball $ \pkgDir' -> do pkgDir <- (pkgDir' ) `liftM` (parseRelDir . FP.takeBaseName . FP.takeBaseName . toFilePath $ tarball) -- ^ drop ".tar" ^ drop ".gz" + when (sdoptsBuildTarball opts) (buildExtractedTarball pkgDir) + unless (sdoptsIgnoreCheck opts) (checkPackageInExtractedTarball pkgDir) + +checkPackageInExtractedTarball :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) + => Path Abs Dir -- ^ Absolute path to tarball + -> m () +checkPackageInExtractedTarball pkgDir = do cabalfp <- findOrGenerateCabalFile pkgDir name <- parsePackageNameFromFilePath cabalfp config <- getDefaultPackageConfig @@ -299,16 +373,56 @@ Nothing -> return () Just ne -> throwM $ CheckException ne +buildExtractedTarball :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) => Path Abs Dir -> m () +buildExtractedTarball pkgDir = do + projectRoot <- view projectRootL + envConfig <- view envConfigL + menv <- getMinimalEnvOverride + localPackageToBuild <- readLocalPackage pkgDir + let packageEntries = bcPackageEntries (envConfigBuildConfig envConfig) + getPaths entry = do + resolvedEntry <- resolvePackageEntry menv projectRoot entry + return $ fmap fst resolvedEntry + allPackagePaths <- fmap mconcat (mapM getPaths packageEntries) + -- We remove the path based on the name of the package + let isPathToRemove path = do + localPackage <- readLocalPackage path + return $ packageName (lpPackage localPackage) == packageName (lpPackage localPackageToBuild) + pathsToRemove <- filterM isPathToRemove allPackagePaths + let adjustPackageEntries entries path = do + adjustedPackageEntries <- mapM (removePathFromPackageEntry menv projectRoot path) entries + return (catMaybes adjustedPackageEntries) + entriesWithoutBuiltPackage <- foldM adjustPackageEntries packageEntries pathsToRemove + let newEntry = PackageEntry Nothing (PLFilePath (toFilePath pkgDir)) [] + newPackagesRef <- liftIO (newIORef Nothing) + let adjustEnvForBuild env = + let updatedEnvConfig = envConfig + {envConfigPackagesRef = newPackagesRef + ,envConfigBuildConfig = updatePackageInBuildConfig (envConfigBuildConfig envConfig) + } + in set envConfigL updatedEnvConfig env + updatePackageInBuildConfig buildConfig = buildConfig + { bcPackageEntries = newEntry : entriesWithoutBuiltPackage + , bcConfig = (bcConfig buildConfig) + { configBuild = defaultBuildOpts + { boptsTests = True + } + } + } + local adjustEnvForBuild $ + build (const (return ())) Nothing defaultBuildOptsCLI + -- | Version of 'checkSDistTarball' that first saves lazy bytestring to -- temporary directory and then calls 'checkSDistTarball' on it. -checkSDistTarball' :: (StackM env m, HasEnvConfig env) - => String -- ^ Tarball name +checkSDistTarball' :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) + => SDistOpts + -> String -- ^ Tarball name -> L.ByteString -- ^ Tarball contents as a byte string -> m () -checkSDistTarball' name bytes = withSystemTempDir "stack" $ \tpath -> do +checkSDistTarball' opts name bytes = withSystemTempDir "stack" $ \tpath -> do npath <- (tpath ) `liftM` parseRelFile name liftIO $ L.writeFile (toFilePath npath) bytes - checkSDistTarball npath + checkSDistTarball opts npath withTempTarGzContents :: (MonadIO m, MonadMask m) => Path Abs File -- ^ Location of tarball diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -37,6 +37,7 @@ import Stack.Types.PackageName import Stack.Types.Resolver import Stack.Types.StackT +import Stack.Types.StringError import System.FilePath (dropExtension, replaceExtension) import System.Process.Read @@ -67,8 +68,8 @@ (targetsSet, coresSet) <- case soPackages opts of - [] -> do - $logError "No packages provided, using experimental import parser" + [] -> + -- Using the import parser getPackagesFromImports (globalResolver go) (soFile opts) packages -> do let targets = concatMap wordsComma packages @@ -164,7 +165,7 @@ case Set.toList pns of [] -> assert False $ return Set.empty [pn] -> return $ Set.singleton pn - pns' -> error $ concat + pns' -> throwString $ concat [ "Module " , S8.unpack $ unModuleName mn , " appears in multiple packages: " @@ -265,8 +266,15 @@ parseImports :: ByteString -> (Set PackageName, Set ModuleName) parseImports = - fold . mapMaybe parseLine . S8.lines + fold . mapMaybe (parseLine . stripCR) . S8.lines where + -- Remove any carriage return character present at the end, to + -- support Windows-style line endings (CRLF) + stripCR bs + | S8.null bs = bs + | S8.last bs == '\r' = S8.init bs + | otherwise = bs + stripPrefix x y | x `S8.isPrefixOf` y = Just $ S8.drop (S8.length x) y | otherwise = Nothing diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -17,6 +17,7 @@ , ensureCompiler , ensureDockerStackExe , getSystemCompiler + , getCabalInstallVersion , SetupOpts (..) , defaultSetupInfoYaml , removeHaskellEnvVars @@ -80,6 +81,7 @@ import Network.HTTP.Simple (getResponseBody, httpLBS, withResponse, getResponseStatusCode) import Network.HTTP.Download import Path +import Path.CheckInstall (warnInstallSearchPathIssues) import Path.Extra (toFilePathNoTrailingSep) import Path.IO hiding (findExecutable) import qualified Paths_stack as Meta @@ -101,6 +103,7 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.StackT +import Stack.Types.StringError import Stack.Types.Version import qualified System.Directory as D import System.Environment (getExecutablePath) @@ -137,7 +140,7 @@ -- ^ Don't check for a compatible GHC version/architecture , soptsSkipMsys :: !Bool -- ^ Do not use a custom msys installation on Windows - , soptsUpgradeCabal :: !Bool + , soptsUpgradeCabal :: !(Maybe UpgradeTo) -- ^ Upgrade the global Cabal library in the database to the newest -- version. Only works reliably with a stack-managed installation. , soptsResolveMissingGHC :: !(Maybe Text) @@ -146,6 +149,8 @@ -- ^ Location of the main stack-setup.yaml file , soptsGHCBindistURL :: !(Maybe String) -- ^ Alternate GHC binary distribution (requires custom GHCVariant) + , soptsGHCJSBootOpts :: [String] + -- ^ Additional ghcjs-boot options, the default is "--clean" } deriving Show data SetupException = UnsupportedSetupCombo OS Arch @@ -231,10 +236,11 @@ , soptsSanityCheck = False , soptsSkipGhcCheck = configSkipGHCCheck config , soptsSkipMsys = configSkipMsys config - , soptsUpgradeCabal = False + , soptsUpgradeCabal = Nothing , soptsResolveMissingGHC = mResolveMissingGHC , soptsSetupInfoYaml = defaultSetupInfoYaml , soptsGHCBindistURL = Nothing + , soptsGHCJSBootOpts = ["--clean"] } (mghcBin, compilerBuild, _) <- ensureCompiler sopts @@ -346,10 +352,10 @@ addIncludeLib (ExtraDirs _bins includes libs) config = config { configExtraIncludeDirs = Set.union (configExtraIncludeDirs config) - (Set.fromList includes) + (Set.fromList (map toFilePathNoTrailingSep includes)) , configExtraLibDirs = Set.union (configExtraLibDirs config) - (Set.fromList libs) + (Set.fromList (map toFilePathNoTrailingSep libs)) } -- | Ensure compiler (ghc or ghcjs) is installed and provide the PATHs to add if necessary @@ -401,7 +407,7 @@ VersionedDownloadInfo version info <- case Map.lookup osKey $ siMsys2 si of Just x -> return x - Nothing -> error $ "MSYS2 not found for " ++ T.unpack osKey + Nothing -> throwString $ "MSYS2 not found for " ++ T.unpack osKey let tool = Tool (PackageIdentifier $(mkPackageName "msys2") version) Just <$> downloadAndInstallTool (configLocalPrograms config) si info tool (installMsys2Windows osKey) | otherwise -> do @@ -489,14 +495,14 @@ m <- augmentPathMap (edBins ed) (unEnvOverride menv0) mkEnvOverride (configPlatform config) (removeHaskellEnvVars m) - when (soptsUpgradeCabal sopts) $ do + forM_ (soptsUpgradeCabal sopts) $ \version -> do unless needLocal $ do - $logWarn "Trying to upgrade Cabal library on a GHC not installed by stack." + $logWarn "Trying to change a Cabal library on a GHC not installed by stack." $logWarn "This may fail, caveat emptor!" - upgradeCabal menv wc + upgradeCabal menv wc version case mtools of - Just (Just (ToolGhcjs cv), _) -> ensureGhcjsBooted menv cv (soptsInstallIfMissing sopts) + Just (Just (ToolGhcjs cv), _) -> ensureGhcjsBooted menv cv (soptsInstallIfMissing sopts) (soptsGHCJSBootOpts sopts) _ -> return () when (soptsSanityCheck sopts) $ sanityCheck menv wc @@ -622,68 +628,75 @@ downloadStackExe platforms sri stackExeDir (const $ return ()) return stackExePath --- | Install the newest version of Cabal globally +-- | Install the newest version or a specific version of Cabal globally upgradeCabal :: (StackM env m, HasConfig env, HasGHCVariant env) => EnvOverride -> WhichCompiler + -> UpgradeTo -> m () -upgradeCabal menv wc = do +upgradeCabal menv wc cabalVersion = do + $logInfo "Manipulating the global Cabal is only for debugging purposes" let name = $(mkPackageName "Cabal") - rmap <- resolvePackages menv Nothing Map.empty (Set.singleton name) - newest <- - case map rpIdent rmap of - [] -> error "No Cabal library found in index, cannot upgrade" - [PackageIdentifier name' version] - | name == name' -> return version - x -> error $ "Unexpected results for resolvePackages: " ++ show x + rmap <- resolvePackages Nothing Map.empty (Set.singleton name) installed <- getCabalPkgVer menv wc - if installed >= newest - then $logInfo $ T.concat - [ "Currently installed Cabal is " + case cabalVersion of + Specific version -> do + if installed /= version then + doCabalInstall menv wc installed version + else + $logInfo $ T.concat ["No install necessary. Cabal " + , T.pack $ versionString installed + , " is already installed"] + Latest -> case map rpIdent rmap of + [] -> throwString "No Cabal library found in index, cannot upgrade" + [PackageIdentifier name' version] | name == name' -> do + if installed > version then + doCabalInstall menv wc installed version + else + $logInfo $ "No upgrade necessary. Latest Cabal already installed" + x -> error $ "Unexpected results for resolvePackages: " ++ show x + +-- Configure and run the necessary commands for a cabal install +doCabalInstall :: (StackM env m, HasConfig env, HasGHCVariant env) + => EnvOverride + -> WhichCompiler + -> Version + -> Version + -> m () +doCabalInstall menv wc installed version = do + withSystemTempDir "stack-cabal-upgrade" $ \tmpdir -> do + $logInfo $ T.concat + [ "Installing Cabal-" + , T.pack $ versionString version + , " to replace " , T.pack $ versionString installed - , ", newest is " - , T.pack $ versionString newest - , ". I'm not upgrading Cabal." ] - else withSystemTempDir "stack-cabal-upgrade" $ \tmpdir -> do - $logInfo $ T.concat - [ "Installing Cabal-" - , T.pack $ versionString newest - , " to replace " - , T.pack $ versionString installed - ] - let ident = PackageIdentifier name newest - -- Nothing below: use the newest .cabal file revision - m <- unpackPackageIdents menv tmpdir Nothing (Map.singleton ident Nothing) - - compilerPath <- join $ findExecutable menv (compilerExeName wc) - newestDir <- parseRelDir $ versionString newest - let installRoot = toFilePath $ parent (parent compilerPath) - $(mkRelDir "new-cabal") - newestDir - - dir <- - case Map.lookup ident m of - Nothing -> error "upgradeCabal: Invariant violated, dir missing" - Just dir -> return dir - - runCmd (Cmd (Just dir) (compilerExeName wc) menv ["Setup.hs"]) Nothing - platform <- view platformL - let setupExe = toFilePath $ dir - (case platform of - Platform _ Cabal.Windows -> $(mkRelFile "Setup.exe") - _ -> $(mkRelFile "Setup")) - dirArgument name' = concat - [ "--" - , name' - , "dir=" - , installRoot FP. name' - ] - args = "configure" : map dirArgument (words "lib bin data doc") - runCmd (Cmd (Just dir) setupExe menv args) Nothing - runCmd (Cmd (Just dir) setupExe menv ["build"]) Nothing - runCmd (Cmd (Just dir) setupExe menv ["install"]) Nothing - $logInfo "New Cabal library installed" + let name = $(mkPackageName "Cabal") + ident = PackageIdentifier name version + m <- unpackPackageIdents tmpdir Nothing (Map.singleton ident Nothing) + compilerPath <- join $ findExecutable menv (compilerExeName wc) + versionDir <- parseRelDir $ versionString version + let installRoot = toFilePath $ parent (parent compilerPath) + $(mkRelDir "new-cabal") + versionDir + dir <- case Map.lookup ident m of + Nothing -> error "upgradeCabal: Invariant violated, dir missing" + Just dir -> return dir + runCmd (Cmd (Just dir) (compilerExeName wc) menv ["Setup.hs"]) Nothing + platform <- view platformL + let setupExe = toFilePath $ dir case platform of + Platform _ Cabal.Windows -> $(mkRelFile "Setup.exe") + _ -> $(mkRelFile "Setup") + dirArgument name' = concat [ "--" + , name' + , "dir=" + , installRoot FP. name' + ] + args = "configure" : map dirArgument (words "lib bin data doc") + runCmd (Cmd (Just dir) setupExe menv args) Nothing + runCmd (Cmd (Just dir) setupExe menv ["build"]) Nothing + runCmd (Cmd (Just dir) setupExe menv ["install"]) Nothing + $logInfo "New Cabal library installed" -- | Get the version of the system compiler, if available getSystemCompiler :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> WhichCompiler -> m (Maybe (CompilerVersion, Arch)) @@ -892,11 +905,11 @@ ".tar.bz2" -> return TarBz2 ".tar.gz" -> return TarGz ".7z.exe" -> return SevenZ - _ -> fail $ "Unknown extension for url: " ++ url - relfile <- parseRelFile $ toolString tool ++ extension + _ -> throwString $ "Error: Unknown extension for url: " ++ url + relativeFile <- parseRelFile $ toolString tool ++ extension path <- case url of (parseUrlThrow -> Just _) -> do - let path = programsDir relfile + let path = programsDir relativeFile ensureDir programsDir chattyDownload (T.pack (toolString tool)) downloadInfo path return path @@ -911,7 +924,7 @@ "should not be specified when `url` is a file path") return path _ -> - fail $ "`url` must be either an HTTP URL or absolute file path: " ++ url + throwString $ "Error: `url` must be either an HTTP URL or absolute file path: " ++ url return (path, at) where url = T.unpack $ downloadInfoUrl downloadInfo @@ -948,7 +961,7 @@ TarXz -> return ("xz", 'J') TarBz2 -> return ("bzip2", 'j') TarGz -> return ("gzip", 'z') - SevenZ -> error "Don't know how to deal with .7z files on non-Windows" + SevenZ -> throwString "Don't know how to deal with .7z files on non-Windows" -- Slight hack: OpenBSD's tar doesn't support xz. -- https://github.com/commercialhaskell/stack/issues/2283#issuecomment-237980986 let tarDep = @@ -1041,7 +1054,7 @@ TarXz -> return "xz" TarBz2 -> return "bzip2" TarGz -> return "gzip" - SevenZ -> error "Don't know how to deal with .7z files on non-Windows" + SevenZ -> throwString "Don't know how to deal with .7z files on non-Windows" (zipTool, tarTool) <- checkDependencies $ (,) <$> checkDependency zipTool' <*> checkDependency "tar" @@ -1086,8 +1099,8 @@ $logStickyDone "Installed GHCJS." ensureGhcjsBooted :: (StackM env m, HasConfig env) - => EnvOverride -> CompilerVersion -> Bool -> m () -ensureGhcjsBooted menv cv shouldBoot = do + => EnvOverride -> CompilerVersion -> Bool -> [String] -> m () +ensureGhcjsBooted menv cv shouldBoot bootOpts = do eres <- try $ sinkProcessStdout Nothing menv "ghcjs" [] (return ()) case eres of Right () -> return () @@ -1109,20 +1122,20 @@ stackYamlExists <- doesFileExist stackYaml ghcjsVersion <- case cv of GhcjsVersion version _ -> return version - _ -> fail "ensureGhcjsBooted invoked on non GhcjsVersion" + _ -> error "ensureGhcjsBooted invoked on non GhcjsVersion" actualStackYaml <- if stackYamlExists then return stackYaml else liftM ((destDir $(mkRelDir "src")) ) $ parseRelFile $ "ghcjs-" ++ versionString ghcjsVersion ++ "/stack.yaml" actualStackYamlExists <- doesFileExist actualStackYaml unless actualStackYamlExists $ - fail "Couldn't find GHCJS stack.yaml in old or new location." - bootGhcjs ghcjsVersion actualStackYaml destDir + throwString "Error: Couldn't find GHCJS stack.yaml in old or new location." + bootGhcjs ghcjsVersion actualStackYaml destDir bootOpts Left err -> throwM err bootGhcjs :: StackM env m - => Version -> Path Abs File -> Path Abs Dir -> m () -bootGhcjs ghcjsVersion stackYaml destDir = do + => Version -> Path Abs File -> Path Abs Dir -> [String] -> m () +bootGhcjs ghcjsVersion stackYaml destDir bootOpts = do envConfig <- loadGhcjsEnvConfig stackYaml (destDir $(mkRelDir "bin")) menv <- liftIO $ configEnvOverride (view configL envConfig) defaultEnvSettings -- Install cabal-install if missing, or if the installed one is old. @@ -1175,7 +1188,7 @@ "This version is specified by the stack.yaml file included in the ghcjs tarball.\n" _ -> return () $logSticky "Booting GHCJS (this will take a long time) ..." - logProcessStderrStdout Nothing "ghcjs-boot" menv' ["--clean"] + logProcessStderrStdout Nothing "ghcjs-boot" menv' bootOpts $logStickyDone "GHCJS booted." loadGhcjsEnvConfig :: StackM env m @@ -1300,10 +1313,10 @@ TarXz -> return ".xz" TarBz2 -> return ".bz2" TarGz -> return ".gz" - _ -> error $ name ++ " must be a tarball file" + _ -> throwString $ name ++ " must be a tarball file" tarFile <- case T.stripSuffix suffix $ T.pack $ toFilePath archiveFile of - Nothing -> error $ "Invalid " ++ name ++ " filename: " ++ show archiveFile + Nothing -> throwString $ "Invalid " ++ name ++ " filename: " ++ show archiveFile Just x -> parseAbsFile $ T.unpack x run7z <- setup7z si let tmpName = toFilePathNoTrailingSep (dirname destDir) ++ "-tmp" @@ -1329,7 +1342,7 @@ contents <- listDir destDir case contents of ([dir], []) -> return dir - _ -> error $ "Expected a single directory within unpacked " ++ toFilePath archiveFile + _ -> throwString $ "Expected a single directory within unpacked " ++ toFilePath archiveFile -- | Download 7z as necessary, and get a function for unpacking things. -- @@ -1648,7 +1661,7 @@ newtype StackReleaseInfo = StackReleaseInfo Value -downloadStackReleaseInfo :: MonadIO m +downloadStackReleaseInfo :: (MonadIO m, MonadThrow m) => Maybe String -- Github org -> Maybe String -- Github repo -> Maybe String -- ^ optional version @@ -1671,7 +1684,7 @@ let code = getResponseStatusCode res if code >= 200 && code < 300 then return $ StackReleaseInfo $ getResponseBody res - else error $ "Could not get release information for Stack from: " ++ url + else throwString $ "Could not get release information for Stack from: " ++ url preferredPlatforms :: (MonadReader env m, HasPlatform env) => m [(Bool, String)] @@ -1683,13 +1696,13 @@ Cabal.Windows -> return (True, "windows") Cabal.OSX -> return (False, "osx") Cabal.FreeBSD -> return (False, "freebsd") - _ -> error $ "Binary upgrade not yet supported on OS: " ++ show os' + _ -> errorString $ "Binary upgrade not yet supported on OS: " ++ show os' arch <- case arch' of I386 -> return "i386" X86_64 -> return "x86_64" Arm -> return "arm" - _ -> error $ "Binary upgrade not yet supported on arch: " ++ show arch' + _ -> errorString $ "Binary upgrade not yet supported on arch: " ++ show arch' hasgmp4 <- return False -- FIXME import relevant code from Stack.Setup? checkLib $(mkRelFile "libgmp.so.3") let suffixes | hasgmp4 = ["-static", "-gmp4", ""] @@ -1697,7 +1710,7 @@ return $ map (\suffix -> (isWindows, concat [os, "-", arch, suffix])) suffixes downloadStackExe - :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env) + :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env) => [(Bool, String)] -- ^ acceptable platforms -> StackReleaseInfo -> Path Abs Dir -- ^ destination directory @@ -1705,8 +1718,8 @@ -> m () downloadStackExe platforms0 archiveInfo destDir testExe = do (isWindows, archiveURL) <- - let loop [] = error $ "Unable to find binary Stack archive for platforms: " - ++ unwords (map snd platforms0) + let loop [] = throwString $ "Unable to find binary Stack archive for platforms: " + ++ unwords (map snd platforms0) loop ((isWindows, p'):ps) = do let p = T.pack p' $logInfo $ "Querying for archive location for platform: " <> p @@ -1752,6 +1765,9 @@ renameFile destFile old renameFile tmpFile destFile _ -> renameFile tmpFile destFile + + destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir + warnInstallSearchPathIssues destDir' ["stack"] $logInfo $ T.pack $ "New stack executable available at " ++ toFilePath destFile where 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 @@ -142,6 +142,7 @@ ] , edLib = [ dir $(mkRelDir "mingw32") $(mkRelDir "lib") + , dir $(mkRelDir "mingw32") $(mkRelDir "bin") ] } (Platform Cabal.X86_64 Cabal.Windows, "msys2") -> return mempty @@ -155,6 +156,7 @@ ] , edLib = [ dir $(mkRelDir "mingw64") $(mkRelDir "lib") + , dir $(mkRelDir "mingw64") $(mkRelDir "bin") ] } (_, isGHC -> True) -> return mempty @@ -188,13 +190,13 @@ -> Tool -> m (Path Abs Dir) installDir programsDir tool = do - reldir <- parseRelDir $ toolString tool - return $ programsDir reldir + relativeDir <- parseRelDir $ toolString tool + return $ programsDir relativeDir tempInstallDir :: (MonadReader env m, MonadThrow m) => Path Abs Dir -> Tool -> m (Path Abs Dir) tempInstallDir programsDir tool = do - reldir <- parseRelDir $ toolString tool ++ ".temp" - return $ programsDir reldir + relativeDir <- parseRelDir $ toolString tool ++ ".temp" + return $ programsDir relativeDir diff --git a/src/Stack/SetupCmd.hs b/src/Stack/SetupCmd.hs --- a/src/Stack/SetupCmd.hs +++ b/src/Stack/SetupCmd.hs @@ -30,9 +30,11 @@ data SetupCmdOpts = SetupCmdOpts { scoCompilerVersion :: !(Maybe CompilerVersion) , scoForceReinstall :: !Bool - , scoUpgradeCabal :: !Bool + , scoUpgradeCabal :: !(Maybe UpgradeTo) , scoSetupInfoYaml :: !String , scoGHCBindistURL :: !(Maybe String) + , scoGHCJSBootOpts :: ![String] + , scoGHCJSBootClean :: !Bool } setupYamlCompatParser :: OA.Parser String @@ -48,6 +50,22 @@ <> OA.metavar "URL" <> OA.value defaultSetupInfoYaml ) +cabalUpgradeParser :: OA.Parser UpgradeTo +cabalUpgradeParser = Specific <$> version' <|> latestParser + where + versionReader = do + s <- OA.readerAsk + case parseVersion (T.pack s) of + Nothing -> OA.readerError $ "Invalid version: " ++ s + Just v -> return v + version' = OA.option versionReader ( + OA.long "install-cabal" + <> OA.metavar "VERSION" + <> OA.help "Install a specific version of Cabal" ) + latestParser = OA.flag' Latest ( + OA.long "upgrade-cabal" + <> OA.help "Install latest version of Cabal globally" ) + setupParser :: OA.Parser SetupCmdOpts setupParser = SetupCmdOpts <$> OA.optional (OA.argument readVersion @@ -58,15 +76,20 @@ "reinstall" "reinstalling GHC, even if available (incompatible with --system-ghc)" OA.idm - <*> OA.boolFlags False - "upgrade-cabal" - "installing the newest version of the Cabal library globally" - OA.idm + <*> OA.optional cabalUpgradeParser <*> setupYamlCompatParser <*> OA.optional (OA.strOption (OA.long "ghc-bindist" <> OA.metavar "URL" <> OA.help "Alternate GHC binary distribution (requires custom --ghc-variant)")) + <*> OA.many (OA.strOption + (OA.long "ghcjs-boot-options" + <> OA.metavar "GHCJS_BOOT" + <> OA.help "Additional ghcjs-boot options")) + <*> OA.boolFlags True + "ghcjs-boot-clean" + "Control if ghcjs-boot should have --clean option present" + OA.idm where readVersion = do s <- OA.readerAsk @@ -100,6 +123,7 @@ , soptsResolveMissingGHC = Nothing , soptsSetupInfoYaml = scoSetupInfoYaml , soptsGHCBindistURL = scoGHCBindistURL + , soptsGHCJSBootOpts = scoGHCJSBootOpts ++ ["--clean" | scoGHCJSBootClean] } let compiler = case wantedCompiler of GhcVersion _ -> "GHC" diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -27,8 +27,7 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger -import Data.Aeson.Extended ( WithJSONWarnings(..), object, (.=), toJSON - , logJSONWarnings) +import Data.Aeson.Extended (object, (.=), toJSON) import qualified Data.ByteString as S import Data.Char (isSpace) import Data.Either @@ -61,11 +60,12 @@ import Path.Find (findFiles) import Path.IO hiding (findExecutable, findFiles) import Stack.BuildPlan -import Stack.Config (getLocalPackages) +import Stack.Config (getLocalPackages, loadConfigYaml) import Stack.Constants (stackDotYaml, wiredInPackages) import Stack.Package (printCabalFileWarning , hpack , readPackageUnresolved) +import Stack.PrettyPrint import Stack.Setup import Stack.Setup.Installed import Stack.Types.Build @@ -293,16 +293,16 @@ , soptsUseSystem = configSystemGHC config , soptsWantedCompiler = compiler , soptsCompilerCheck = configCompilerCheck config - , soptsStackYaml = Nothing , soptsForceReinstall = False , soptsSanityCheck = False , soptsSkipGhcCheck = False , soptsSkipMsys = configSkipMsys config - , soptsUpgradeCabal = False + , soptsUpgradeCabal = Nothing , soptsResolveMissingGHC = msg - , soptsSetupInfoYaml = defaultSetupInfoYaml + , soptsSetupInfoYaml = defaultSetupInfoYaml , soptsGHCBindistURL = Nothing + , soptsGHCJSBootOpts = ["--clean"] } return dirs @@ -319,10 +319,20 @@ platform <- view platformL menv <- mkEnvOverride platform envMap - mcabal <- findExecutable menv "cabal" + mcabal <- getCabalInstallVersion menv case mcabal of Nothing -> throwM SolverMissingCabalInstall - Just _ -> return () + Just version + | version < $(mkVersion "1.24") -> $prettyWarn $ + "Installed version of cabal-install (" <> + display version <> + ") doesn't support custom-setup clause, and so may not yield correct results." <> line <> + "To resolve this, install a newer version via 'stack install cabal-install'." <> line + | version >= $(mkVersion "1.25") -> $prettyWarn $ + "Installed version of cabal-install (" <> + display version <> + ") is newer than stack has been tested with. If you run into difficulties, consider downgrading." <> line + | otherwise -> return () mver <- getSystemCompiler menv (whichCompiler compiler) case mver of @@ -716,7 +726,7 @@ $logInfo $ "No changes needed to " <> T.pack relStackYaml where - indent t = T.unlines $ fmap (" " <>) (T.lines t) + indentLines t = T.unlines $ fmap (" " <>) (T.lines t) printResolver mOldRes res = do forM_ mOldRes $ \oldRes -> @@ -731,21 +741,20 @@ printFlags fl msg = do unless (Map.null fl) $ do $logInfo $ T.pack msg - $logInfo $ indent $ decodeUtf8 $ Yaml.encode - $ object ["flags" .= fl] + $logInfo $ indentLines $ decodeUtf8 $ Yaml.encode + $ object ["flags" .= fl] printDeps deps msg = do unless (Map.null deps) $ do $logInfo $ T.pack msg - $logInfo $ indent $ decodeUtf8 $ Yaml.encode $ object + $logInfo $ indentLines $ decodeUtf8 $ Yaml.encode $ object ["extra-deps" .= map fromTuple (Map.toList deps)] writeStackYaml path res deps fl = do let fp = toFilePath path obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return - WithJSONWarnings (ProjectAndConfigMonoid _ _) warnings <- - liftIO (Yaml.decodeFileEither fp) >>= either throwM return - logJSONWarnings fp warnings + -- Check input file and show warnings + _ <- loadConfigYaml (parseProjectAndConfigMonoid (parent path)) path let obj' = HashMap.insert "extra-deps" (toJSON $ map fromTuple $ Map.toList deps) 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 @@ -18,6 +18,7 @@ ,Installed(..) ,PackageInstallInfo(..) ,Task(..) + ,taskIsTarget ,taskLocation ,LocalPackage(..) ,BaseConfigOpts(..) @@ -35,6 +36,8 @@ ,ConfigCache(..) ,configCacheVC ,configureOpts + ,CachePkgSrc (..) + ,toCachePkgSrc ,isStackOpt ,wantedLocalPackages ,FileCacheInfo (..) @@ -393,13 +396,23 @@ -- is a convenient way to force compilation when the components change. , configCacheHaddock :: !Bool -- ^ Are haddocks to be built? + , configCachePkgSrc :: !CachePkgSrc } deriving (Generic, Eq, Show, Data, Typeable) instance Store ConfigCache instance NFData ConfigCache +data CachePkgSrc = CacheSrcUpstream | CacheSrcLocal FilePath + deriving (Generic, Eq, Show, Data, Typeable) +instance Store CachePkgSrc +instance NFData CachePkgSrc + +toCachePkgSrc :: PackageSource -> CachePkgSrc +toCachePkgSrc (PSLocal lp) = CacheSrcLocal (toFilePath (lpDir lp)) +toCachePkgSrc PSUpstream{} = CacheSrcUpstream + configCacheVC :: VersionConfig ConfigCache -configCacheVC = storeVersionConfig "config-v1" "NMEzMXpksE1h7STRzlQ2f6Glkjo=" +configCacheVC = storeVersionConfig "config-v3" "z7N_NxX7Gbz41Gi9AGEa1zoLE-4=" -- | A task to perform when building data Task = Task @@ -412,6 +425,7 @@ -- ^ GhcPkgIds of already-installed dependencies , taskAllInOne :: !Bool -- ^ indicates that the package can be built in one step + , taskCachePkgSrc :: !CachePkgSrc } deriving Show @@ -436,6 +450,12 @@ | TTUpstream Package InstallLocation (Maybe GitSHA1) deriving Show +taskIsTarget :: Task -> Bool +taskIsTarget t = + case taskType t of + TTLocal lp -> lpWanted lp + _ -> False + taskLocation :: Task -> InstallLocation taskLocation task = case taskType task of @@ -495,10 +515,13 @@ , "--haddockdir=" , "--enable-tests" , "--enable-benchmarks" - , "--enable-library-profiling" - , "--enable-executable-profiling" - , "--enable-profiling" , "--exact-configuration" + -- Treat these as causing dirtiness, to resolve + -- https://github.com/commercialhaskell/stack/issues/2984 + -- + -- , "--enable-library-profiling" + -- , "--enable-executable-profiling" + -- , "--enable-profiling" ] || t == "--user" configureOptsDirs :: BaseConfigOpts @@ -557,8 +580,8 @@ flagNameString name) (Map.toList flags) , concatMap (\x -> [compilerOptionsCabalFlag wc, T.unpack x]) (packageGhcOptions package) - , map (("--extra-include-dirs=" ++) . toFilePathNoTrailingSep) (Set.toList (configExtraIncludeDirs config)) - , map (("--extra-lib-dirs=" ++) . toFilePathNoTrailingSep) (Set.toList (configExtraLibDirs config)) + , map ("--extra-include-dirs=" ++) (Set.toList (configExtraIncludeDirs config)) + , map ("--extra-lib-dirs=" ++) (Set.toList (configExtraLibDirs config)) , maybe [] (\customGcc -> ["--with-gcc=" ++ toFilePath customGcc]) (configOverrideGccPath config) , ["--ghcjs" | wc == Ghcjs] , ["--exact-configuration" | useExactConf] diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -445,7 +445,7 @@ , mpiToolDeps :: !(Set Text) -- ^ Due to ambiguity in Cabal, it is unclear whether this refers to the -- executable name, the package name, or something else. We have to guess - -- based on what's available, which is why we store this is an unwrapped + -- based on what's available, which is why we store this in an unwrapped -- 'Text'. , mpiExes :: !(Set ExeName) -- ^ Executables provided by this package @@ -454,12 +454,15 @@ , mpiGitSHA1 :: !(Maybe GitSHA1) -- ^ An optional SHA1 representation in hex format of the blob containing -- the cabal file contents. Useful for grabbing the correct cabal file - -- revision directly from a Git repo + -- revision directly from a Git repo or the 01-index.tar file } deriving (Generic, Show, Eq, Data, Typeable) instance Store MiniPackageInfo instance NFData MiniPackageInfo +-- | A SHA1 hash, but in Git format. This means that the contents are +-- prefixed with @blob@ and the size of the payload before hashing, as +-- Git itself does. newtype GitSHA1 = GitSHA1 ByteString deriving (Generic, Show, Eq, NFData, Store, Data, Typeable, Ord, Hashable) 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 @@ -63,6 +63,7 @@ ,ConfigMonoid(..) ,configMonoidInstallGHCName ,configMonoidSystemGHCName + ,parseConfigMonoid -- ** DumpLogs ,DumpLogs(..) -- ** EnvSettings @@ -86,7 +87,6 @@ ,PackageIndex(..) ,IndexName(..) ,indexNameText - ,IndexLocation(..) -- Config fields ,configPackageIndex ,configPackageIndexOld @@ -94,13 +94,14 @@ ,configPackageIndexCacheOld ,configPackageIndexGz ,configPackageIndexRoot - ,configPackageIndexRepo ,configPackageTarball -- ** Project & ProjectAndConfigMonoid ,Project(..) ,ProjectAndConfigMonoid(..) + ,parseProjectAndConfigMonoid -- ** PvpBounds ,PvpBounds(..) + ,PvpBoundsType(..) ,parsePvpBounds -- ** ColorWhen ,ColorWhen(..) @@ -237,7 +238,7 @@ import Stack.Types.TemplateName import Stack.Types.Urls import Stack.Types.Version -import System.FilePath (takeBaseName) +import qualified System.FilePath as FilePath import System.PosixCompat.Types (UserID, GroupID, FileMode) import System.Process.Read (EnvOverride, findExecutable) @@ -325,9 +326,9 @@ -- ^ How many concurrent jobs to run, defaults to number of capabilities ,configOverrideGccPath :: !(Maybe (Path Abs File)) -- ^ Optional gcc override path - ,configExtraIncludeDirs :: !(Set (Path Abs Dir)) + ,configExtraIncludeDirs :: !(Set FilePath) -- ^ --extra-include-dirs arguments - ,configExtraLibDirs :: !(Set (Path Abs Dir)) + ,configExtraLibDirs :: !(Set FilePath) -- ^ --extra-lib-dirs arguments ,configConcurrentTests :: !Bool -- ^ Run test suites concurrently @@ -371,6 +372,8 @@ ,configAllowLocals :: !Bool -- ^ Are we allowed to build local packages? The script -- command disallows this. + ,configSaveHackageCreds :: !Bool + -- ^ Should we save Hackage credentials to a file? } -- | Which packages do ghc-options on the command line apply to? @@ -740,9 +743,9 @@ -- ^ Used for overriding the GHC build ,configMonoidJobs :: !(First Int) -- ^ See: 'configJobs' - ,configMonoidExtraIncludeDirs :: !(Set (Path Abs Dir)) + ,configMonoidExtraIncludeDirs :: !(Set FilePath) -- ^ See: 'configExtraIncludeDirs' - ,configMonoidExtraLibDirs :: !(Set (Path Abs Dir)) + ,configMonoidExtraLibDirs :: !(Set FilePath) -- ^ See: 'configExtraLibDirs' , configMonoidOverrideGccPath :: !(First (Path Abs File)) -- ^ Allow users to override the path to gcc @@ -784,6 +787,8 @@ -- installation. , configMonoidDumpLogs :: !(First DumpLogs) -- ^ See 'configDumpLogs' + , configMonoidSaveHackageCreds :: !(First Bool) + -- ^ See 'configSaveHackageCreds' } deriving (Show, Generic) @@ -791,14 +796,14 @@ mempty = memptydefault mappend = mappenddefault -instance FromJSON (WithJSONWarnings ConfigMonoid) where - parseJSON = withObjectWarnings "ConfigMonoid" parseConfigMonoidJSON +parseConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings ConfigMonoid) +parseConfigMonoid = withObjectWarnings "ConfigMonoid" . parseConfigMonoidObject -- | Parse a partial configuration. Used both to parse both a standalone config -- file and a project file, so that a sub-parser is not required, which would interfere with -- warnings for missing fields. -parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid -parseConfigMonoidJSON obj = do +parseConfigMonoidObject :: Path Abs Dir -> Object -> WarningParser ConfigMonoid +parseConfigMonoidObject rootDir obj = do -- Parsing 'stackRoot' from 'stackRoot'/config.yaml would be nonsensical let configMonoidStackRoot = First Nothing configMonoidWorkDir <- First <$> obj ..:? configMonoidWorkDirName @@ -821,8 +826,10 @@ configMonoidGHCVariant <- First <$> obj ..:? configMonoidGHCVariantName configMonoidGHCBuild <- First <$> obj ..:? configMonoidGHCBuildName configMonoidJobs <- First <$> obj ..:? configMonoidJobsName - configMonoidExtraIncludeDirs <- obj ..:? configMonoidExtraIncludeDirsName ..!= Set.empty - configMonoidExtraLibDirs <- obj ..:? configMonoidExtraLibDirsName ..!= Set.empty + configMonoidExtraIncludeDirs <- fmap (Set.map (toFilePath rootDir FilePath.)) $ + obj ..:? configMonoidExtraIncludeDirsName ..!= Set.empty + configMonoidExtraLibDirs <- fmap (Set.map (toFilePath rootDir FilePath.)) $ + obj ..:? configMonoidExtraLibDirsName ..!= Set.empty configMonoidOverrideGccPath <- First <$> obj ..:? configMonoidOverrideGccPathName configMonoidConcurrentTests <- First <$> obj ..:? configMonoidConcurrentTestsName configMonoidLocalBinPath <- First <$> obj ..:? configMonoidLocalBinPathName @@ -853,6 +860,7 @@ configMonoidDefaultTemplate <- First <$> obj ..:? configMonoidDefaultTemplateName configMonoidAllowDifferentUser <- First <$> obj ..:? configMonoidAllowDifferentUserName configMonoidDumpLogs <- First <$> obj ..:? configMonoidDumpLogsName + configMonoidSaveHackageCreds <- First <$> obj ..:? configMonoidSaveHackageCredsName return ConfigMonoid {..} where @@ -986,6 +994,9 @@ configMonoidDumpLogsName :: Text configMonoidDumpLogsName = "dump-logs" +configMonoidSaveHackageCredsName :: Text +configMonoidSaveHackageCredsName = "save-hackage-creds" + data ConfigException = ParseConfigFileException (Path Abs File) ParseException | ParseCustomSnapshotException Text ParseException @@ -1160,28 +1171,6 @@ dir <- parseRelDir $ S8.unpack name return (root $(mkRelDir "indices") dir) --- | Git repo directory for a specific package index, returns 'Nothing' if not --- a Git repo -configPackageIndexRepo :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Maybe (Path Abs Dir)) -configPackageIndexRepo name = do - indices <- view packageIndicesL - case filter (\p -> indexName p == name) indices of - [index] -> do - let murl = - case simplifyIndexLocation $ indexLocation index of - SILGit x -> Just x - SILHttp _ _ -> Nothing - case murl of - Nothing -> return Nothing - Just url -> do - sDir <- configPackageIndexRoot name - repoName <- parseRelDir $ takeBaseName $ T.unpack url - let suDir = - sDir - $(mkRelDir "git-update") - return $ Just $ suDir repoName - _ -> assert False $ return Nothing - -- | Location of the 01-index.cache file configPackageIndexCache :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) configPackageIndexCache = liftM ( $(mkRelFile "01-index.cache")) . configPackageIndexRoot @@ -1425,8 +1414,9 @@ data ProjectAndConfigMonoid = ProjectAndConfigMonoid !Project !ConfigMonoid -instance FromJSON (WithJSONWarnings ProjectAndConfigMonoid) where - parseJSON = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do +parseProjectAndConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings ProjectAndConfigMonoid) +parseProjectAndConfigMonoid rootDir = + withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do dirs <- jsonSubWarningsTT (o ..:? "packages") ..!= [packageEntryCurrDir] extraDeps' <- o ..:? "extra-deps" ..!= [] extraDeps <- @@ -1438,7 +1428,7 @@ resolver <- jsonSubWarnings (o ..: "resolver") compiler <- o ..:? "compiler" msg <- o ..:? "user-message" - config <- parseConfigMonoidJSON o + config <- parseConfigMonoidObject rootDir o extraPackageDBs <- o ..:? "extra-package-dbs" ..!= [] let project = Project { projectUserMsg = msg @@ -1651,29 +1641,44 @@ return $ WithJSONWarnings (SetupInfoInline si) w -- | How PVP bounds should be added to .cabal files -data PvpBounds +data PvpBoundsType = PvpBoundsNone | PvpBoundsUpper | PvpBoundsLower | PvpBoundsBoth deriving (Show, Read, Eq, Typeable, Ord, Enum, Bounded) -pvpBoundsText :: PvpBounds -> Text +data PvpBounds = PvpBounds + { pbType :: !PvpBoundsType + , pbAsRevision :: !Bool + } + deriving (Show, Read, Eq, Typeable, Ord) + +pvpBoundsText :: PvpBoundsType -> Text pvpBoundsText PvpBoundsNone = "none" pvpBoundsText PvpBoundsUpper = "upper" pvpBoundsText PvpBoundsLower = "lower" pvpBoundsText PvpBoundsBoth = "both" parsePvpBounds :: Text -> Either String PvpBounds -parsePvpBounds t = - case Map.lookup t m of - Nothing -> Left $ "Invalid PVP bounds: " ++ T.unpack t - Just x -> Right x +parsePvpBounds t = maybe err Right $ do + (t', asRevision) <- + case T.break (== '-') t of + (x, "") -> Just (x, False) + (x, "-revision") -> Just (x, True) + _ -> Nothing + x <- Map.lookup t' m + Just PvpBounds + { pbType = x + , pbAsRevision = asRevision + } where m = Map.fromList $ map (pvpBoundsText &&& id) [minBound..maxBound] + err = Left $ "Invalid PVP bounds: " ++ T.unpack t instance ToJSON PvpBounds where - toJSON = toJSON . pvpBoundsText + toJSON (PvpBounds typ asRevision) = + toJSON (pvpBoundsText typ <> (if asRevision then "-revision" else "")) instance FromJSON PvpBounds where parseJSON = withText "PvpBounds" (either fail return . parsePvpBounds) diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs --- a/src/Stack/Types/Config/Build.hs +++ b/src/Stack/Types/Config/Build.hs @@ -56,6 +56,9 @@ -- ^ Build haddocks for dependencies? ,boptsHaddockInternal :: !Bool -- ^ Build haddocks for all symbols and packages, like @cabal haddock --internal@ + ,boptsHaddockHyperlinkSource :: !Bool + -- ^ Build hyperlinked source if possible. Fallback to + -- @hscolour@. Disable for no sources. ,boptsInstallExes :: !Bool -- ^ Install executables to user path after building? ,boptsPreFetch :: !Bool @@ -97,6 +100,7 @@ , boptsOpenHaddocks = False , boptsHaddockDeps = Nothing , boptsHaddockInternal = False + , boptsHaddockHyperlinkSource = True , boptsInstallExes = False , boptsPreFetch = False , boptsKeepGoing = Nothing @@ -149,7 +153,10 @@ -- | Build options that may be specified in the stack.yaml or from the CLI data BuildOptsMonoid = BuildOptsMonoid - { buildMonoidLibProfile :: !(First Bool) + { buildMonoidTrace :: !Any + , buildMonoidProfile :: !Any + , buildMonoidNoStrip :: !Any + , buildMonoidLibProfile :: !(First Bool) , buildMonoidExeProfile :: !(First Bool) , buildMonoidLibStrip :: !(First Bool) , buildMonoidExeStrip :: !(First Bool) @@ -158,6 +165,7 @@ , buildMonoidOpenHaddocks :: !(First Bool) , buildMonoidHaddockDeps :: !(First Bool) , buildMonoidHaddockInternal :: !(First Bool) + , buildMonoidHaddockHyperlinkSource :: !(First Bool) , buildMonoidInstallExes :: !(First Bool) , buildMonoidPreFetch :: !(First Bool) , buildMonoidKeepGoing :: !(First Bool) @@ -173,7 +181,10 @@ instance FromJSON (WithJSONWarnings BuildOptsMonoid) where parseJSON = withObjectWarnings "BuildOptsMonoid" - (\o -> do buildMonoidLibProfile <- First <$> o ..:? buildMonoidLibProfileArgName + (\o -> do let buildMonoidTrace = Any False + buildMonoidProfile = Any False + buildMonoidNoStrip = Any False + buildMonoidLibProfile <- First <$> o ..:? buildMonoidLibProfileArgName buildMonoidExeProfile <-First <$> o ..:? buildMonoidExeProfileArgName buildMonoidLibStrip <- First <$> o ..:? buildMonoidLibStripArgName buildMonoidExeStrip <-First <$> o ..:? buildMonoidExeStripArgName @@ -182,6 +193,7 @@ buildMonoidOpenHaddocks <- First <$> o ..:? buildMonoidOpenHaddocksArgName buildMonoidHaddockDeps <- First <$> o ..:? buildMonoidHaddockDepsArgName buildMonoidHaddockInternal <- First <$> o ..:? buildMonoidHaddockInternalArgName + buildMonoidHaddockHyperlinkSource <- First <$> o ..:? buildMonoidHaddockHyperlinkSourceArgName buildMonoidInstallExes <- First <$> o ..:? buildMonoidInstallExesArgName buildMonoidPreFetch <- First <$> o ..:? buildMonoidPreFetchArgName buildMonoidKeepGoing <- First <$> o ..:? buildMonoidKeepGoingArgName @@ -221,6 +233,9 @@ buildMonoidHaddockInternalArgName :: Text buildMonoidHaddockInternalArgName = "haddock-internal" + +buildMonoidHaddockHyperlinkSourceArgName :: Text +buildMonoidHaddockHyperlinkSourceArgName = "haddock-hyperlink-source" buildMonoidInstallExesArgName :: Text buildMonoidInstallExesArgName = "copy-bins" 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 @@ -38,6 +38,7 @@ import GHC.Generics import Language.Haskell.TH import Language.Haskell.TH.Syntax +import Stack.Types.StringError -- | A parse fail. newtype FlagNameParseFail @@ -93,7 +94,7 @@ mkFlagName :: String -> Q Exp mkFlagName s = case parseFlagNameFromString s of - Nothing -> error ("Invalid flag name: " ++ show s) + Nothing -> errorString ("Invalid flag name: " ++ show s) Just pn -> [|pn|] -- | Convenient way to parse a flag name from a 'Text'. 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 @@ -31,7 +31,7 @@ import Distribution.License (License) import Distribution.ModuleName (ModuleName) import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier) -import Distribution.PackageDescription (TestSuiteInterface) +import Distribution.PackageDescription (TestSuiteInterface, BuildType) import Distribution.System (Platform (..)) import GHC.Generics (Generic) import Path as FL @@ -101,7 +101,7 @@ ,packageExes :: !(Set Text) -- ^ names of executables ,packageOpts :: !GetPackageOpts -- ^ Args to pass to GHC. ,packageHasExposedModules :: !Bool -- ^ Does the package have exposed modules? - ,packageSimpleType :: !Bool -- ^ Does the package of build-type: Simple + ,packageBuildType :: !(Maybe BuildType) -- ^ Package build-type. ,packageSetupDeps :: !(Maybe (Map PackageName VersionRange)) -- ^ If present: custom-setup dependencies } diff --git a/src/Stack/Types/PackageIndex.hs b/src/Stack/Types/PackageIndex.hs --- a/src/Stack/Types/PackageIndex.hs +++ b/src/Stack/Types/PackageIndex.hs @@ -16,10 +16,7 @@ , PackageIndex(..) , IndexName(..) , indexNameText - , IndexLocation(..) - , SimplifiedIndexLocation (..) - , simplifyIndexLocation - , HttpType (..) + , IndexType (..) , HackageSecurity (..) ) where @@ -126,7 +123,7 @@ Left e -> fail $ "Invalid index name: " ++ show e Right _ -> return $ IndexName $ encodeUtf8 t -data HttpType = HTHackageSecurity !HackageSecurity | HTVanilla +data IndexType = ITHackageSecurity !HackageSecurity | ITVanilla deriving (Show, Eq, Ord) data HackageSecurity = HackageSecurity @@ -139,33 +136,15 @@ <$> o .: "keyids" <*> o .: "key-threshold" --- | Location of the package index. This ensures that at least one of Git or --- HTTP is available. -data IndexLocation - = ILGit !Text - | ILHttp !Text !HttpType - | ILGitHttp !Text !Text !HttpType - deriving (Show, Eq, Ord) - --- | Simplified 'IndexLocation', which will either be a Git repo or HTTP URL. -data SimplifiedIndexLocation = SILGit !Text | SILHttp !Text !HttpType - deriving (Show, Eq, Ord) - -simplifyIndexLocation :: IndexLocation -> SimplifiedIndexLocation -simplifyIndexLocation (ILGit t) = SILGit t -simplifyIndexLocation (ILHttp t ht) = SILHttp t ht --- Prefer HTTP over Git -simplifyIndexLocation (ILGitHttp _ t ht) = SILHttp t ht - -- | Information on a single package index data PackageIndex = PackageIndex { indexName :: !IndexName - , indexLocation :: !IndexLocation + , indexLocation :: !Text + -- ^ URL for the tarball or, in the case of Hackage Security, the + -- root of the directory + , indexType :: !IndexType , indexDownloadPrefix :: !Text -- ^ URL prefix for downloading packages - , indexGpgVerify :: !Bool - -- ^ GPG-verify the package index during download. Only applies to Git - -- repositories for now. , indexRequireHashes :: !Bool -- ^ Require that hashes and package size information be available for packages in this index } @@ -174,24 +153,14 @@ parseJSON = withObjectWarnings "PackageIndex" $ \o -> do name <- o ..: "name" prefix <- o ..: "download-prefix" - mgit <- o ..:? "git" - mhttp <- o ..:? "http" + http <- o ..: "http" mhackageSecurity <- o ..:? "hackage-security" - let httpType = maybe HTVanilla HTHackageSecurity mhackageSecurity - loc <- - case (mgit, mhttp) of - (Nothing, Nothing) -> fail $ - "Must provide either Git or HTTP URL for " ++ - T.unpack (indexNameText name) - (Just git, Nothing) -> return $ ILGit git - (Nothing, Just http) -> return $ ILHttp http httpType - (Just git, Just http) -> return $ ILGitHttp git http httpType - gpgVerify <- o ..:? "gpg-verify" ..!= False + let indexType' = maybe ITVanilla ITHackageSecurity mhackageSecurity reqHashes <- o ..:? "require-hashes" ..!= False return PackageIndex { indexName = name - , indexLocation = loc + , indexLocation = http + , indexType = indexType' , indexDownloadPrefix = prefix - , indexGpgVerify = gpgVerify , indexRequireHashes = reqHashes } 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 @@ -43,6 +43,7 @@ import Language.Haskell.TH.Syntax import qualified Options.Applicative as O import Path +import Stack.Types.StringError -- | A parse fail. data PackageNameParseFail @@ -95,7 +96,7 @@ mkPackageName :: String -> Q Exp mkPackageName s = case parsePackageNameFromString s of - Nothing -> error ("Invalid package name: " ++ show s) + Nothing -> errorString ("Invalid package name: " ++ show s) Just pn -> [|pn|] -- | Parse a package name from a 'Text'. diff --git a/src/Stack/Types/Resolver.hs b/src/Stack/Types/Resolver.hs --- a/src/Stack/Types/Resolver.hs +++ b/src/Stack/Types/Resolver.hs @@ -65,7 +65,7 @@ -- dependency solver. ResolverCompiler :: !CompilerVersion -> ResolverThat's l -- A custom resolver based on the given name and URL. When a URL is - -- provided, it file is to be completely immutable. Filepaths are + -- provided, its contents must be completely immutable. Filepaths are -- always loaded. This constructor is used before the build-plan has -- been loaded, as we do not yet know the custom snapshot's hash. ResolverCustom :: !Text -> !Text -> ResolverThat's 'NotLoaded diff --git a/src/Stack/Types/StringError.hs b/src/Stack/Types/StringError.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/StringError.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE MagicHash #-} + +module Stack.Types.StringError where + +import Control.Exception +import Control.Monad.Catch +import Data.Typeable +import GHC.Prim + +newtype StringError = StringError String + deriving (Typeable) + +instance Exception StringError +instance Show StringError where show (StringError str) = str + +throwString :: MonadThrow m => String -> m a +throwString = throwM . StringError + +errorString :: String -> a +errorString = raise# . toException . StringError 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 @@ -22,6 +22,7 @@ import Path import Path.Internal import Prelude +import Stack.Types.StringError -- | A template name. data TemplateName = TemplateName !Text !TemplatePath @@ -94,7 +95,7 @@ mkTemplateName :: String -> Q Exp mkTemplateName s = case parseTemplateNameFromString s of - Left{} -> error ("Invalid template name: " ++ show s) + Left{} -> errorString ("Invalid template name: " ++ show s) Right (TemplateName (T.unpack -> prefix) p) -> [|TemplateName (T.pack prefix) $(pn)|] where pn = diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -27,7 +27,8 @@ ,toMajorVersion ,latestApplicableVersion ,checkVersion - ,nextMajorVersion) + ,nextMajorVersion + ,UpgradeTo(..)) where import Control.Applicative @@ -54,6 +55,7 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax import Prelude -- Fix warning: Word in Prelude from base-4.8. +import Stack.Types.StringError import Text.PrettyPrint (render) -- | A parse fail. @@ -64,6 +66,9 @@ instance Show VersionParseFail where show (VersionParseFail bs) = "Invalid version: " ++ show bs +-- | A Package upgrade; Latest or a specific version. +data UpgradeTo = Specific Version | Latest deriving (Show) + -- | A package version. newtype Version = Version {unVersion :: Vector Word} @@ -157,7 +162,7 @@ mkVersion :: String -> Q Exp mkVersion s = case parseVersionFromString s of - Nothing -> error ("Invalid package version: " ++ show s) + Nothing -> errorString ("Invalid package version: " ++ show s) Just pn -> [|pn|] -- | Display a version range diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -36,6 +36,7 @@ import Stack.Types.Config import Stack.Types.Resolver import Stack.Types.StackT +import Stack.Types.StringError import System.Exit (ExitCode (ExitSuccess)) import System.Process (rawSystem, readProcess) import System.Process.Run @@ -110,7 +111,7 @@ -- FIXME It would be far nicer to capture this case in the -- options parser itself so we get better error messages, but -- I can't think of a way to make it happen. - (Nothing, Nothing) -> error "You must allow either binary or source upgrade paths" + (Nothing, Nothing) -> throwString "You must allow either binary or source upgrade paths" (Just bo, Nothing) -> binary bo (Nothing, Just so) -> source so -- See #2977 - if --git or --git-repo is specified, do source upgrade. @@ -159,7 +160,7 @@ toUpgrade <- case (force, isNewer) of (False, False) -> do - $logInfo "Skipping binary upgrade, your version is already more recent" + $logInfo "Skipping binary upgrade, you are already running the most recent version" return False (True, False) -> do $logInfo "Forcing binary upgrade" @@ -174,7 +175,7 @@ ec <- rawSystem (toFilePath tmpFile) ["--version"] unless (ec == ExitSuccess) - $ error "Non-success exit code from running newly downloaded executable" + $ throwString "Non-success exit code from running newly downloaded executable" sourceUpgrade :: (StackM env m, HasConfig env) @@ -209,7 +210,7 @@ runCmd (Cmd (Just tmp) "git" menv args) Nothing return $ Just $ tmp $(mkRelDir "stack") Nothing -> do - updateAllIndices menv + updateAllIndices (caches, _gitShaCaches) <- getPackageCaches let latest = Map.fromListWith max $ map toTuple @@ -222,13 +223,13 @@ caches case Map.lookup $(mkPackageName "stack") latest of - Nothing -> error "No stack found in package indices" + Nothing -> throwString "No stack found in package indices" Just version | version <= fromCabalVersion Paths.version -> do $logInfo "Already at latest version, no upgrade required" return Nothing Just version -> do let ident = PackageIdentifier $(mkPackageName "stack") version - paths <- unpackPackageIdents menv tmp Nothing + paths <- unpackPackageIdents tmp Nothing -- accept latest cabal revision by not supplying a Git SHA $ Map.singleton ident Nothing case Map.lookup ident paths of diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -1,39 +1,25 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Provide ability to upload tarballs to Hackage. module Stack.Upload ( -- * Upload - nopUploader - , mkUploader - , Uploader - , upload + upload , uploadBytes - , UploadSettings - , defaultUploadSettings - , setUploadUrl - , setCredsSource - , setSaveCreds + , uploadRevision -- * Credentials , HackageCreds , loadCreds - , saveCreds - , FromFile - -- ** Credentials source - , HackageCredsSource - , fromAnywhere - , fromPrompt - , fromFile - , fromMemory ) where import Control.Applicative -import Control.Exception (bracket) +import Control.Exception.Safe (handleIO, tryIO) import qualified Control.Exception as E -import Control.Monad (when) +import Control.Monad (void, when, unless) import Data.Aeson (FromJSON (..), ToJSON (..), - eitherDecode', encode, + decode', encode, object, withObject, (.:), (.=)) import qualified Data.ByteString.Char8 as S @@ -44,26 +30,32 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.IO as TIO -import Data.Typeable (Typeable) import Network.HTTP.Client (Response, - RequestBody(RequestBodyLBS)) + RequestBody(RequestBodyLBS), + Request) import Network.HTTP.Simple (withResponse, getResponseStatusCode, getResponseBody, setRequestHeader, - parseRequest) -import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody) + parseRequest, + httpNoBody) +import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody, + partBS, partLBS) import Network.HTTP.Client.TLS (getGlobalManager, applyDigestAuth, displayDigestAuthException) import Path (toFilePath) import Prelude -- Fix redundant import warnings import Stack.Types.Config +import Stack.Types.PackageIdentifier (PackageIdentifier, packageIdentifierString, + packageIdentifierName) +import Stack.Types.PackageName (packageNameString) +import Stack.Types.StringError import System.Directory (createDirectoryIfMissing, removeFile) import System.FilePath ((), takeFileName) -import System.IO (hFlush, hGetEcho, hSetEcho, - stdin, stdout) +import System.IO (hFlush, stdout) +import System.IO.Echo (withoutInputEcho) -- | Username and password to log into Hackage. -- @@ -71,62 +63,52 @@ data HackageCreds = HackageCreds { hcUsername :: !Text , hcPassword :: !Text + , hcCredsFile :: !FilePath } deriving Show instance ToJSON HackageCreds where - toJSON (HackageCreds u p) = object + toJSON (HackageCreds u p _) = object [ "username" .= u , "password" .= p ] -instance FromJSON HackageCreds where +instance FromJSON (FilePath -> HackageCreds) where parseJSON = withObject "HackageCreds" $ \o -> HackageCreds <$> o .: "username" <*> o .: "password" --- | A source for getting Hackage credentials. --- --- Since 0.1.0.0 -newtype HackageCredsSource = HackageCredsSource - { getCreds :: IO (HackageCreds, FromFile) - } - --- | Whether the Hackage credentials were loaded from a file. --- --- This information is useful since, typically, you only want to save the --- credentials to a file if it wasn't already loaded from there. --- --- Since 0.1.0.0 -type FromFile = Bool - --- | Load Hackage credentials from the given source. --- --- Since 0.1.0.0 -loadCreds :: HackageCredsSource -> IO (HackageCreds, FromFile) -loadCreds = getCreds - --- | Save the given credentials to the credentials file. --- --- Since 0.1.0.0 -saveCreds :: Config -> HackageCreds -> IO () -saveCreds config creds = do - fp <- credsFile config - L.writeFile fp $ encode creds - --- | Load the Hackage credentials from the prompt, asking the user to type them --- in. +-- | Load Hackage credentials, either from a save file or the command +-- line. -- -- Since 0.1.0.0 -fromPrompt :: HackageCredsSource -fromPrompt = HackageCredsSource $ do - putStr "Hackage username: " - hFlush stdout - username <- TIO.getLine - password <- promptPassword - return (HackageCreds - { hcUsername = username - , hcPassword = password - }, False) +loadCreds :: Config -> IO HackageCreds +loadCreds config = do + fp <- credsFile config + elbs <- tryIO $ L.readFile fp + case either (const Nothing) Just elbs >>= decode' of + Nothing -> fromPrompt fp + Just mkCreds -> do + unless (configSaveHackageCreds config) $ do + putStrLn "WARNING: You've set save-hackage-creds to false" + putStrLn "However, credentials were found at:" + putStrLn $ " " ++ fp + return $ mkCreds fp + where + fromPrompt fp = do + when (configSaveHackageCreds config) $ do + putStrLn "NOTE: Username and password will be saved in a local file" + putStrLn "You can modify this behavior with the save-hackage-creds config option" + putStr "Hackage username: " + hFlush stdout + username <- TIO.getLine + password <- promptPassword + let hc = HackageCreds + { hcUsername = username + , hcPassword = password + , hcCredsFile = fp + } + L.writeFile fp (encode hc) + return hc credsFile :: Config -> IO FilePath credsFile config = do @@ -134,181 +116,96 @@ createDirectoryIfMissing True dir return $ dir "credentials.json" --- | Load the Hackage credentials from the JSON config file. --- --- Since 0.1.0.0 -fromFile :: Config -> HackageCredsSource -fromFile config = HackageCredsSource $ do - fp <- credsFile config - lbs <- L.readFile fp - case eitherDecode' lbs of - Left e -> E.throwIO $ Couldn'tParseJSON fp e - Right creds -> return (creds, True) - --- | Load the Hackage credentials from the given arguments. --- --- Since 0.1.0.0 -fromMemory :: Text -> Text -> HackageCredsSource -fromMemory u p = HackageCredsSource $ return (HackageCreds - { hcUsername = u - , hcPassword = p - }, False) - -data HackageCredsExceptions = Couldn'tParseJSON FilePath String - deriving (Show, Typeable) -instance E.Exception HackageCredsExceptions - --- | Try to load the credentials from the config file. If that fails, ask the --- user to enter them. --- --- Since 0.1.0.0 -fromAnywhere :: Config -> HackageCredsSource -fromAnywhere config = HackageCredsSource $ - getCreds (fromFile config) `E.catches` - [ E.Handler $ \(_ :: E.IOException) -> getCreds fromPrompt - , E.Handler $ \(_ :: HackageCredsExceptions) -> getCreds fromPrompt - ] - -- | Lifted from cabal-install, Distribution.Client.Upload promptPassword :: IO Text promptPassword = do putStr "Hackage password: " hFlush stdout - -- save/restore the terminal echoing status - passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do - hSetEcho stdin False -- no echoing for entering the password - fmap T.pack getLine + -- save/restore the terminal echoing status (no echoing for entering the password) + passwd <- withoutInputEcho $ fmap T.pack getLine putStrLn "" return passwd -nopUploader :: Config -> UploadSettings -> IO Uploader -nopUploader _ _ = return (Uploader nop) - where nop :: String -> L.ByteString -> IO () - nop _ _ = return () - --- | Turn the given settings into an @Uploader@. --- --- Since 0.1.0.0 -mkUploader :: Config -> UploadSettings -> IO Uploader -mkUploader config us = do - (creds, fromFile') <- loadCreds $ usCredsSource us config - when (not fromFile' && usSaveCreds us) $ saveCreds config creds - req0 <- parseRequest $ usUploadUrl us - let req1 = setRequestHeader "Accept" ["text/plain"] req0 - return Uploader - { upload_ = \tarName bytes -> do - let formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)] - req2 <- formDataBody formData req1 - manager <- getGlobalManager - ereq3 <- applyDigestAuth - (encodeUtf8 $ hcUsername creds) - (encodeUtf8 $ hcPassword creds) - req2 - manager - req3 <- - case ereq3 of - Left e -> do - putStrLn "WARNING: No HTTP digest prompt found, this will probably fail" - case E.fromException e of - Just e' -> putStrLn $ displayDigestAuthException e' - Nothing -> print e - return req2 - Right req3 -> return req3 - putStr $ "Uploading " ++ tarName ++ "... " - hFlush stdout - withResponse req3 $ \res -> - case getResponseStatusCode res of - 200 -> putStrLn "done!" - 401 -> do - putStrLn "authentication failure" - cfp <- credsFile config - handleIO (const $ return ()) (removeFile cfp) - error "Authentication failure uploading to server" - 403 -> do - putStrLn "forbidden upload" - putStrLn "Usually means: you've already uploaded this package/version combination" - putStrLn "Ignoring error and continuing, full message from Hackage below:\n" - printBody res - 503 -> do - putStrLn "service unavailable" - putStrLn "This error some times gets sent even though the upload succeeded" - putStrLn "Check on Hackage to see if your pacakge is present" - printBody res - code -> do - putStrLn $ "unhandled status code: " ++ show code - printBody res - error $ "Upload failed on " ++ tarName - } - -printBody :: Response (ConduitM () S.ByteString IO ()) -> IO () -printBody res = runConduit $ getResponseBody res .| CB.sinkHandle stdout - --- | The computed value from a @UploadSettings@. --- --- Typically, you want to use this with 'upload'. --- --- Since 0.1.0.0 -newtype Uploader = Uploader - { upload_ :: String -> L.ByteString -> IO () - } - --- | Upload a single tarball with the given @Uploader@. --- --- Since 0.1.0.0 -upload :: Uploader -> FilePath -> IO () -upload uploader fp = upload_ uploader (takeFileName fp) =<< L.readFile fp +applyCreds :: HackageCreds -> Request -> IO Request +applyCreds creds req0 = do + manager <- getGlobalManager + ereq <- applyDigestAuth + (encodeUtf8 $ hcUsername creds) + (encodeUtf8 $ hcPassword creds) + req0 + manager + case ereq of + Left e -> do + putStrLn "WARNING: No HTTP digest prompt found, this will probably fail" + case E.fromException e of + Just e' -> putStrLn $ displayDigestAuthException e' + Nothing -> print e + return req0 + Right req -> return req -- | Upload a single tarball with the given @Uploader@. Instead of -- sending a file like 'upload', this sends a lazy bytestring. -- -- Since 0.1.2.1 -uploadBytes :: Uploader -> String -> L.ByteString -> IO () -uploadBytes = upload_ - --- | Settings for creating an @Uploader@. --- --- Since 0.1.0.0 -data UploadSettings = UploadSettings - { usUploadUrl :: !String - , usCredsSource :: !(Config -> HackageCredsSource) - , usSaveCreds :: !Bool - } - --- | Default value for @UploadSettings@. --- --- Use setter functions to change defaults. --- --- Since 0.1.0.0 -defaultUploadSettings :: UploadSettings -defaultUploadSettings = UploadSettings - { usUploadUrl = "https://hackage.haskell.org/packages/" - , usCredsSource = fromAnywhere - , usSaveCreds = True - } - --- | Change the upload URL. --- --- Default: "https://hackage.haskell.org/packages/" --- --- Since 0.1.0.0 -setUploadUrl :: String -> UploadSettings -> UploadSettings -setUploadUrl x us = us { usUploadUrl = x } +uploadBytes :: HackageCreds + -> String -- ^ tar file name + -> L.ByteString -- ^ tar file contents + -> IO () +uploadBytes creds tarName bytes = do + let req1 = setRequestHeader "Accept" ["text/plain"] + "https://hackage.haskell.org/packages/" + formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)] + req2 <- formDataBody formData req1 + req3 <- applyCreds creds req2 + putStr $ "Uploading " ++ tarName ++ "... " + hFlush stdout + withResponse req3 $ \res -> + case getResponseStatusCode res of + 200 -> putStrLn "done!" + 401 -> do + putStrLn "authentication failure" + handleIO (const $ return ()) (removeFile (hcCredsFile creds)) + throwString "Authentication failure uploading to server" + 403 -> do + putStrLn "forbidden upload" + putStrLn "Usually means: you've already uploaded this package/version combination" + putStrLn "Ignoring error and continuing, full message from Hackage below:\n" + printBody res + 503 -> do + putStrLn "service unavailable" + putStrLn "This error some times gets sent even though the upload succeeded" + putStrLn "Check on Hackage to see if your pacakge is present" + printBody res + code -> do + putStrLn $ "unhandled status code: " ++ show code + printBody res + throwString $ "Upload failed on " ++ tarName --- | How to get the Hackage credentials. --- --- Default: @fromAnywhere@ --- --- Since 0.1.0.0 -setCredsSource :: (Config -> HackageCredsSource) -> UploadSettings -> UploadSettings -setCredsSource x us = us { usCredsSource = x } +printBody :: Response (ConduitM () S.ByteString IO ()) -> IO () +printBody res = runConduit $ getResponseBody res .| CB.sinkHandle stdout --- | Save new credentials to the config file. --- --- Default: @True@ +-- | Upload a single tarball with the given @Uploader@. -- -- Since 0.1.0.0 -setSaveCreds :: Bool -> UploadSettings -> UploadSettings -setSaveCreds x us = us { usSaveCreds = x } +upload :: HackageCreds -> FilePath -> IO () +upload creds fp = uploadBytes creds (takeFileName fp) =<< L.readFile fp -handleIO :: (E.IOException -> IO a) -> IO a -> IO a -handleIO = E.handle +uploadRevision :: HackageCreds + -> PackageIdentifier + -> L.ByteString + -> IO () +uploadRevision creds ident cabalFile = do + req0 <- parseRequest $ concat + [ "https://hackage.haskell.org/package/" + , packageIdentifierString ident + , "/" + , packageNameString $ packageIdentifierName ident + , ".cabal/edit" + ] + req1 <- formDataBody + [ partLBS "cabalfile" cabalFile + , partBS "publish" "on" + ] + req0 + req2 <- applyCreds creds req1 + void $ httpNoBody req2 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 @@ -423,11 +423,11 @@ mkEnvOverride platform . Map.fromList . map (T.pack *** T.pack) -newtype PathException = PathsInvalidInPath [FilePath] +newtype InvalidPathException = PathsInvalidInPath [FilePath] deriving Typeable -instance Exception PathException -instance Show PathException where +instance Exception InvalidPathException +instance Show InvalidPathException where show (PathsInvalidInPath paths) = unlines $ [ "Would need to add some paths to the PATH environment variable \ \to continue, but they would be invalid because they contain a " diff --git a/src/Text/PrettyPrint/Leijen/Extended.hs b/src/Text/PrettyPrint/Leijen/Extended.hs --- a/src/Text/PrettyPrint/Leijen/Extended.hs +++ b/src/Text/PrettyPrint/Leijen/Extended.hs @@ -232,7 +232,7 @@ displayDecoratedWrap f doc = do (mafter, result) <- go doc case mafter of - Just _ -> fail "Invariant violated by input to displayDecoratedWrap: no matching SAnnotStart for SAnnotStop." + Just _ -> error "Invariant violated by input to displayDecoratedWrap: no matching SAnnotStart for SAnnotStop." Nothing -> return result where spaces n = LTB.fromText (T.replicate n " ") 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 Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping)) import Data.Attoparsec.Interpreter (getInterpreterArgs) import qualified Data.ByteString.Lazy as L +import Data.IORef.RunOnce (runOnce) import Data.List import qualified Data.Map as Map import Data.Maybe @@ -81,17 +82,19 @@ import Stack.Options.ExecParser import Stack.Options.GhciParser import Stack.Options.GlobalParser + import Stack.Options.HpcReportParser import Stack.Options.NewParser import Stack.Options.NixParser import Stack.Options.ScriptParser +import Stack.Options.SDistParser import Stack.Options.SolverParser import Stack.Options.Utils import qualified Stack.PackageIndex import qualified Stack.Path import Stack.Runners import Stack.Script -import Stack.SDist (getSDistTarball, checkSDistTarball, checkSDistTarball') +import Stack.SDist (getSDistTarball, checkSDistTarball, checkSDistTarball', SDistOpts(..)) import Stack.SetupCmd import qualified Stack.Sig as Sig import Stack.Solver (solveExtraDeps) @@ -101,6 +104,7 @@ import Stack.Types.Resolver import Stack.Types.Nix import Stack.Types.StackT +import Stack.Types.StringError import Stack.Upgrade import qualified Stack.Upload as Upload import qualified System.Directory as D @@ -168,7 +172,8 @@ (nixOptsParser False) ("Only showing --" ++ Nix.nixCmdName ++ "* options.") - eGlobalRun <- try $ commandLineHandler progName False + currentDir <- D.getCurrentDirectory + eGlobalRun <- try $ commandLineHandler currentDir progName False case eGlobalRun of Left (exitCode :: ExitCode) -> throwIO exitCode @@ -197,10 +202,11 @@ ParserHelp (vcatChunks [e2, e1]) h2 u2 b2 f2 commandLineHandler - :: String + :: FilePath + -> String -> Bool -> IO (GlobalOptsMonoid, GlobalOpts -> IO ()) -commandLineHandler progName isInterpreter = complicatedOptions +commandLineHandler currentDir progName isInterpreter = complicatedOptions Meta.version (Just versionString') VERSION_hpack @@ -216,7 +222,7 @@ Just _ -> if isInterpreter then parseResultHandler args f else secondaryCommandHandler args f - >>= interpreterHandler args + >>= interpreterHandler currentDir args Nothing -> parseResultHandler args f parseResultHandler args f = @@ -295,26 +301,12 @@ "upload" "Upload a package to Hackage" uploadCmd - ((,,,,) <$> many (strArgument $ metavar "TARBALL/DIR") <*> - optional pvpBoundsOption <*> - ignoreCheckSwitch <*> - switch (long "no-signature" <> help "Do not sign & upload signatures") <*> - strOption - (long "sig-server" <> metavar "URL" <> showDefault <> - value "https://sig.commercialhaskell.org" <> - help "URL")) + (sdistOptsParser True) addCommand' "sdist" "Create source distribution tarballs" sdistCmd - ((,,,,) <$> many (strArgument $ metavar "DIR") <*> - optional pvpBoundsOption <*> - ignoreCheckSwitch <*> - switch (long "sign" <> help "Sign & upload signatures") <*> - strOption - (long "sig-server" <> metavar "URL" <> showDefault <> - value "https://sig.commercialhaskell.org" <> - help "URL")) + (sdistOptsParser False) addCommand' "dot" "Visualize your project's dependency graph using Graphviz dot" dotCmd @@ -443,10 +435,6 @@ hpcReportOptsParser) ) where - ignoreCheckSwitch = - switch (long "ignore-check" - <> help "Do not check package for common mistakes") - -- addCommand hiding global options addCommand' :: String -> String -> (a -> GlobalOpts -> IO ()) -> Parser a -> AddCommand @@ -474,10 +462,11 @@ globalOpts kind = extraHelpOption hide progName (Docker.dockerCmdName ++ "*") Docker.dockerHelpOptName <*> extraHelpOption hide progName (Nix.nixCmdName ++ "*") Nix.nixHelpOptName <*> - globalOptsParser kind (if isInterpreter - -- Silent except when errors occur - see #2879 - then Just LevelError - else Nothing) + globalOptsParser currentDir kind + (if isInterpreter + -- Silent except when errors occur - see #2879 + then Just LevelError + else Nothing) where hide = kind /= OuterGlobalOpts globalFooter = "Run 'stack --help' for global options that apply to all subcommands." @@ -516,10 +505,11 @@ interpreterHandler :: Monoid t - => [String] + => FilePath + -> [String] -> ParserFailure ParserHelp -> IO (GlobalOptsMonoid, (GlobalOpts -> IO (), t)) -interpreterHandler args f = do +interpreterHandler currentDir args f = do -- args can include top-level config such as --extra-lib-dirs=... (set by -- nix-shell) - we need to find the first argument which is a file, everything -- afterwards is an argument to the script, everything before is an argument @@ -559,7 +549,7 @@ runInterpreterCommand path stackArgs fileArgs = do progName <- getProgName iargs <- getInterpreterArgs path - let parseCmdLine = commandLineHandler progName True + let parseCmdLine = commandLineHandler currentDir progName True separator = if "--" `elem` iargs then [] else ["--"] cmdArgs = stackArgs ++ iargs ++ separator ++ path : fileArgs -- TODO show the command in verbose mode @@ -574,7 +564,7 @@ setupCmd :: SetupCmdOpts -> GlobalOpts -> IO () setupCmd sco@SetupCmdOpts{..} go@GlobalOpts{..} = do lc <- loadConfigWithOpts go - when (scoUpgradeCabal && nixEnable (configNix (lcConfig lc))) $ do + when (isJust scoUpgradeCabal && nixEnable (configNix (lcConfig lc))) $ do throwIO UpgradeCabalUnusable withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> do let getCompilerVersion = loadCompilerVersion go lc @@ -602,16 +592,16 @@ (Just $ munlockFile lk) cleanCmd :: CleanOpts -> GlobalOpts -> IO () -cleanCmd opts go = withBuildConfigAndLock go (const (clean opts)) +cleanCmd opts go = withBuildConfigAndLockNoDocker go (const (clean opts)) -- | Helper for build and install commands buildCmd :: BuildOptsCLI -> GlobalOpts -> IO () buildCmd opts go = do when (any (("-prof" `elem`) . either (const []) id . parseArgs Escaping) (boptsCLIGhcOptions opts)) $ do - hPutStrLn stderr "When building with stack, you should not use the -prof GHC option" + hPutStrLn stderr "Error: When building with stack, you should not use the -prof GHC option" 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" + exitFailure case boptsCLIFileWatch opts of FileWatchPoll -> fileWatchPoll stderr inner FileWatch -> fileWatch stderr inner @@ -631,12 +621,11 @@ uninstallCmd _ go = withConfigAndLock go $ do $logError "stack does not manage installations in global locations" $logError "The only global mutation stack performs is executable copying" - $logError "For the default executable destination, please run 'stack path --local-bin-path'" + $logError "For the default executable destination, please run 'stack path --local-bin'" -- | Unpack packages to the filesystem unpackCmd :: [String] -> GlobalOpts -> IO () unpackCmd names go = withConfigAndLock go $ do - menv <- getMinimalEnvOverride mMiniBuildPlan <- case globalResolver go of Nothing -> return Nothing @@ -647,14 +636,13 @@ config <- view configL let miniConfig = loadMiniConfig config runInnerStackT miniConfig (loadMiniBuildPlan snapName) - ResolverCompiler _ -> error "unpack does not work with compiler resolvers" - ResolverCustom _ _ -> error "unpack does not work with custom resolvers" - Stack.Fetch.unpackPackages menv mMiniBuildPlan "." names + ResolverCompiler _ -> throwString "Error: unpack does not work with compiler resolvers" + ResolverCustom _ _ -> throwString "Error: unpack does not work with custom resolvers" + Stack.Fetch.unpackPackages mMiniBuildPlan "." names -- | Update the package index updateCmd :: () -> GlobalOpts -> IO () -updateCmd () go = withConfigAndLock go $ - getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices +updateCmd () go = withConfigAndLock go Stack.PackageIndex.updateAllIndices upgradeCmd :: UpgradeOpts -> GlobalOpts -> IO () upgradeCmd upgradeOpts' go = withGlobalConfigAndLock go $ @@ -668,70 +656,72 @@ upgradeOpts' -- | Upload to Hackage -uploadCmd :: ([String], Maybe PvpBounds, Bool, Bool, String) -> GlobalOpts -> IO () -uploadCmd ([], _, _, _, _) _ = error "To upload the current package, please run 'stack upload .'" -uploadCmd (args, mpvpBounds, ignoreCheck, don'tSign, sigServerUrl) go = do +uploadCmd :: SDistOpts -> GlobalOpts -> IO () +uploadCmd (SDistOpts [] _ _ _ _ _) _ = throwString "Error: To upload the current package, please run 'stack upload .'" +uploadCmd sdistOpts go = do let partitionM _ [] = return ([], []) partitionM f (x:xs) = do r <- f x (as, bs) <- partitionM f xs return $ if r then (x:as, bs) else (as, x:bs) - (files, nonFiles) <- partitionM D.doesFileExist args + (files, nonFiles) <- partitionM D.doesFileExist (sdoptsDirsToWorkWith sdistOpts) (dirs, invalid) <- partitionM D.doesDirectoryExist nonFiles - unless (null invalid) $ error $ - "stack upload expects a list sdist tarballs or cabal directories. Can't find " ++ - show invalid - let getUploader :: (HasConfig config) => StackT config IO Upload.Uploader - getUploader = do - config <- view configL - liftIO $ Upload.mkUploader config Upload.defaultUploadSettings + unless (null invalid) $ do + hPutStrLn stderr $ + "Error: stack upload expects a list sdist tarballs or cabal directories. Can't find " ++ + show invalid + exitFailure withBuildConfigAndLock go $ \_ -> do - uploader <- getUploader - unless ignoreCheck $ - mapM_ (resolveFile' >=> checkSDistTarball) files + config <- view configL + getCreds <- liftIO (runOnce (Upload.loadCreds config)) + mapM_ (resolveFile' >=> checkSDistTarball sdistOpts) files forM_ files (\file -> do tarFile <- resolveFile' file - liftIO - (Upload.upload uploader (toFilePath tarFile)) - unless - don'tSign + liftIO $ do + creds <- getCreds + Upload.upload creds (toFilePath tarFile) + when + (sdoptsSign sdistOpts) (void $ Sig.sign - sigServerUrl + (sdoptsSignServerUrl sdistOpts) tarFile)) unless (null dirs) $ forM_ dirs $ \dir -> do pkgDir <- resolveDir' dir - (tarName, tarBytes) <- getSDistTarball mpvpBounds pkgDir - unless ignoreCheck $ checkSDistTarball' tarName tarBytes - liftIO $ Upload.uploadBytes uploader tarName tarBytes + (tarName, tarBytes, mcabalRevision) <- getSDistTarball (sdoptsPvpBounds sdistOpts) pkgDir + checkSDistTarball' sdistOpts tarName tarBytes + liftIO $ do + creds <- getCreds + Upload.uploadBytes creds tarName tarBytes + forM_ mcabalRevision $ uncurry $ Upload.uploadRevision creds tarPath <- parseRelFile tarName - unless - don'tSign + when + (sdoptsSign sdistOpts) (void $ Sig.signTarBytes - sigServerUrl + (sdoptsSignServerUrl sdistOpts) tarPath tarBytes) -sdistCmd :: ([String], Maybe PvpBounds, Bool, Bool, String) -> GlobalOpts -> IO () -sdistCmd (dirs, mpvpBounds, ignoreCheck, sign, sigServerUrl) go = +sdistCmd :: SDistOpts -> GlobalOpts -> IO () +sdistCmd sdistOpts go = withBuildConfig go $ do -- No locking needed. -- If no directories are specified, build all sdist tarballs. - dirs' <- if null dirs + dirs' <- if null (sdoptsDirsToWorkWith sdistOpts) then liftM Map.keys getLocalPackages - else mapM resolveDir' dirs + else mapM resolveDir' (sdoptsDirsToWorkWith sdistOpts) forM_ dirs' $ \dir -> do - (tarName, tarBytes) <- getSDistTarball mpvpBounds dir + (tarName, tarBytes, _mcabalRevision) <- getSDistTarball (sdoptsPvpBounds sdistOpts) dir distDir <- distDirFromDir dir tarPath <- (distDir ) <$> parseRelFile tarName ensureDir (parent tarPath) liftIO $ L.writeFile (toFilePath tarPath) tarBytes - unless ignoreCheck (checkSDistTarball tarPath) + checkSDistTarball sdistOpts tarPath $logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath) - when sign (void $ Sig.sign sigServerUrl tarPath) + when (sdoptsSign sdistOpts) (void $ Sig.sign (sdoptsSignServerUrl sdistOpts) tarPath) -- | Execute a command. execCmd :: ExecOpts -> GlobalOpts -> IO () @@ -771,7 +761,7 @@ config <- view configL menv <- liftIO $ configEnvOverride config eoEnvSettings -- Add RTS options to arguments - let argsWithRts args = if null eoRtsOptions + let argsWithRts args = if null eoRtsOptions then args :: [String] else args ++ ["+RTS"] ++ eoRtsOptions ++ ["-RTS"] (cmd, args) <- case (eoCmd, argsWithRts eoArgs) of @@ -790,7 +780,9 @@ case mId of Just i -> return (head $ words (T.unpack i)) -- should never happen as we have already installed the packages - _ -> error ("Could not find package id of package " ++ name) + _ -> liftIO $ do + hPutStrLn stderr ("Could not find package id of package " ++ name) + exitFailure getPkgOpts menv wc pkgs = do ids <- mapM (getPkgId menv wc) pkgs @@ -800,7 +792,6 @@ wc <- view $ actualCompilerVersionL.whichCompilerL pkgopts <- getPkgOpts menv wc pkgs return (prefix ++ compilerExeName wc, pkgopts ++ args) - -- | Evaluate some haskell code inline. evalCmd :: EvalOpts -> GlobalOpts -> IO () @@ -874,6 +865,7 @@ imgDockerCmd (rebuild,images) go@GlobalOpts{..} = do mProjectRoot <- lcProjectRoot <$> loadConfigWithOpts go withBuildConfigExt + False go Nothing (\lk -> 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 @@ -150,6 +150,9 @@ describe "defaultConfigYaml" $ it "is parseable" $ \_ -> do - let parsed :: Either String (WithJSONWarnings ConfigMonoid) - parsed = decodeEither defaultConfigYaml - isRight parsed `shouldBe` True + curDir <- getCurrentDir + let parsed :: Either String (Either String (WithJSONWarnings ConfigMonoid)) + parsed = parseEither (parseConfigMonoid curDir) <$> decodeEither defaultConfigYaml + case parsed of + Right (Right _) -> return () :: IO () + _ -> fail "Failed to parse default config yaml" diff --git a/src/test/Stack/GhciSpec.hs b/src/test/Stack/GhciSpec.hs --- a/src/test/Stack/GhciSpec.hs +++ b/src/test/Stack/GhciSpec.hs @@ -13,6 +13,7 @@ import qualified Data.Text.Encoding as T import Distribution.License (License (BSD3)) import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription (BuildType(..)) import Stack.Types.Package import Stack.Types.PackageName import Stack.Types.Version @@ -58,40 +59,44 @@ describe "Script rendering" $ do describe "should render GHCi scripts" $ do it "with one library package" $ do - let res = scriptToLazyByteString $ renderScriptGhci packages_singlePackage Nothing + let res = scriptToLazyByteString $ renderScriptGhci packages_singlePackage Nothing [] res `shouldBeLE` ghciScript_projectWithLib it "with one main package" $ do let res = scriptToLazyByteString $ renderScriptGhci [] (Just absFile) + [] res `shouldBeLE` ghciScript_projectWithMain it "with one library and main package" $ do let res = scriptToLazyByteString $ renderScriptGhci packages_singlePackage (Just absFile) + [] res `shouldBeLE` ghciScript_projectWithLibAndMain it "with multiple library packages" $ do - let res = scriptToLazyByteString $ renderScriptGhci packages_multiplePackages Nothing + let res = scriptToLazyByteString $ renderScriptGhci packages_multiplePackages Nothing [] res `shouldBeLE` ghciScript_multipleProjectsWithLib describe "should render intero scripts" $ do it "with one library package" $ do - let res = scriptToLazyByteString $ renderScriptIntero packages_singlePackage Nothing + let res = scriptToLazyByteString $ renderScriptIntero packages_singlePackage Nothing [] res `shouldBeLE` interoScript_projectWithLib it "with one main package" $ do let res = scriptToLazyByteString $ renderScriptIntero packages_singlePackage - (Just absFile) + (Just absFile) + [] res `shouldBeLE` interoScript_projectWithMain it "with one library and main package" $ do let res = scriptToLazyByteString $ renderScriptIntero packages_singlePackage - (Just absFile) + (Just absFile) + [] res `shouldBeLE` interoScript_projectWithLibAndMain it "with multiple library packages" $ do - let res = scriptToLazyByteString $ renderScriptIntero packages_multiplePackages Nothing + let res = scriptToLazyByteString $ renderScriptIntero packages_multiplePackages Nothing [] res `shouldBeLE` interoScript_multipleProjectsWithLib -- Exptected Intero scripts @@ -220,7 +225,7 @@ , packageExes = S.empty , packageOpts = GetPackageOpts undefined , packageHasExposedModules = True - , packageSimpleType = True + , packageBuildType = Just Simple , packageSetupDeps = Nothing } } @@ -255,7 +260,7 @@ , packageExes = S.empty , packageOpts = GetPackageOpts undefined , packageHasExposedModules = True - , packageSimpleType = True + , packageBuildType = Just Simple , packageSetupDeps = Nothing } } @@ -286,7 +291,7 @@ , packageExes = S.empty , packageOpts = GetPackageOpts undefined , packageHasExposedModules = True - , packageSimpleType = True + , packageBuildType = Just Simple , packageSetupDeps = Nothing } } 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 @@ -14,6 +14,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.System (buildPlatform) +import Distribution.License (License(..)) import Prelude -- Fix redundant imports warnings import Stack.PackageDump import Stack.Types.Compiler @@ -83,6 +84,7 @@ haskell2010 `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = packageIdent + , dpLicense = Just BSD3 , dpLibDirs = ["/opt/ghc/7.8.4/lib/ghc-7.8.4/haskell2010-1.1.2.0"] , dpDepends = depends , dpLibraries = ["HShaskell2010-1.1.2.0"] @@ -122,6 +124,7 @@ haskell2010 `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = pkgIdent + , dpLicense = Just BSD3 , 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" @@ -154,6 +157,7 @@ hmatrix `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = pkgId + , dpLicense = Just BSD3 , dpLibDirs = [ "/Users/alexbiehl/.stack/snapshots/x86_64-osx/lts-2.13/7.8.4/lib/x86_64-osx-ghc-7.8.4/hmatrix-0.16.1.5" , "/opt/local/lib/" @@ -187,6 +191,7 @@ ghcBoot `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = pkgId + , dpLicense = Just BSD3 , dpLibDirs = ["/opt/ghc/head/lib/ghc-7.11.20151213/ghc-boot-0.0.0.0"] , dpHaddockInterfaces = ["/opt/ghc/head/share/doc/ghc/html/libraries/ghc-boot-0.0.0.0/ghc-boot.haddock"] diff --git a/src/test/Stack/StoreSpec.hs b/src/test/Stack/StoreSpec.hs --- a/src/test/Stack/StoreSpec.hs +++ b/src/test/Stack/StoreSpec.hs @@ -80,12 +80,12 @@ describe "Roundtrips binary formats" $ do $(smallcheckManyStore False 6 [ [t| InstalledCacheInner |] - , [t| PackageCacheMap |] , [t| BuildCache |] ]) -- Blows up with > 5 $(smallcheckManyStore False 5 - [ [t| MiniBuildPlan |] + [ [t| PackageCacheMap |] + , [t| MiniBuildPlan |] ]) -- Blows up with > 4 $(smallcheckManyStore False 4 diff --git a/stack.cabal b/stack.cabal --- a/stack.cabal +++ b/stack.cabal @@ -1,421 +1,439 @@ -name: stack -version: 1.4.0 -cabal-version: >=1.10 -build-type: Custom -license: BSD3 -license-file: LICENSE -maintainer: manny@fpcomplete.com -homepage: http://haskellstack.org -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/*.md - src/setup-shim/StackSetupShim.hs - 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 +name: stack +version: 1.5.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: Commercial Haskell SIG +maintainer: manny@fpcomplete.com +category: Development +build-type: Custom +cabal-version: >=1.10 +homepage: http://haskellstack.org +extra-source-files: CONTRIBUTING.md + ChangeLog.md + README.md + doc/*.md + src/setup-shim/StackSetupShim.hs -source-repository head - type: git - location: https://github.com/commercialhaskell/stack.git + -- 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 + stack.yaml + +custom-setup + setup-depends: base + , Cabal + , filepath + flag integration-tests - description: - Run the integration test suite - default: False - manual: True + manual: True + default: False + description: Run the integration test suite flag disable-git-info - description: - Disable compile-time inclusion of current git info in stack - default: False - manual: True + manual: True + default: False + description: Disable compile-time inclusion of current git info in stack + -- disabling git info can lead to a quicker workflow in certain + -- scenarios when you're developing on stack itself, but + -- should otherwise be avoided + -- see: https://github.com/commercialhaskell/stack/issues/1425 flag static - description: - Pass -static/-pthread to ghc when linking the stack binary. - default: False - manual: True + manual: True + default: False + description: Pass -static/-pthread to ghc when linking the stack binary. + -- Not intended for general use. Simply makes it easier to + -- build a fully static binary on Linux platforms that enable it. flag hide-dependency-versions - description: - Hides dependency versions from "stack --version", used only by building with stack.yaml - default: False - manual: True + manual: True + default: False + description: Hides dependency versions from "stack --version", used only by building with stack.yaml library - - 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, - pid1 ==0.1.* - exposed-modules: - Control.Concurrent.Execute - Data.Aeson.Extended - Data.Attoparsec.Args - Data.Attoparsec.Combinators - Data.Attoparsec.Interpreter - Data.IORef.RunOnce - Data.Maybe.Extra - Data.Monoid.Extra - Data.Store.VersionTagged - Data.Text.Extra - Distribution.Version.Extra - Network.HTTP.Download - Network.HTTP.Download.Verified - Options.Applicative.Args - Options.Applicative.Builder.Extra - Options.Applicative.Complicated - Path.Extra - Path.Find - Paths_stack - Stack.Build - Stack.Build.Cache - Stack.Build.ConstructPlan - Stack.Build.Execute - Stack.Build.Haddock - Stack.Build.Installed - Stack.Build.Source - Stack.Build.Target - Stack.BuildPlan - Stack.Clean - Stack.Config - Stack.Config.Build - Stack.Config.Urls - Stack.Config.Docker - Stack.Config.Nix - Stack.ConfigCmd - Stack.Constants - Stack.Coverage - Stack.Docker - Stack.Docker.GlobalDB - Stack.Dot - Stack.Exec - Stack.Fetch - Stack.FileWatch - Stack.GhcPkg - Stack.Ghci - Stack.Ghci.Script - Stack.Hoogle - Stack.IDE - Stack.Image - Stack.Init - Stack.New - Stack.Nix - Stack.Options.BenchParser - Stack.Options.BuildMonoidParser - Stack.Options.BuildParser - Stack.Options.CleanParser - Stack.Options.ConfigParser - Stack.Options.DockerParser - Stack.Options.DotParser - Stack.Options.ExecParser - Stack.Options.GhcBuildParser - Stack.Options.GhciParser - Stack.Options.GhcVariantParser - Stack.Options.GlobalParser - Stack.Options.HaddockParser - Stack.Options.HpcReportParser - Stack.Options.LogLevelParser - Stack.Options.NewParser - Stack.Options.NixParser - Stack.Options.PackageParser - Stack.Options.ResolverParser - Stack.Options.ScriptParser - Stack.Options.SolverParser - Stack.Options.TestParser - Stack.Options.Utils - Stack.Package - Stack.PackageDump - Stack.PackageIndex - Stack.Path - Stack.PrettyPrint - Stack.Runners - Stack.Script - Stack.SDist - Stack.Setup - Stack.Setup.Installed - Stack.SetupCmd - Stack.Sig - Stack.Sig.GPG - Stack.Sig.Sign - Stack.Solver - Stack.Types.Build - Stack.Types.BuildPlan - Stack.Types.CompilerBuild - Stack.Types.Urls - Stack.Types.Compiler - Stack.Types.Config - Stack.Types.Config.Build - Stack.Types.Docker - Stack.Types.FlagName - Stack.Types.GhcPkgId - Stack.Types.Image - Stack.Types.Internal - Stack.Types.Nix - Stack.Types.Package - Stack.Types.PackageDump - Stack.Types.PackageIdentifier - Stack.Types.PackageIndex - Stack.Types.PackageName - Stack.Types.Resolver - Stack.Types.Sig - Stack.Types.StackT - Stack.Types.TemplateName - Stack.Types.Version - Stack.Upgrade - Stack.Upload - Text.PrettyPrint.Leijen.Extended - System.Process.Log - System.Process.PagerEditor - System.Process.Read - System.Process.Run - build-depends: - Cabal ==1.24.*, - aeson >=1.0 && <1.2, - ansi-terminal >=0.6.2.3 && <0.7, - async >=2.0.2 && <2.2, - attoparsec >=0.12.1.5 && <0.14, - base >=4.8 && <5, - base-compat >=0.6 && <0.10, - base64-bytestring >=1.0.0.1 && <1.1, - binary >=0.7 && <0.9, - binary-tagged >=0.1.1 && <0.2, - blaze-builder >=0.4.0.2 && <0.5, - bytestring >=0.10.4.0 && <0.11, - clock >=0.7.2 && <0.8, - conduit >=1.2.8 && <1.3, - conduit-extra >=1.1.14 && <1.2, - containers >=0.5.5.1 && <0.6, - cryptonite ==0.19.*, - cryptonite-conduit ==0.1.*, - directory >=1.2.1.0 && <1.4, - either >=4.4.1.1 && <4.5, - errors >=2.1.2 && <2.2, - exceptions >=0.8.0.2 && <0.9, - extra >=1.4.10 && <1.6, - 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, - generic-deriving >=1.10.5 && <1.12, - hackage-security >=0.5.2.2 && <0.6, - hashable >=1.2.3.2 && <1.3, - hit >=0.6.3 && <0.7, - hpc >=0.6.0.2 && <0.7, - http-client >=0.5.3.3 && <0.6, - http-client-tls >=0.3.4 && <0.4, - http-conduit >=2.2.3 && <2.3, - http-types >=0.8.6 && <0.10, - lifted-async >=0.9.0 && <0.10, - lifted-base >=0.2.3.8 && <0.3, - memory ==0.13.*, - microlens >=0.3.0.0 && <0.5, - microlens-mtl >=0.1.10.0 && <0.2, - monad-control >=1.0.1.0 && <1.1, - monad-logger >=0.3.13.1 && <0.4, - monad-unlift >=0.2.0 && <0.3, - mtl >=2.1.3.1 && <2.3, - network-uri >=2.6.1.0 && <2.7, - open-browser >=0.2.1 && <0.3, - optparse-applicative ==0.13.*, - path >=0.5.8 && <0.6, - path-io >=1.1.0 && <2.0.0, - persistent >=2.1.2 && <2.7, - persistent-sqlite >=2.1.4 && <2.5.0.1 || >2.5.0.1 && <2.7, - persistent-template >=2.1.1 && <2.6, - pretty >=1.1.1.1 && <1.2, - process >=1.2.1.0 && <1.5, - regex-applicative-text >=0.1.0.1 && <0.2, - resourcet >=1.1.4.1 && <1.2, - retry >=0.6 && <0.8, - safe ==0.3.*, - safe-exceptions >=0.1.4.0 && <0.2, - semigroups >=0.5 && <0.19, - split >=0.2.3.1 && <0.3, - stm >=2.4.4 && <2.5, - streaming-commons >=0.1.10.0 && <0.2, - tar >=0.5.0.3 && <0.6, - template-haskell >=2.9.0.0 && <2.12, - temporary >=1.2.0.3 && <1.3, - text >=1.2.0.4 && <1.3, - text-binary >=0.2.1.1 && <0.3, - text-metrics >=0.1 && <0.3, - time >=1.4.2 && <1.7, - tls >=1.3.8 && <1.4, - transformers >=0.3.0.0 && <0.6, - transformers-base >=0.4.4 && <0.5, - unicode-transforms >=0.1 && <0.4, - unix-compat >=0.4.1.4 && <0.5, - unordered-containers >=0.2.5.1 && <0.3, - vector >=0.10.12.3 && <0.13, - vector-binary-instances >=0.2.3.2 && <0.3, - yaml >=0.8.20 && <0.9, - zlib >=0.5.4.2 && <0.7, - deepseq ==1.4.*, - hastache >=0.6.1 && <0.7, - project-template ==0.2.*, - zip-archive >=0.2.3.7 && <0.4, - hpack >=0.17.0 && <0.18, - store >=0.2.1.0 && <0.4, - annotated-wl-pprint >=0.7.0 && <0.8, - file-embed >=0.0.10 && <0.1 - default-language: Haskell2010 - hs-source-dirs: src/ - other-modules: - Hackage.Security.Client.Repository.HttpLib.HttpClient - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-identities + hs-source-dirs: src/ + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-identities + exposed-modules: Control.Concurrent.Execute + Data.Aeson.Extended + Data.Attoparsec.Args + Data.Attoparsec.Combinators + Data.Attoparsec.Interpreter + Data.IORef.RunOnce + Data.Maybe.Extra + Data.Monoid.Extra + Data.Store.VersionTagged + Data.Text.Extra + Distribution.Version.Extra + Network.HTTP.Download + Network.HTTP.Download.Verified + Options.Applicative.Args + Options.Applicative.Builder.Extra + Options.Applicative.Complicated + Path.CheckInstall + Path.Extra + Path.Find + Paths_stack + Stack.Build + Stack.Build.Cache + Stack.Build.ConstructPlan + Stack.Build.Execute + Stack.Build.Haddock + Stack.Build.Installed + Stack.Build.Source + Stack.Build.Target + Stack.BuildPlan + Stack.Clean + Stack.Config + Stack.Config.Build + Stack.Config.Urls + Stack.Config.Docker + Stack.Config.Nix + Stack.ConfigCmd + Stack.Constants + Stack.Coverage + Stack.Docker + Stack.Docker.GlobalDB + Stack.Dot + Stack.Exec + Stack.Fetch + Stack.FileWatch + Stack.GhcPkg + Stack.Ghci + Stack.Ghci.Script + Stack.Hoogle + Stack.IDE + Stack.Image + Stack.Init + Stack.New + Stack.Nix + Stack.Options.BenchParser + Stack.Options.BuildMonoidParser + Stack.Options.BuildParser + Stack.Options.CleanParser + Stack.Options.ConfigParser + Stack.Options.Completion + Stack.Options.DockerParser + Stack.Options.DotParser + Stack.Options.ExecParser + Stack.Options.GhcBuildParser + Stack.Options.GhciParser + Stack.Options.GhcVariantParser + Stack.Options.GlobalParser + Stack.Options.HaddockParser + Stack.Options.HpcReportParser + Stack.Options.LogLevelParser + Stack.Options.NewParser + Stack.Options.NixParser + Stack.Options.PackageParser + Stack.Options.ResolverParser + Stack.Options.ScriptParser + Stack.Options.SDistParser + Stack.Options.SolverParser + Stack.Options.TestParser + Stack.Options.Utils + Stack.Package + Stack.PackageDump + Stack.PackageIndex + Stack.Path + Stack.PrettyPrint + Stack.Runners + Stack.Script + Stack.SDist + Stack.Setup + Stack.Setup.Installed + Stack.SetupCmd + Stack.Sig + Stack.Sig.GPG + Stack.Sig.Sign + Stack.Solver + Stack.Types.Build + Stack.Types.BuildPlan + Stack.Types.CompilerBuild + Stack.Types.Urls + Stack.Types.Compiler + Stack.Types.Config + Stack.Types.Config.Build + Stack.Types.Docker + Stack.Types.FlagName + Stack.Types.GhcPkgId + Stack.Types.Image + Stack.Types.Internal + Stack.Types.Nix + Stack.Types.Package + Stack.Types.PackageDump + Stack.Types.PackageIdentifier + Stack.Types.PackageIndex + Stack.Types.PackageName + Stack.Types.Resolver + Stack.Types.Sig + Stack.Types.StackT + Stack.Types.StringError + Stack.Types.TemplateName + Stack.Types.Version + Stack.Upgrade + Stack.Upload + Text.PrettyPrint.Leijen.Extended + System.Process.Log + System.Process.PagerEditor + System.Process.Read + System.Process.Run + other-modules: Hackage.Security.Client.Repository.HttpLib.HttpClient + build-depends: Cabal >= 1.24 && < 1.25 + , aeson (>= 1.0 && < 1.2) + , ansi-terminal >= 0.6.2.3 + , async >= 2.0.2 && < 2.2 + , attoparsec >= 0.12.1.5 && < 0.14 + , base >= 4.8 && <5 + , base-compat >=0.6 && <0.10 + , base64-bytestring + , binary >= 0.7 && < 0.9 + , binary-tagged >= 0.1.1 + , blaze-builder + , bytestring >= 0.10.4.0 + , clock >= 0.7.2 + , conduit >= 1.2.8 + , conduit-extra >= 1.1.14 + , containers >= 0.5.5.1 + , cryptonite >= 0.19 && < 0.24 + , cryptonite-conduit >= 0.1 && < 0.3 + , directory >= 1.2.1.0 && < 1.4 + , echo >= 0.1.3 && < 0.2 + , either + , errors < 2.3 + , exceptions >= 0.8.0.2 + , extra >= 1.4.10 && < 1.6 + , fast-logger >= 2.3.1 + , filelock >= 0.1.0.1 + , filepath >= 1.3.0.2 + , fsnotify >= 0.2.1 + , generic-deriving >= 1.10.5 && < 1.12 + , ghc-prim >= 0.4.0.0 + , hackage-security + , hashable >= 1.2.3.2 + , hpc >= 0.6.0.2 + , http-client >= 0.5.3.3 + , http-client-tls >= 0.3.4 + , http-conduit >= 2.2.3 + , http-types >= 0.8.6 && < 0.10 + , lifted-async >= 0.9.1.1 + -- https://github.com/basvandijk/lifted-base/issues/31 + , lifted-base < 0.2.3.7 || > 0.2.3.7 + , memory >= 0.13 && < 0.15 + , microlens >= 0.3.0.0 + , microlens-mtl >= 0.1.10.0 + , mintty >= 0.1.1 + , monad-control >= 1.0.1.0 + , monad-logger >= 0.3.13.1 + , monad-unlift < 0.3 + , mtl >= 2.1.3.1 + , network-uri + , open-browser >= 0.2.1 + , optparse-applicative >= 0.13 && < 0.14 + , path >= 0.5.8 && < 0.6 + , path-io >= 1.1.0 && < 2.0.0 + , persistent >= 2.1.2 && < 2.8 + -- persistent-sqlite-2.5.0.1 has a bug + -- (see https://github.com/yesodweb/persistent/pull/561#issuecomment-222329087) + , persistent-sqlite (>= 2.1.4 && < 2.5.0.1) || (> 2.5.0.1 && < 2.7) + , persistent-template >= 2.1.1 && < 2.6 + , pretty >= 1.1.1.1 + , process >= 1.2.1.0 && < 1.5 + , regex-applicative-text >=0.1.0.1 && <0.2 + , resourcet >= 1.1.4.1 + , retry >= 0.6 && < 0.8 + , safe >= 0.3 + , safe-exceptions >= 0.1.5.0 + , semigroups >= 0.5 && < 0.19 + , split + , stm >= 2.4.4 + , streaming-commons >= 0.1.10.0 + , tar >= 0.5.0.3 && < 0.6 + , template-haskell >= 2.9.0.0 && < 2.12 + , temporary >= 1.2.0.3 + , text >= 1.2.0.4 + , text-binary + , text-metrics >= 0.1 && < 0.4 + , time >= 1.4.2 && < 1.7 + , tls >= 1.3.8 + , transformers >= 0.3.0.0 && < 0.6 + , transformers-base >= 0.4.4 + , unicode-transforms >= 0.1 && <0.4 + , unix-compat >= 0.4.1.4 + , unordered-containers >= 0.2.5.1 + , vector >= 0.10.12.3 && < 0.13 + , vector-binary-instances + , yaml >= 0.8.20 + , zlib >= 0.5.4.2 && < 0.7 + , deepseq >= 1.4 + , hastache + , project-template >= 0.2 + , zip-archive >= 0.2.3.7 && < 0.4 + , hpack >= 0.17.0 && < 0.19 + , store >= 0.4.1 && < 0.5 + , store-core >= 0.4 && < 0.5 + , annotated-wl-pprint + , file-embed >= 0.0.10 + if os(windows) + cpp-options: -DWINDOWS + build-depends: Win32 + else + build-depends: unix >= 2.7.0.1 + , pid1 >= 0.1 && < 0.2 + default-language: Haskell2010 executable stack - - if flag(static) - ld-options: -static -pthread - - if os(windows) - build-depends: - Win32 >=2.3.1.0 && <2.4 - cpp-options: -DWINDOWS - - if !flag(disable-git-info) - build-depends: - gitrev >=1.1 && <1.3, - optparse-simple >=0.0.3 && <0.1 - cpp-options: -DUSE_GIT_INFO - - if flag(hide-dependency-versions) - cpp-options: -DHIDE_DEP_VERSIONS - main-is: Main.hs - build-depends: - Cabal >=1.18.1.5 && <1.25, - base >=4.7 && <5, - bytestring >=0.10.4.0 && <0.11, - conduit >=1.2.8 && <1.3, - containers >=0.5.5.1 && <0.6, - directory >=1.2.1.0 && <1.4, - either >=4.4.1.1 && <4.5, - filelock >=0.1.0.1 && <0.2, - filepath >=1.3.0.2 && <1.5, - hpack >=0.17.0 && <0.18, - http-client >=0.5.3.3 && <0.6, - lifted-base >=0.2.3.8 && <0.3, - microlens >=0.3.0.0 && <0.5, - monad-control >=1.0.1.0 && <1.1, - monad-logger >=0.3.13.1 && <0.4, - mtl >=2.1.3.1 && <2.3, - optparse-applicative ==0.13.*, - path >=0.5.8 && <0.6, - path-io >=1.1.0 && <2.0.0, - split >=0.2.3.1 && <0.3, - stack >=1.4.0 && <1.5, - text >=1.2.0.4 && <1.3, - transformers >=0.3.0.0 && <0.6 - default-language: Haskell2010 - hs-source-dirs: src/main - other-modules: - Paths_stack - ghc-options: -threaded -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + hs-source-dirs: src/main + main-is: Main.hs + ghc-options: -threaded -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + other-modules: Paths_stack + if flag(static) + ld-options: -static -pthread + build-depends: Cabal >= 1.18.1.5 && < 1.25 + , base >=4.7 && < 5 + , bytestring >= 0.10.4.0 + , conduit >= 1.2.8 + , containers >= 0.5.5.1 + , directory >= 1.2.1.0 && < 1.4 + , either + , filelock >= 0.1.0.1 + , filepath >= 1.3.0.2 + , hpack >= 0.17.0 && < 0.19 + , http-client >= 0.5.3.3 + -- https://github.com/basvandijk/lifted-base/issues/31 + , lifted-base < 0.2.3.7 || > 0.2.3.7 + , microlens >= 0.3.0.0 + , monad-control >= 1.0.1.0 + , monad-logger >= 0.3.13.1 + , mtl >= 2.1.3.1 + , optparse-applicative >= 0.13 && < 0.14 + , path >= 0.5.8 && < 0.6 + , path-io >= 1.1.0 && < 2.0.0 + , split + , stack + , text >= 1.2.0.4 + , transformers >= 0.3.0.0 && < 0.6 + default-language: Haskell2010 + if os(windows) + build-depends: Win32 + cpp-options: -DWINDOWS + if !flag(disable-git-info) + cpp-options: -DUSE_GIT_INFO + build-depends: gitrev >= 1.1 && < 1.4 + , optparse-simple >= 0.0.3 + if flag(hide-dependency-versions) + cpp-options: -DHIDE_DEP_VERSIONS + test-suite stack-test - - if os(windows) - cpp-options: -DWINDOWS - type: exitcode-stdio-1.0 - main-is: Test.hs - build-depends: - Cabal >=1.18.1.5 && <1.25, - QuickCheck >=2.8.2 && <2.10, - attoparsec >=0.13.1.0 && <0.14, - base >=4.7 && <5, - conduit >=1.2.8 && <1.3, - conduit-extra >=1.1.14 && <1.2, - containers >=0.5.5.1 && <0.6, - cryptonite ==0.19.*, - directory >=1.2.1.0 && <1.4, - exceptions >=0.8.3 && <0.9, - filepath >=1.4.0.0 && <1.5, - hspec >=2.2 && <2.5, - hashable >=1.2.4.0 && <1.3, - http-client-tls >=0.3.4 && <0.4, - http-conduit >=2.2.3 && <2.3, - monad-logger >=0.3.20.1 && <0.4, - neat-interpolation ==0.3.*, - optparse-applicative ==0.13.*, - path >=0.5.8 && <0.6, - path-io >=1.1.0 && <2.0.0, - resourcet >=1.1.8.1 && <1.2, - retry >=0.6 && <0.8, - stack >=1.4.0 && <1.5, - temporary >=1.2.0.4 && <1.3, - text >=1.2.2.1 && <1.3, - transformers >=0.3.0.0 && <0.6, - mono-traversable >=0.10.2 && <1.1, - th-reify-many >=0.1.6 && <0.2, - smallcheck >=1.1.1 && <1.2, - bytestring >=0.10.6.0 && <0.11, - store >=0.2.1.0 && <0.4, - vector >=0.10.12.3 && <0.13, - unordered-containers >=0.2.7.1 && <0.3, - template-haskell >=2.10.0.0 && <2.11, - yaml >=0.8.20 && <0.9 - default-language: Haskell2010 - hs-source-dirs: src/test - other-modules: - Spec - Stack.BuildPlanSpec - Stack.Build.ExecuteSpec - Stack.Build.TargetSpec - Stack.ConfigSpec - Stack.DotSpec - Stack.GhciSpec - Stack.Ghci.ScriptSpec - Stack.Ghci.PortableFakePaths - Stack.PackageDumpSpec - Stack.ArgsSpec - Stack.NixSpec - Stack.StoreSpec - Network.HTTP.Download.VerifiedSpec - Stack.SolverSpec - Stack.Untar.UntarSpec - ghc-options: -threaded -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + 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.GhciSpec + , Stack.Ghci.ScriptSpec + , Stack.Ghci.PortableFakePaths + , Stack.PackageDumpSpec + , Stack.ArgsSpec + , Stack.NixSpec + , Stack.StoreSpec + , Network.HTTP.Download.VerifiedSpec + , Stack.SolverSpec + , Stack.Untar.UntarSpec + ghc-options: -threaded -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + build-depends: Cabal >= 1.18.1.5 && < 1.25 + , QuickCheck >= 2.8.2 && < 2.10 + , attoparsec < 0.14 + , base >=4.7 && <5 + , conduit >= 1.2.8 + , conduit-extra + , containers >= 0.5.5.1 + , cryptonite >= 0.19 && < 0.24 + , directory >= 1.2.1.0 && < 1.4 + , exceptions + , filepath >= 1.3.0.2 + , hspec >= 2.2 && <2.5 + , hashable >= 1.2.3.2 + , http-client-tls >= 0.3.4 + , http-conduit >= 2.2.3 + , monad-logger + , neat-interpolation >= 0.3 + , optparse-applicative >= 0.13 && < 0.14 + , path >= 0.5.8 && < 0.6 + , path-io >= 1.1.0 && < 2.0.0 + , resourcet + , retry >= 0.6 && < 0.8 + , stack + , temporary >= 1.2.0.3 + , text + , transformers >= 0.3.0.0 && < 0.6 + , mono-traversable >= 0.10.2 && <1.1 + , th-reify-many >= 0.1.6 + , smallcheck + , bytestring >= 0.10.4.0 + , store >= 0.4.1 && < 0.5 + , vector >= 0.10.12.3 && < 0.13 + , unordered-containers + , template-haskell >= 2.9.0.0 && < 2.12 + , yaml >= 0.8.20 + default-language: Haskell2010 + if os(windows) + cpp-options: -DWINDOWS + test-suite stack-integration-test - - if !flag(integration-tests) - buildable: False - type: exitcode-stdio-1.0 - main-is: IntegrationSpec.hs - build-depends: - async >=2.1.0 && <2.2, - base >=4.7 && <5, - bytestring >=0.10.4.0 && <0.11, - conduit >=1.2.8 && <1.3, - conduit-extra >=1.1.14 && <1.2, - containers >=0.5.5.1 && <0.6, - directory >=1.2.1.0 && <1.4, - filepath >=1.3.0.2 && <1.5, - hspec >=2.2 && <2.5, - process >=1.2.0.0 && <1.5, - resourcet >=1.1.8.1 && <1.2, - temporary >=1.2.0.4 && <1.3, - text >=1.2.2.1 && <1.3, - transformers >=0.3.0.0 && <0.6, - unix-compat >=0.4.1.4 && <0.5 - default-language: Haskell2010 - hs-source-dirs: test/integration test/integration/lib - other-modules: - StackTest - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + type: exitcode-stdio-1.0 + hs-source-dirs: test/integration + main-is: IntegrationSpec.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + + if !flag(integration-tests) + buildable: False + + build-depends: async < 2.2 + , base >= 4.7 && < 5 + , bytestring >= 0.10.4.0 + , conduit >= 1.2.8 + , conduit-extra >= 1.1.14 + , containers >= 0.5.5.1 + , directory >= 1.2.1.0 && < 1.4 + , filepath >= 1.3.0.2 + , hspec >= 2.2 && < 2.5 + , process >= 1.2.0.0 && < 1.5 + , resourcet + , temporary >= 1.2.0.3 + , text + , transformers >= 0.3.0.0 && < 0.6 + , unix-compat >= 0.4.1.4 + default-language: Haskell2010 + + -- This isn't actually needed to build stack-integration-test, but it makes it + -- easier to load up an individual integration test into stack ghci. It's + -- still a little involved: + -- + -- stack exec -- stack ghci stack:stack-integration-test --flag stack:integration-tests --no-build + -- + -- Then, in ghci: + -- + -- :cd test/integration/tests/.../files + -- :load ../Main.hs + -- main + other-modules: StackTest + hs-source-dirs: test/integration/lib + +source-repository head + type: git + location: https://github.com/commercialhaskell/stack.git diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-6.25 +resolver: lts-8.22 # docker: # enable: true # repo: fpco/stack-full @@ -11,26 +11,10 @@ enable: false packages: - zlib -extra-deps: -- Cabal-1.24.2.0 -- th-utilities-0.2.0.1 -- store-0.3 -- store-core-0.3 -- th-orphans-0.13.1 -- http-client-0.5.3.3 -- http-client-tls-0.3.4 -- http-conduit-2.2.3 -- optparse-applicative-0.13.0.0 -- text-metrics-0.1.0 -- pid1-0.1.0.0 -- aeson-1.0.2.1 -- hpack-0.17.0 -- persistent-2.6 -- persistent-template-2.5.1.6 -- persistent-sqlite-2.6 -- cryptohash-sha256-0.11.100.1 -- ed25519-0.0.5.0 -- hackage-security-0.5.2.2 flags: stack: hide-dependency-versions: true + mintty: + win32-2-5: false +extra-deps: +- mintty-0.1.1 diff --git a/test/integration/IntegrationSpec.hs b/test/integration/IntegrationSpec.hs --- a/test/integration/IntegrationSpec.hs +++ b/test/integration/IntegrationSpec.hs @@ -17,6 +17,7 @@ import Data.Conduit.Process import Data.List (isSuffixOf, stripPrefix, sort) import qualified Data.Map as Map +import Data.Maybe (fromMaybe) import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL @@ -53,12 +54,14 @@ $ Map.insert "HOME" newHome $ Map.insert "APPDATA" newHome $ Map.delete "GHC_PACKAGE_PATH" + $ Map.delete "STACK_ROOT" $ Map.fromList $ map (first (map toUpper)) envOrig - origStackRoot <- getAppUserDataDirectory "stack" + defaultStackRoot <- getAppUserDataDirectory "stack" + let origStackRoot = fromMaybe defaultStackRoot (lookup "STACK_ROOT" envOrig) - hspec $ mapM_ (test runghc env' currDir origStackRoot newHome) tests + hspec $ mapM_ (test runghc env' currDir defaultStackRoot origStackRoot newHome) tests hasTest :: FilePath -> FilePath -> IO Bool hasTest root dir = doesFileExist $ root dir "Main.hs" @@ -66,14 +69,15 @@ test :: FilePath -- ^ runghc -> [(String, String)] -- ^ env -> FilePath -- ^ currdir + -> FilePath -- ^ defaultStackRoot -> FilePath -- ^ origStackRoot -> FilePath -- ^ newHome -> String -> Spec -test runghc env' currDir origStackRoot newHome name = it name $ withDir $ \dir -> do +test runghc env' currDir defaultStackRoot origStackRoot newHome name = it name $ withDir $ \dir -> do newHomeExists <- doesDirectoryExist newHome when newHomeExists (removeDirectoryRecursive newHome) - let newStackRoot = newHome takeFileName origStackRoot + let newStackRoot = newHome takeFileName defaultStackRoot copyTree toCopyRoot origStackRoot newStackRoot writeFile (newStackRoot "config.yaml") "system-ghc: true" let testDir = currDir "tests" name diff --git a/test/integration/lib/StackTest.hs b/test/integration/lib/StackTest.hs --- a/test/integration/lib/StackTest.hs +++ b/test/integration/lib/StackTest.hs @@ -181,6 +181,8 @@ -- | To avoid problems with GHC version mismatch when a new LTS major -- version is released, pass this argument to @stack@ when running in --- a global context. The LTS major version here should match that of --- the main @stack.yaml@. -defaultResolverArg = "--resolver=lts-6.0" +-- a global context. The LTS major version here should match that of +-- the main @stack.yaml@ (and ordinarily be the `.0` minor version). +-- +-- NOTE: currently using lts-8.22 instead of lts-8.0 because the `cyclic-test-deps` integration test is broken with lts-8.0 because a hackage metadata revision invalidated the snapshot (snapshot has `test-framework-quickcheck2-0.3.0.3` and `QuickCheck-2.9.2`, which used to be fine, but now test-framework-quickcheck2 was revised to have a `QuickCheck < 2.8` constraint). +defaultResolverArg = "--resolver=lts-8.22"