stack 1.4.0 → 1.5.0
raw patch · 98 files changed
+2865/−1947 lines, 98 filesdep +echodep +ghc-primdep +minttydep −hitdep ~Win32dep ~asyncdep ~bytestring
Dependencies added: echo, ghc-prim, mintty, store-core
Dependencies removed: hit
Dependency ranges changed: Win32, async, bytestring, conduit-extra, cryptonite, errors, filepath, gitrev, hashable, hpack, lifted-async, lifted-base, monad-logger, persistent, resourcet, safe-exceptions, split, stack, store, temporary, text-metrics, unordered-containers, vector-binary-instances
Files
- CONTRIBUTING.md +4/−4
- ChangeLog.md +96/−0
- doc/CONTRIBUTING.md +4/−4
- doc/ChangeLog.md +96/−0
- doc/GUIDE.md +36/−3
- doc/MAINTAINER_GUIDE.md +39/−29
- doc/README.md +32/−32
- doc/build_command.md +1/−0
- doc/custom_snapshot.md +1/−1
- doc/docker_integration.md +4/−0
- doc/faq.md +28/−0
- doc/ghcjs.md +3/−0
- doc/install_and_upgrade.md +10/−36
- doc/yaml_configuration.md +42/−5
- src/Data/Store/VersionTagged.hs +19/−18
- src/Options/Applicative/Builder/Extra.hs +104/−9
- src/Options/Applicative/Complicated.hs +11/−9
- src/Path/CheckInstall.hs +60/−0
- src/Stack/Build.hs +8/−9
- src/Stack/Build/Cache.hs +1/−3
- src/Stack/Build/ConstructPlan.hs +144/−45
- src/Stack/Build/Execute.hs +322/−215
- src/Stack/Build/Haddock.hs +2/−1
- src/Stack/Build/Source.hs +52/−19
- src/Stack/Build/Target.hs +4/−0
- src/Stack/BuildPlan.hs +6/−3
- src/Stack/Clean.hs +4/−4
- src/Stack/Config.hs +71/−32
- src/Stack/Config/Build.hs +43/−13
- src/Stack/Config/Nix.hs +2/−1
- src/Stack/ConfigCmd.hs +4/−3
- src/Stack/Constants.hs +5/−0
- src/Stack/Coverage.hs +6/−5
- src/Stack/Docker.hs +2/−2
- src/Stack/Docker/GlobalDB.hs +2/−1
- src/Stack/Dot.hs +35/−17
- src/Stack/Exec.hs +0/−9
- src/Stack/Fetch.hs +50/−103
- src/Stack/FileWatch.hs +8/−4
- src/Stack/Ghci.hs +11/−10
- src/Stack/Hoogle.hs +1/−3
- src/Stack/Image.hs +12/−1
- src/Stack/Init.hs +9/−7
- src/Stack/New.hs +5/−0
- src/Stack/Nix.hs +1/−1
- src/Stack/Options/BenchParser.hs +1/−0
- src/Stack/Options/BuildMonoidParser.hs +35/−71
- src/Stack/Options/BuildParser.hs +5/−1
- src/Stack/Options/Completion.hs +114/−0
- src/Stack/Options/ConfigParser.hs +11/−5
- src/Stack/Options/DockerParser.hs +9/−6
- src/Stack/Options/ExecParser.hs +3/−3
- src/Stack/Options/GhcBuildParser.hs +1/−0
- src/Stack/Options/GhciParser.hs +7/−2
- src/Stack/Options/GlobalParser.hs +7/−4
- src/Stack/Options/HpcReportParser.hs +10/−3
- src/Stack/Options/LogLevelParser.hs +1/−0
- src/Stack/Options/NixParser.hs +2/−1
- src/Stack/Options/SDistParser.hs +29/−0
- src/Stack/Options/ScriptParser.hs +2/−1
- src/Stack/Options/TestParser.hs +1/−0
- src/Stack/Package.hs +27/−15
- src/Stack/PackageDump.hs +9/−1
- src/Stack/PackageIndex.hs +25/−151
- src/Stack/Path.hs +2/−2
- src/Stack/PrettyPrint.hs +4/−1
- src/Stack/Runners.hs +27/−13
- src/Stack/SDist.hs +136/−22
- src/Stack/Script.hs +12/−4
- src/Stack/Setup.hs +103/−87
- src/Stack/Setup/Installed.hs +6/−4
- src/Stack/SetupCmd.hs +29/−5
- src/Stack/Solver.hs +24/−15
- src/Stack/Types/Build.hs +29/−6
- src/Stack/Types/BuildPlan.hs +5/−2
- src/Stack/Types/Config.hs +50/−45
- src/Stack/Types/Config/Build.hs +17/−2
- src/Stack/Types/FlagName.hs +2/−1
- src/Stack/Types/Package.hs +2/−2
- src/Stack/Types/PackageIndex.hs +10/−41
- src/Stack/Types/PackageName.hs +2/−1
- src/Stack/Types/Resolver.hs +1/−1
- src/Stack/Types/StringError.hs +20/−0
- src/Stack/Types/TemplateName.hs +2/−1
- src/Stack/Types/Version.hs +7/−2
- src/Stack/Upgrade.hs +7/−6
- src/Stack/Upload.hs +127/−230
- src/System/Process/Read.hs +3/−3
- src/Text/PrettyPrint/Leijen/Extended.hs +1/−1
- src/main/Main.hs +70/−78
- src/test/Stack/ConfigSpec.hs +6/−3
- src/test/Stack/GhciSpec.hs +14/−9
- src/test/Stack/PackageDumpSpec.hs +5/−0
- src/test/Stack/StoreSpec.hs +2/−2
- stack.cabal +423/−405
- stack.yaml +5/−21
- test/integration/IntegrationSpec.hs +8/−4
- test/integration/lib/StackTest.hs +5/−3
CONTRIBUTING.md view
@@ -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
ChangeLog.md view
@@ -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:
doc/CONTRIBUTING.md view
@@ -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
doc/ChangeLog.md view
@@ -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:
doc/GUIDE.md view
@@ -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/<your-project>-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:+ - <your-project>-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).
doc/MAINTAINER_GUIDE.md view
@@ -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.+ * <del>+ 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)+ </del> * 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 <VERSION>`--* (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`++* <del>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 <VERSION>`+ </del>++* <del>[Flag the Arch Linux package as out-of-date](https://www.archlinux.org/packages/community/x86_64/stack/flag/)</del>++* 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
doc/README.md view
@@ -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).
doc/build_command.md view
@@ -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`.
doc/custom_snapshot.md view
@@ -113,7 +113,7 @@ resolver: lts-7.1 packages: - text-1.2.2.1-ghc-options:+flags: text: developer: true ```
doc/docker_integration.md view
@@ -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
doc/faq.md view
@@ -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
doc/ghcjs.md view
@@ -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
doc/install_and_upgrade.md view
@@ -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
doc/yaml_configuration.md view
@@ -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 `<project dir>/stack.yaml`.+specific options from `~/.stack/global-project/stack.yaml`. When stack is+invoked inside a stack project, only options from `<project dir>/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
src/Data/Store/VersionTagged.hs view
@@ -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
src/Options/Applicative/Builder/Extra.hs view
@@ -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
src/Options/Applicative/Complicated.hs view
@@ -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
+ src/Path/CheckInstall.hs view
@@ -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"+ ]
src/Stack/Build.hs view
@@ -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
src/Stack/Build/Cache.hs view
@@ -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)
src/Stack/Build/ConstructPlan.hs view
@@ -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
src/Stack/Build/Execute.hs view
@@ -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
src/Stack/Build/Haddock.hs view
@@ -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
src/Stack/Build/Source.hs view
@@ -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)
src/Stack/Build/Target.hs view
@@ -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
src/Stack/BuildPlan.hs view
@@ -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)
src/Stack/Clean.hs view
@@ -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)
src/Stack/Config.hs view
@@ -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.
src/Stack/Config/Build.hs view
@@ -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
src/Stack/Config/Nix.hs view
@@ -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
src/Stack/ConfigCmd.hs view
@@ -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"])
src/Stack/Constants.hs view
@@ -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
src/Stack/Coverage.hs view
@@ -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"))
src/Stack/Docker.hs view
@@ -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
src/Stack/Docker/GlobalDB.hs view
@@ -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)
src/Stack/Dot.hs view
@@ -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))]
src/Stack/Exec.hs view
@@ -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
src/Stack/Fetch.hs view
@@ -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)
src/Stack/FileWatch.hs view
@@ -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
src/Stack/Ghci.hs view
@@ -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
src/Stack/Hoogle.hs view
@@ -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
src/Stack/Image.hs view
@@ -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
src/Stack/Init.hs view
@@ -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
src/Stack/New.hs view
@@ -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"
src/Stack/Nix.hs view
@@ -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)
src/Stack/Options/BenchParser.hs view
@@ -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`") <>
src/Stack/Options/BuildMonoidParser.hs view
@@ -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
src/Stack/Options/BuildParser.hs view
@@ -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 " <>
+ src/Stack/Options/Completion.hs view
@@ -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
src/Stack/Options/ConfigParser.hs view
@@ -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 ))
src/Stack/Options/DockerParser.hs view
@@ -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" ])))
src/Stack/Options/ExecParser.hs view
@@ -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)")-
src/Stack/Options/GhcBuildParser.hs view
@@ -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
src/Stack/Options/GhciParser.hs view
@@ -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."))
src/Stack/Options/GlobalParser.hs view
@@ -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")
src/Stack/Options/HpcReportParser.hs view
@@ -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
src/Stack/Options/LogLevelParser.hs view
@@ -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)
src/Stack/Options/NixParser.hs view
@@ -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
+ src/Stack/Options/SDistParser.hs view
@@ -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
src/Stack/Options/ScriptParser.hs view
@@ -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"
src/Stack/Options/TestParser.hs view
@@ -22,6 +22,7 @@ (optional (argsOption (long "test-arguments" <>+ long "ta" <> metavar "TEST_ARGS" <> help "Arguments passed in to the test suite program" <> hide)))
src/Stack/Package.hs view
@@ -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
src/Stack/PackageDump.hs view
@@ -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)
src/Stack/PackageIndex.hs view
@@ -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
src/Stack/Path.hs view
@@ -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 )
src/Stack/PrettyPrint.hs view
@@ -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
src/Stack/Runners.hs view
@@ -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.
src/Stack/SDist.hs view
@@ -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
src/Stack/Script.hs view
@@ -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
src/Stack/Setup.hs view
@@ -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
src/Stack/Setup/Installed.hs view
@@ -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
src/Stack/SetupCmd.hs view
@@ -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"
src/Stack/Solver.hs view
@@ -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)
src/Stack/Types/Build.hs view
@@ -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]
src/Stack/Types/BuildPlan.hs view
@@ -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)
src/Stack/Types/Config.hs view
@@ -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)
src/Stack/Types/Config/Build.hs view
@@ -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"
src/Stack/Types/FlagName.hs view
@@ -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'.
src/Stack/Types/Package.hs view
@@ -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 }
src/Stack/Types/PackageIndex.hs view
@@ -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 }
src/Stack/Types/PackageName.hs view
@@ -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'.
src/Stack/Types/Resolver.hs view
@@ -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
+ src/Stack/Types/StringError.hs view
@@ -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
src/Stack/Types/TemplateName.hs view
@@ -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 =
src/Stack/Types/Version.hs view
@@ -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
src/Stack/Upgrade.hs view
@@ -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
src/Stack/Upload.hs view
@@ -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
src/System/Process/Read.hs view
@@ -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 "
src/Text/PrettyPrint/Leijen/Extended.hs view
@@ -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 " ")
src/main/Main.hs view
@@ -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 ->
src/test/Stack/ConfigSpec.hs view
@@ -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"
src/test/Stack/GhciSpec.hs view
@@ -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 } }
src/test/Stack/PackageDumpSpec.hs view
@@ -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"]
src/test/Stack/StoreSpec.hs view
@@ -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
stack.cabal view
@@ -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
stack.yaml view
@@ -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
test/integration/IntegrationSpec.hs view
@@ -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
test/integration/lib/StackTest.hs view
@@ -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"