packages feed

stack 1.2.0 → 1.3.0

raw patch · 135 files changed

+6394/−3920 lines, 135 filesdep +file-embeddep +pid1dep +safe-exceptionsdep −edit-distancedep −enclosed-exceptionsdep ~aesondep ~attoparsecdep ~conduit

Dependencies added: file-embed, pid1, safe-exceptions, text-metrics

Dependencies removed: edit-distance, enclosed-exceptions

Dependency ranges changed: aeson, attoparsec, conduit, conduit-extra, exceptions, extra, generic-deriving, hspec, http-client, http-client-tls, http-conduit, lifted-base, monad-logger, path, resourcet, stack, store, text-binary, unicode-transforms, yaml

Files

CONTRIBUTING.md view
@@ -2,14 +2,24 @@  ## Bug Reports -Please [open an issue](https://github.com/commercialhaskell/stack/issues/new) and use the provided template to include all necessary details.+Please [open an issue](https://github.com/commercialhaskell/stack/issues/new)+and use the provided template to include all necessary details. -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.+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.   ## Documentation -If you would like to help with documentation, please note that for most cases the Wiki has been deprecated in favor of markdown files placed in a new `/doc` subdirectory of the repository itself. Please submit a [pull request](https://help.github.com/articles/using-pull-requests/) with your changes/additions.+If you would like to help with documentation, please note that for most cases+the Wiki has been deprecated in favor of markdown files placed in a new `/doc`+subdirectory of the repository itself. Please submit a+[pull request](https://help.github.com/articles/using-pull-requests/) with your+changes/additions.  The documentation is rendered on [haskellstack.org](http://haskellstack.org) by readthedocs.org using Sphinx and CommonMark. Since links and formatting vary@@ -18,7 +28,11 @@ `.html` extensions instead of `.md`, unfortunately (see [#1506](https://github.com/commercialhaskell/stack/issues/1506) for details). -If your changes move or rename files, or subsume Wiki content, please continue to leave a file/page in the old location temporarily, in addition to the new location. This will allow users time to update any shared links to the old location. Please also update any links in other files, or on the Wiki, to point to the new file location.+If your changes move or rename files, or subsume Wiki content, please continue+to leave a file/page in the old location temporarily, in addition to the new+location. This will allow users time to update any shared links to the old+location. Please also update any links in other files, or on the Wiki, to point+to the new file location.   ## Code@@ -41,3 +55,38 @@ entry and [documentation](https://github.com/commercialhaskell/stack/tree/master/doc/) updates with your pull request.++## Code Quality++The Stack projects uses [HLint](https://github.com/ndmitchell/hlint) as a code+quality tool.++Note that stack contributors need not dogmatically follow the suggested hints+but are encouraged to debate their usefulness. If you find a hint is not useful+and detracts from readability, consider marking it in the [configuration+file](https://github.com/commercialhaskell/stack/blob/master/HLint.hs) to+be ignored. Please refer to the [HLint manual](https://github.com/ndmitchell/hlint#ignoring-hints)+for configuration syntax.++Quoting [@mgsloan](https://github.com/commercialhaskell/stack/pulls?utf8=%E2%9C%93&q=is%3Apr%20author%3Amgsloan):++> We are optimizing for code clarity, not code concision or what HLint thinks.++You can install HLint with stack. You might want to install it in the global+project in case you run into dependency conflicts. HLint can report hints in+your favourite text editor. Refer to the HLint repository for more details.++To install:++```+stack install hlint+```++Once installed, you can check your changes with:++```+hlint src/ test/ --cpp-simple --hint=HLint.hs+```++Where `--cpp-simple` strips `#` lines and `--hint` explicitly specifies the+configuration file.
ChangeLog.md view
@@ -1,20 +1,186 @@ # Changelog +## 1.3.0++Release notes:++* For the _next_ stack release after this one, we are planning+  changes to our Linux releases, including dropping our Ubuntu,+  Debian, CentOS, and Fedora package repositories and switching to+  statically linked binaries. See+  [#2534](https://github.com/commercialhaskell/stack/issues/2534).+  Note that upgrading without a package manager has gotten easier+  with new binary upgrade support in `stack upgrade` (see the Major+  Changes section below for more information). In addition, the+  get.haskellstack.org script no longer installs from Ubuntu,+  Debian, CentOS, or Fedora package repositories. Instead it places+  a generic binary in /usr/local/bin.++Major changes:++* Stack will now always use its own GHC installation, even when a suitable GHC+  installation is available on the PATH. To get the old behaviour, use+  the `--system-ghc` flag or run `stack config set system-ghc --global true`.+  Docker- and Nix-enabled projects continue to use the GHC installations+  in their environment by default.++    NB: Scripts that previously used stack in combination with a system GHC+    installation should now include a `stack setup` line or use the `--install-ghc`+    flag.+    [#2221](https://github.com/commercialhaskell/stack/issues/2221)++* `stack ghci` now defaults to skipping the build of target packages, because+  support has been added for invoking "initial build steps", which create+  autogen files and run preprocessors. The `--no-build` flag is now deprecated+  because it should no longer be necessary. See+  [#1364](https://github.com/commercialhaskell/stack/issues/1364)++* Stack is now capable of doing binary upgrades instead of always+  recompiling a new version from source. Running `stack upgrade` will+  now default to downloading a binary version of Stack from the most+  recent release, if one is available. See `stack upgrade --help` for+  more options.+  [#1238](https://github.com/commercialhaskell/stack/issues/1238)++Behavior changes:++* Passing `--resolver X` with a Stack command which forces creation of a global+  project config, will pass resolver X into the initial config.+  See [#2579](https://github.com/commercialhaskell/stack/issues/2229).++* Switch the "Run from outside project" messages to debug-level, to+  avoid spamming users in the normal case of non-project usage++* If a remote package is specified (such as a Git repo) without an explicit+  `extra-dep` setting, a warning is given to the user to provide one+  explicitly.++Other enhancements:++* `stack haddock` now supports `--haddock-internal`. See+  [#2229](https://github.com/commercialhaskell/stack/issues/2229)+* Add support for `system-ghc` and `install-ghc` fields to `stack config set` command.+* Add `ghc-build` option to override autodetected GHC build to use (e.g. gmp4,+  tinfo6, nopie) on Linux.+* `stack setup` detects systems where gcc enables PIE by default (such as Ubuntu+  16.10 and Hardened Gentoo) and adjusts the GHC `configure` options accordingly.+  [#2542](https://github.com/commercialhaskell/stack/issues/2542)+* Upload to Hackage with HTTP digest instead of HTTP basic.+* Make `stack list-dependencies` understand all of the `stack dot` options too.+* Add the ability for `stack list-dependencies` to list dependency licenses by+  passing the `--license` flag.+* Dump logs that contain warnings for any local non-dependency packages+  [#2545](https://github.com/commercialhaskell/stack/issues/2545)+* Add the `dump-logs` config option and `--dump-logs` command line+  option to get full build output on the+  console. [#426](https://github.com/commercialhaskell/stack/issues/426)+* Add the `--open` option to "stack hpc report" command, causing the report to+  be opened in the browser.+* The `stack config set` command now accepts a `--global` flag for suitable fields+  which causes it to modify the global user configuration (`~/.stack/config.yaml`)+  instead of the project configuration.+  [#2675](https://github.com/commercialhaskell/stack/pull/2675)+* Information on the latest available snapshots is now downloaded from S3 instead of+  stackage.org, increasing reliability in case of stackage.org outages.+  [#2653](https://github.com/commercialhaskell/stack/pull/2653)+* `stack dot` and `stack list-dependencies` now take targets and flags.+  [#1919](https://github.com/commercialhaskell/stack/issues/1919)+* Deprecate `stack setup --stack-setup-yaml` for `--setup-info-yaml` based+  on discussion in [#2647](https://github.com/commercialhaskell/stack/issues/2647).+* The `--main-is` flag for GHCI now implies the TARGET, fixing+  [#1845](https://github.com/commercialhaskell/stack/issues/1845).+* `stack ghci` no longer takes all build options, as many weren't useful+  [#2199](https://github.com/commercialhaskell/stack/issues/2199)+* `--no-time-in-log` option, to make verbose logs more diffable+  [#2727](https://github.com/commercialhaskell/stack/issues/2727)+* `--color` option added to override auto-detection of ANSI support+  [#2725](https://github.com/commercialhaskell/stack/issues/2725)+* Missing extra-deps are now warned about, adding a degree of typo detection+  [#1521](https://github.com/commercialhaskell/stack/issues/1521)+* No longer warns about missing build-tools if they are on the PATH.+  [#2235](https://github.com/commercialhaskell/stack/issues/2235)+* Replace enclosed-exceptions with safe-exceptions.+  [#2768](https://github.com/commercialhaskell/stack/issues/2768)+* The install location for GHC and other programs can now be configured with the+  `local-programs-path` option in `config.yaml`.+  [#1644](https://github.com/commercialhaskell/stack/issues/1644)+* Added option to add nix dependencies as nix GC roots+* Proper pid 1 (init) process for `stack exec` with Docker+* Dump build logs if they contain warnings.+  [#2545](https://github.com/commercialhaskell/stack/issues/2545)+* Docker: redirect stdout of `docker pull` to stderr so that+  it will not interfere with output of other commands.+* Nix & docker can be activated at the same time, in order to run stack in a nix-shell+  in a container, preferably from an image already containing the nix dependencies+  in its /nix/store+* Stack/nix: Dependencies can be added as nix GC roots, so they are not removed+  when running `nix-collect-garbage`++Bug fixes:++* Fixed a gnarly bug where programs and package tarballs sometimes have+  corrupted downloads. See+  [#2657](https://github.com/commercialhaskell/stack/issues/2568).+* Add proper support for non-ASCII characters in file paths for the `sdist` command.+  See [#2549](https://github.com/commercialhaskell/stack/issues/2549)+* Never treat `extra-dep` local packages as targets. This ensures+  things like test suites are not run for these packages, and that+  build output is not hidden due to their presence.+* Fix a resource leak in `sinkProcessStderrStdout` which could affect+  much of the codebase, in particular copying precompiled+  packages. [#1979](https://github.com/commercialhaskell/stack/issues/1979)+* Docker: ensure that interrupted extraction process does not cause corrupt file+  when downloading a Docker-compatible Stack executable+  [#2568](https://github.com/commercialhaskell/stack/issues/2568)+* Fixed running `stack hpc report` on package targets.+  [#2664](https://github.com/commercialhaskell/stack/issues/2664)+* Fix a long-standing performance regression where stack would parse the .dump-hi+  files of the library components of local packages twice.+  [#2658](https://github.com/commercialhaskell/stack/pull/2658)+* Fixed a regression in "stack ghci --no-load", where it would prompt for a main+  module to load. [#2603](https://github.com/commercialhaskell/stack/pull/2603)+* Build Setup.hs files with the threaded RTS, mirroring the behavior of+  cabal-install and enabling more complex build systems in those files.+* Fixed a bug in passing along `--ghc-options` to ghcjs.  They were being+  provided as `--ghc-options` to Cabal, when it needs to be `--ghcjs-options`.+  [#2714](https://github.com/commercialhaskell/stack/issues/2714)+* Launch Docker from the project root regardless of the working+  directory Stack is invoked from. This means paths relative to the project root+  (e.g. environment files) can be specified in `stack.yaml`'s docker `run-args`.+* `stack setup --reinstall` now behaves as expected.+  [#2554](https://github.com/commercialhaskell/stack/issues/2554)+ ## 1.2.0  Release notes: +* On many Un*x systems, Stack can now be installed with a simple+  one-liner:++        wget -qO- https://get.haskellstack.org/ | sh+ * The fix for   [#2175](https://github.com/commercialhaskell/stack/issues/2175)   entails that stack must perform a full clone of a large Git repo of   Hackage meta-information. The total download size is about 200 MB.   Please be aware of this when upgrading your stack installation.-* On many Un*x systems, stack can now be installed with a simple-  one-liner: `wget -qO- https://get.haskellstack.org/ | sh`-* 64-bit GHC bindists have been built for Linux systems with-  libtinfo6/libncurses6 (such as Fedora 24 and Arch Linux), and `stack setup`-  will detect when to use them.-* Added Ubuntu 16.10 (yakkety) Apt repo.++* If you use Mac OS X, you may want to delay upgrading to macOS Sierra as there+  are reports of GHC panics when building some packages (including Stack+  itself). See [#2577](https://github.com/commercialhaskell/stack/issues/2577)++* This version of Stack does not build on ARM or PowerPC systems (see+  [store#37](https://github.com/fpco/store/issues/37)).  Please stay with+  version 1.1.2 for now on those architectures.  This will be rectified soon!++* We are now releasing a+  [statically linked Stack binary for 64-bit Linux](https://www.stackage.org/stack/linux-x86_64-static).+  Please try it and let us know if you run into any trouble on your platform.++* We are planning some changes to our Linux releases, including dropping our+  Ubuntu, Debian, CentOS, and Fedora package repositories and switching to+  statically linked binaries.  We would value your feedback in+  [#2534](https://github.com/commercialhaskell/stack/issues/2534).  Major changes:
doc/CONTRIBUTING.md view
@@ -2,14 +2,24 @@  ## Bug Reports -Please [open an issue](https://github.com/commercialhaskell/stack/issues/new) and use the provided template to include all necessary details.+Please [open an issue](https://github.com/commercialhaskell/stack/issues/new)+and use the provided template to include all necessary details. -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.+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.   ## Documentation -If you would like to help with documentation, please note that for most cases the Wiki has been deprecated in favor of markdown files placed in a new `/doc` subdirectory of the repository itself. Please submit a [pull request](https://help.github.com/articles/using-pull-requests/) with your changes/additions.+If you would like to help with documentation, please note that for most cases+the Wiki has been deprecated in favor of markdown files placed in a new `/doc`+subdirectory of the repository itself. Please submit a+[pull request](https://help.github.com/articles/using-pull-requests/) with your+changes/additions.  The documentation is rendered on [haskellstack.org](http://haskellstack.org) by readthedocs.org using Sphinx and CommonMark. Since links and formatting vary@@ -18,7 +28,11 @@ `.html` extensions instead of `.md`, unfortunately (see [#1506](https://github.com/commercialhaskell/stack/issues/1506) for details). -If your changes move or rename files, or subsume Wiki content, please continue to leave a file/page in the old location temporarily, in addition to the new location. This will allow users time to update any shared links to the old location. Please also update any links in other files, or on the Wiki, to point to the new file location.+If your changes move or rename files, or subsume Wiki content, please continue+to leave a file/page in the old location temporarily, in addition to the new+location. This will allow users time to update any shared links to the old+location. Please also update any links in other files, or on the Wiki, to point+to the new file location.   ## Code@@ -41,3 +55,38 @@ entry and [documentation](https://github.com/commercialhaskell/stack/tree/master/doc/) updates with your pull request.++## Code Quality++The Stack projects uses [HLint](https://github.com/ndmitchell/hlint) as a code+quality tool.++Note that stack contributors need not dogmatically follow the suggested hints+but are encouraged to debate their usefulness. If you find a hint is not useful+and detracts from readability, consider marking it in the [configuration+file](https://github.com/commercialhaskell/stack/blob/master/HLint.hs) to+be ignored. Please refer to the [HLint manual](https://github.com/ndmitchell/hlint#ignoring-hints)+for configuration syntax.++Quoting [@mgsloan](https://github.com/commercialhaskell/stack/pulls?utf8=%E2%9C%93&q=is%3Apr%20author%3Amgsloan):++> We are optimizing for code clarity, not code concision or what HLint thinks.++You can install HLint with stack. You might want to install it in the global+project in case you run into dependency conflicts. HLint can report hints in+your favourite text editor. Refer to the HLint repository for more details.++To install:++```+stack install hlint+```++Once installed, you can check your changes with:++```+hlint src/ test/ --cpp-simple --hint=HLint.hs+```++Where `--cpp-simple` strips `#` lines and `--hint` explicitly specifies the+configuration file.
doc/ChangeLog.md view
@@ -1,20 +1,186 @@ # Changelog +## 1.3.0++Release notes:++* For the _next_ stack release after this one, we are planning+  changes to our Linux releases, including dropping our Ubuntu,+  Debian, CentOS, and Fedora package repositories and switching to+  statically linked binaries. See+  [#2534](https://github.com/commercialhaskell/stack/issues/2534).+  Note that upgrading without a package manager has gotten easier+  with new binary upgrade support in `stack upgrade` (see the Major+  Changes section below for more information). In addition, the+  get.haskellstack.org script no longer installs from Ubuntu,+  Debian, CentOS, or Fedora package repositories. Instead it places+  a generic binary in /usr/local/bin.++Major changes:++* Stack will now always use its own GHC installation, even when a suitable GHC+  installation is available on the PATH. To get the old behaviour, use+  the `--system-ghc` flag or run `stack config set system-ghc --global true`.+  Docker- and Nix-enabled projects continue to use the GHC installations+  in their environment by default.++    NB: Scripts that previously used stack in combination with a system GHC+    installation should now include a `stack setup` line or use the `--install-ghc`+    flag.+    [#2221](https://github.com/commercialhaskell/stack/issues/2221)++* `stack ghci` now defaults to skipping the build of target packages, because+  support has been added for invoking "initial build steps", which create+  autogen files and run preprocessors. The `--no-build` flag is now deprecated+  because it should no longer be necessary. See+  [#1364](https://github.com/commercialhaskell/stack/issues/1364)++* Stack is now capable of doing binary upgrades instead of always+  recompiling a new version from source. Running `stack upgrade` will+  now default to downloading a binary version of Stack from the most+  recent release, if one is available. See `stack upgrade --help` for+  more options.+  [#1238](https://github.com/commercialhaskell/stack/issues/1238)++Behavior changes:++* Passing `--resolver X` with a Stack command which forces creation of a global+  project config, will pass resolver X into the initial config.+  See [#2579](https://github.com/commercialhaskell/stack/issues/2229).++* Switch the "Run from outside project" messages to debug-level, to+  avoid spamming users in the normal case of non-project usage++* If a remote package is specified (such as a Git repo) without an explicit+  `extra-dep` setting, a warning is given to the user to provide one+  explicitly.++Other enhancements:++* `stack haddock` now supports `--haddock-internal`. See+  [#2229](https://github.com/commercialhaskell/stack/issues/2229)+* Add support for `system-ghc` and `install-ghc` fields to `stack config set` command.+* Add `ghc-build` option to override autodetected GHC build to use (e.g. gmp4,+  tinfo6, nopie) on Linux.+* `stack setup` detects systems where gcc enables PIE by default (such as Ubuntu+  16.10 and Hardened Gentoo) and adjusts the GHC `configure` options accordingly.+  [#2542](https://github.com/commercialhaskell/stack/issues/2542)+* Upload to Hackage with HTTP digest instead of HTTP basic.+* Make `stack list-dependencies` understand all of the `stack dot` options too.+* Add the ability for `stack list-dependencies` to list dependency licenses by+  passing the `--license` flag.+* Dump logs that contain warnings for any local non-dependency packages+  [#2545](https://github.com/commercialhaskell/stack/issues/2545)+* Add the `dump-logs` config option and `--dump-logs` command line+  option to get full build output on the+  console. [#426](https://github.com/commercialhaskell/stack/issues/426)+* Add the `--open` option to "stack hpc report" command, causing the report to+  be opened in the browser.+* The `stack config set` command now accepts a `--global` flag for suitable fields+  which causes it to modify the global user configuration (`~/.stack/config.yaml`)+  instead of the project configuration.+  [#2675](https://github.com/commercialhaskell/stack/pull/2675)+* Information on the latest available snapshots is now downloaded from S3 instead of+  stackage.org, increasing reliability in case of stackage.org outages.+  [#2653](https://github.com/commercialhaskell/stack/pull/2653)+* `stack dot` and `stack list-dependencies` now take targets and flags.+  [#1919](https://github.com/commercialhaskell/stack/issues/1919)+* Deprecate `stack setup --stack-setup-yaml` for `--setup-info-yaml` based+  on discussion in [#2647](https://github.com/commercialhaskell/stack/issues/2647).+* The `--main-is` flag for GHCI now implies the TARGET, fixing+  [#1845](https://github.com/commercialhaskell/stack/issues/1845).+* `stack ghci` no longer takes all build options, as many weren't useful+  [#2199](https://github.com/commercialhaskell/stack/issues/2199)+* `--no-time-in-log` option, to make verbose logs more diffable+  [#2727](https://github.com/commercialhaskell/stack/issues/2727)+* `--color` option added to override auto-detection of ANSI support+  [#2725](https://github.com/commercialhaskell/stack/issues/2725)+* Missing extra-deps are now warned about, adding a degree of typo detection+  [#1521](https://github.com/commercialhaskell/stack/issues/1521)+* No longer warns about missing build-tools if they are on the PATH.+  [#2235](https://github.com/commercialhaskell/stack/issues/2235)+* Replace enclosed-exceptions with safe-exceptions.+  [#2768](https://github.com/commercialhaskell/stack/issues/2768)+* The install location for GHC and other programs can now be configured with the+  `local-programs-path` option in `config.yaml`.+  [#1644](https://github.com/commercialhaskell/stack/issues/1644)+* Added option to add nix dependencies as nix GC roots+* Proper pid 1 (init) process for `stack exec` with Docker+* Dump build logs if they contain warnings.+  [#2545](https://github.com/commercialhaskell/stack/issues/2545)+* Docker: redirect stdout of `docker pull` to stderr so that+  it will not interfere with output of other commands.+* Nix & docker can be activated at the same time, in order to run stack in a nix-shell+  in a container, preferably from an image already containing the nix dependencies+  in its /nix/store+* Stack/nix: Dependencies can be added as nix GC roots, so they are not removed+  when running `nix-collect-garbage`++Bug fixes:++* Fixed a gnarly bug where programs and package tarballs sometimes have+  corrupted downloads. See+  [#2657](https://github.com/commercialhaskell/stack/issues/2568).+* Add proper support for non-ASCII characters in file paths for the `sdist` command.+  See [#2549](https://github.com/commercialhaskell/stack/issues/2549)+* Never treat `extra-dep` local packages as targets. This ensures+  things like test suites are not run for these packages, and that+  build output is not hidden due to their presence.+* Fix a resource leak in `sinkProcessStderrStdout` which could affect+  much of the codebase, in particular copying precompiled+  packages. [#1979](https://github.com/commercialhaskell/stack/issues/1979)+* Docker: ensure that interrupted extraction process does not cause corrupt file+  when downloading a Docker-compatible Stack executable+  [#2568](https://github.com/commercialhaskell/stack/issues/2568)+* Fixed running `stack hpc report` on package targets.+  [#2664](https://github.com/commercialhaskell/stack/issues/2664)+* Fix a long-standing performance regression where stack would parse the .dump-hi+  files of the library components of local packages twice.+  [#2658](https://github.com/commercialhaskell/stack/pull/2658)+* Fixed a regression in "stack ghci --no-load", where it would prompt for a main+  module to load. [#2603](https://github.com/commercialhaskell/stack/pull/2603)+* Build Setup.hs files with the threaded RTS, mirroring the behavior of+  cabal-install and enabling more complex build systems in those files.+* Fixed a bug in passing along `--ghc-options` to ghcjs.  They were being+  provided as `--ghc-options` to Cabal, when it needs to be `--ghcjs-options`.+  [#2714](https://github.com/commercialhaskell/stack/issues/2714)+* Launch Docker from the project root regardless of the working+  directory Stack is invoked from. This means paths relative to the project root+  (e.g. environment files) can be specified in `stack.yaml`'s docker `run-args`.+* `stack setup --reinstall` now behaves as expected.+  [#2554](https://github.com/commercialhaskell/stack/issues/2554)+ ## 1.2.0  Release notes: +* On many Un*x systems, Stack can now be installed with a simple+  one-liner:++        wget -qO- https://get.haskellstack.org/ | sh+ * The fix for   [#2175](https://github.com/commercialhaskell/stack/issues/2175)   entails that stack must perform a full clone of a large Git repo of   Hackage meta-information. The total download size is about 200 MB.   Please be aware of this when upgrading your stack installation.-* On many Un*x systems, stack can now be installed with a simple-  one-liner: `wget -qO- https://get.haskellstack.org/ | sh`-* 64-bit GHC bindists have been built for Linux systems with-  libtinfo6/libncurses6 (such as Fedora 24 and Arch Linux), and `stack setup`-  will detect when to use them.-* Added Ubuntu 16.10 (yakkety) Apt repo.++* If you use Mac OS X, you may want to delay upgrading to macOS Sierra as there+  are reports of GHC panics when building some packages (including Stack+  itself). See [#2577](https://github.com/commercialhaskell/stack/issues/2577)++* This version of Stack does not build on ARM or PowerPC systems (see+  [store#37](https://github.com/fpco/store/issues/37)).  Please stay with+  version 1.1.2 for now on those architectures.  This will be rectified soon!++* We are now releasing a+  [statically linked Stack binary for 64-bit Linux](https://www.stackage.org/stack/linux-x86_64-static).+  Please try it and let us know if you run into any trouble on your platform.++* We are planning some changes to our Linux releases, including dropping our+  Ubuntu, Debian, CentOS, and Fedora package repositories and switching to+  statically linked binaries.  We would value your feedback in+  [#2534](https://github.com/commercialhaskell/stack/issues/2534).  Major changes:
doc/GUIDE.md view
@@ -332,8 +332,7 @@ ```  Thankfully, the command is smart enough to know not to perform an installation-twice. `setup` will either use the first GHC it finds on your PATH, or a sandboxed-version after installing it. As the command output above indicates, you can use `stack+twice. As the command output above indicates, you can use `stack path` for quite a bit of path information (which we'll play with more later). For now, we'll just look at where GHC is installed: @@ -1856,6 +1855,7 @@       sandboxes__, everything is (essentially) sandboxed by default.  __Other tools for comparison (including active and historical)__+ * [cabal-dev](https://hackage.haskell.org/package/cabal-dev) (deprecated in favor of cabal-install) * [cabal-meta](https://hackage.haskell.org/package/cabal-meta) inspired a lot of the multi-package functionality of stack. If you're still using cabal-install, cabal-meta is relevant. For stack work, the feature set is fully subsumed by stack. * [cabal-src](https://hackage.haskell.org/package/cabal-src) is mostly irrelevant in the presence of both stack and cabal sandboxes, both of which make it easier to add additional package sources easily. The mega-sdist executable that ships with cabal-src is, however, still relevant. Its functionality may some day be folded into stack@@ -1938,213 +1938,8 @@  ### Travis with caching -Many people use Travis CI to test out a project for every Git push. We have [a-document devoted to-Travis](travis_ci.md). However, for-most people, the following example will be sufficient to get started:--```yaml-# Copy these contents into the root directory of your Github project in a file-# named .travis.yml--# Use new container infrastructure to enable caching-sudo: false--# Choose a lightweight base image; we provide our own build tools.-language: c--# Caching so the next build will be fast too.-cache:-  directories:-  - $HOME/.ghc-  - $HOME/.cabal-  - $HOME/.stack--# The different configurations we want to test. We have BUILD=cabal which uses-# cabal-install, and BUILD=stack which uses Stack. More documentation on each-# of those below.-#-# We set the compiler values here to tell Travis to use a different-# cache file per set of arguments.-#-# If you need to have different apt packages for each combination in the-# matrix, you can use a line such as:-#     addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}-matrix:-  include:-  # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See:-  # https://github.com/hvr/multi-ghc-travis-  #- env: BUILD=cabal GHCVER=7.0.4 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7-  #  compiler: ": #GHC 7.0.4"-  #  addons: {apt: {packages: [cabal-install-1.16,ghc-7.0.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}-  #- env: BUILD=cabal GHCVER=7.2.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7-  #  compiler: ": #GHC 7.2.2"-  #  addons: {apt: {packages: [cabal-install-1.16,ghc-7.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}-  #- env: BUILD=cabal GHCVER=7.4.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7-  #  compiler: ": #GHC 7.4.2"-  #  addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}-  - env: BUILD=cabal GHCVER=7.6.3 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7-    compiler: ": #GHC 7.6.3"-    addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}-  - env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7-    compiler: ": #GHC 7.8.4"-    addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}-  - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7-    compiler: ": #GHC 7.10.3"-    addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}-  - env: BUILD=cabal GHCVER=8.0.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7-    compiler: ": #GHC 8.0.1"-    addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}--  # Build with the newest GHC and cabal-install. This is an accepted failure,-  # see below.-  - env: BUILD=cabal GHCVER=head  CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7-    compiler: ": #GHC HEAD"-    addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}--  # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS-  # variable, such as using --stack-yaml to point to a different file.-  - env: BUILD=stack ARGS=""-    compiler: ": #stack default"-    addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}}--  - env: BUILD=stack ARGS="--resolver lts-2"-    compiler: ": #stack 7.8.4"-    addons: {apt: {packages: [ghc-7.8.4], sources: [hvr-ghc]}}--  - env: BUILD=stack ARGS="--resolver lts-3"-    compiler: ": #stack 7.10.2"-    addons: {apt: {packages: [ghc-7.10.2], sources: [hvr-ghc]}}--  - env: BUILD=stack ARGS="--resolver lts-6"-    compiler: ": #stack 7.10.3"-    addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}}--  # Nightly builds are allowed to fail-  - env: BUILD=stack ARGS="--resolver nightly"-    compiler: ": #stack nightly"-    addons: {apt: {packages: [libgmp,libgmp-dev]}}--  # Build on OS X in addition to Linux-  - env: BUILD=stack ARGS=""-    compiler: ": #stack default osx"-    os: osx--  - env: BUILD=stack ARGS="--resolver lts-2"-    compiler: ": #stack 7.8.4 osx"-    os: osx--  - env: BUILD=stack ARGS="--resolver lts-3"-    compiler: ": #stack 7.10.2 osx"-    os: osx--  - env: BUILD=stack ARGS="--resolver lts-6"-    compiler: ": #stack 7.10.3 osx"-    os: osx--  - env: BUILD=stack ARGS="--resolver nightly"-    compiler: ": #stack nightly osx"-    os: osx--  allow_failures:-  - env: BUILD=cabal GHCVER=head  CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7-  - env: BUILD=stack ARGS="--resolver nightly"--before_install:-# Using compiler above sets CC to an invalid value, so unset it-- unset CC--# We want to always allow newer versions of packages when building on GHC HEAD-- CABALARGS=""-- if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi--# Download and unpack the stack executable-- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH-- mkdir -p ~/.local/bin-- |-  if [ `uname` = "Darwin" ]-  then-    travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin-  else-    travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'-  fi--  # Use the more reliable S3 mirror of Hackage-  mkdir -p $HOME/.cabal-  echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config-  echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config--  if [ "$CABALVER" != "1.16" ]-  then-    echo 'jobs: $ncpus' >> $HOME/.cabal/config-  fi--# Get the list of packages from the stack.yaml file-- PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@')--install:-- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"-- if [ -f configure.ac ]; then autoreconf -i; fi-- |-  set -ex-  case "$BUILD" in-    stack)-      stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies-      ;;-    cabal)-      cabal --version-      travis_retry cabal update-      cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES-      ;;-  esac-  set +ex--script:-- |-  set -ex-  case "$BUILD" in-    stack)-      stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps-      ;;-    cabal)-      cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES--      ORIGDIR=$(pwd)-      for dir in $PACKAGES-      do-        cd $dir-        cabal check || [ "$CABALVER" == "1.16" ]-        cabal sdist-        PKGVER=$(cabal info . | awk '{print $2;exit}')-        SRC_TGZ=$PKGVER.tar.gz-        cd dist-        tar zxfv "$SRC_TGZ"-        cd "$PKGVER"-        cabal configure --enable-tests-        cabal build-        cd $ORIGDIR-      done-      ;;-  esac-  set +ex-```--Not only will this build and test your project against multiple GHC versions-and snapshots, but it will cache your snapshot built packages, meaning that-subsequent builds will be much faster.--Once Travis whitelists the stack .deb files, we'll be able to simply include-stack in the `addons` section, and automatically use the newest version of-stack, avoiding that complicated `before_install` section This is being-tracked in the-[apt-source-whitelist](https://github.com/travis-ci/apt-source-whitelist/pull/7)-and-[apt-package-whitelist](https://github.com/travis-ci/apt-package-whitelist/issues/379)-issue trackers.--In case you're wondering: we need `--no-terminal` because stack does some fancy-sticky display on smart terminals to give nicer status and progress messages,-and the terminal detection is broken on Travis.+This content has been moved to a dedicated+[Travis CI document](https://docs.haskellstack.org/en/stable/travis_ci/).  ### Shell auto-completion
doc/MAINTAINER_GUIDE.md view
@@ -1,9 +1,18 @@ # Maintainer guide +## Next release:++* Consider moving all the release scripts stuff to a separate repo, or make it+  easy to run the release tools from a separate repo than the version of Stack+  being released. This will make it much easier to adjust the release process as+  we go without ending up with stack binaries build from different git commit+  IDs.+ ## Pre-release steps  * Ensure `release` and `stable` branches merged to `master`-* Ensure integration tests pass on a representative Windows, Mac OS X, and Linux (Linux+* Check compatibility with latest stackage snapshot+* 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@@ -33,8 +42,8 @@           due to merges     * Review documentation for any changes that need to be made         * Search for old Stack version, unstable stack version, and the next-          "obvious" version in sequence (if doing a non-obvious jump) and replace-          with new version+          "obvious" version in sequence (if doing a non-obvious jump), and+          `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.@@ -44,7 +53,7 @@         * [Debian](https://www.debian.org/releases/) (keep at least latest two)         * [CentOS](https://wiki.centos.org/Download)         * [Fedora](https://fedoraproject.org/wiki/Releases)-    * Check for new FreeBSD release+    * 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),       [install_and_upgrade.md](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md),@@ -69,14 +78,14 @@   `GITHUB_AUTHORIZATION_TOKEN`, `AWS_ACCESS_KEY_ID`, `AWS_SECRET_ACCESS_KEY`,   `AWS_DEFAULT_REGION`. -    Note: since one of the tools (rpm-s3 on CentOS) doesn't support AWS temporary-    credentials, you can't use MFA with the AWS credentials (`AWS_SECURITY_TOKEN`-    is ignored).+    Note: since one of the tools (rpm-s3 on CentOS) doesn't support AWS+    temporary credentials, you can't use MFA with the AWS credentials+    (`AWS_SECURITY_TOKEN` is ignored).  * On a machine with Vagrant installed:     * Run `etc/scripts/vagrant-releases.sh` -* On Mac OS X:+* On macOS:     * Run `etc/scripts/osx-release.sh`  * On Windows:@@ -85,8 +94,15 @@     * Release Windows installers. See       [stack-installer README](https://github.com/borsboom/stack-installer#readme) -* Publish Github release+* On Linux ARMv7:+    * Run `etc/scripts/linux-armv7-release.sh` +* Build sdist using `stack sdist . --pvp-bounds=both`, and upload it to the+  Github release with a name like `stack-X.Y.Z-sdist-0.tar.gz`.++* Publish Github release. Use e.g. `git shortlog -s v1.1.2..rc/v1.2.0|sed+  's/^[0-9 ]*/* /'|sort -f` to get the list of contributors.+ * Upload package to Hackage: `stack upload . --pvp-bounds=both`  * On a machine with Vagrant installed:@@ -96,15 +112,16 @@   [stack-setup-2.yaml](https://github.com/fpco/stackage-content/blob/master/stack/stack-setup-2.yaml),   and add the new linux64 stack bindist -* Submit a PR for the+* (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>` -* [Flag the Arch Linux package as out-of-date](https://www.archlinux.org/packages/community/x86_64/stack/flag/)+* (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 origin vX.Y.Z`+  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`@@ -121,7 +138,7 @@  * Merge any changes made in the RC/release/stable branches to master. -* Announce to haskell-cafe@haskell.org haskell-stack@googlegroups.com+* Announce to haskell-cafe@haskell.org, haskell-stack@googlegroups.com,   commercialhaskell@googlegroups.com mailing lists  * Keep an eye on the@@ -146,44 +163,48 @@   4. Install the VMware guest additions, and reboot - 5. Configure a shared folder for your home directory on the host, and mount it on Z:+ 5. In **Settings**->**Update & Security**->**Windows Update**->**Advanced options**:+     * Change **Choose how updates are installed** to **Notify to schedule restart**+     * Check **Defer upgrades** - 6. Install Windows SDK (for signtool):+ 6. Configure a shared folder for your home directory on the host, and mount it on Z:++ 7. Install Windows SDK (for signtool):     http://microsoft.com/en-us/download/confirmation.aspx?id=8279 - 7. Install msysgit: https://msysgit.github.io/+ 8. Install msysgit: https://msysgit.github.io/ - 8. Install nsis-2.46.5-Unicode-setup.exe from http://www.scratchpaper.com/+ 9. Install nsis-2.46.5-Unicode-setup.exe from http://www.scratchpaper.com/ - 9: Install Stack using the Windows 64-bit installer+10: Install Stack using the Windows 64-bit installer -10. Visit https://hackage.haskell.org/ in Edge to ensure system has correct CA+11. Visit https://hackage.haskell.org/ in Edge to ensure system has correct CA     certificates -11. Get the object code certificate from+12. Get the object code certificate from     [password-store](https://github.com/fpco/password-store), in     `certificates/code_signing/fpcomplete_corporation_startssl_2015-09-22.pfx`.     Double click it in explorer and import it -12. Run in command prompt:+13. Run in command prompt:          md C:\p         md C:\p\tmp         cd \p         md c:\tmp -13. Create `C:\p\env.bat`:+14. Create `C:\p\env.bat`:          SET STACK_ROOT=C:\p\.sr         SET TEMP=C:\p\tmp         SET TMP=C:\p\tmp         SET PATH=C:\Users\IEUser\AppData\Roaming\local\bin;"c:\Program Files\Git\usr\bin";"C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin";%PATH% -14. Run `C:\p\env.bat` (do this every time you open a new command prompt)+15. Run `C:\p\env.bat` (do this every time you open a new command prompt) -15. Import the `dev@fpcomplete.com` (0x575159689BEFB442) GPG secret key+16. Import the `dev@fpcomplete.com` (0x575159689BEFB442) GPG secret key -16. Run in command prompt (adjust the `user.email` and `user.name` settings):+17. Run in command prompt (adjust the `user.email` and `user.name` settings):          stack setup         stack install cabal-install@@ -196,6 +217,137 @@         git clone git@github.com:commercialhaskell/stack.git         git clone git@github.com:borsboom/stack-installer.git +## Setting up an ARM VM for releases++These instructions assume the host system is running macOS. Some steps will vary+with a different host OS.++### Install qemu on host++    brew install qemu++### Install fuse-ext2++    brew install e2fsprogs m4 automake autoconf libtool && \+    git clone https://github.com/alperakcan/fuse-ext2.git && \+    cd fuse-ext2 && \++Add `m4_ifdef([AM_PROG_AR], [AM_PROG_AR])` to the `configure.ac` after+`m4_ifdef([AC_PROG_LIB],[AC_PROG_LIB],[m4_warn(portability,[Missing AC_PROJ_LIB])])`+line.++    PKG_CONFIG_PATH="$(brew --prefix e2fsprogs)/lib/pkgconfig" \+        CFLAGS="-idirafter/$(brew --prefix e2fsprogs)/include -idirafter/usr/local/include/osxfuse" \+        LDFLAGS="-L$(brew --prefix e2fsprogs)/lib" \+        ./configure++### Create VM and install Debian in it++    wget http://ftp.de.debian.org/debian/dists/jessie/main/installer-armhf/current/images/netboot/initrd.gz && \+    wget http://ftp.de.debian.org/debian/dists/jessie/main/installer-armhf/current/images/netboot/vmlinuz && \+    wget http://ftp.de.debian.org/debian/dists/jessie/main/installer-armhf/current/images/device-tree/vexpress-v2p-ca9.dtb && \+    qemu-img create -f raw armdisk.raw 15G && \+    qemu-system-arm -M vexpress-a9 -cpu cortex-a9 -kernel vmlinuz -initrd initrd.gz -sd armdisk.raw -append "root=/dev/mmcblk0p2" -m 1024M -redir tcp:2223::22 -dtb vexpress-v2p-ca9.dtb -append "console=ttyAMA0,115200" -serial stdio++Now the Debian installer will run. Don't use LVM for partitioning (it won't+BOOT), and add at least 2 GB swap during installation.++### Get boot files after install++    hdiutil attach -imagekey diskimage-class=CRawDiskImage -nomount armdisk.raw && \+    mkdir -p /Volumes/armdeb && \+    fuse-ext2 /dev/disk2s1 /Volumes/armdeb/ && \+    sleep 5 && \+    cp /Volumes/armdeb/vmlinuz-3.16.0-4-armmp . && \+    cp /Volumes/armdeb/initrd.img-3.16.0-4-armmp . && \+    hdiutil detach /dev/disk2++### Boot VM++    qemu-system-arm -M vexpress-a9 -cpu cortex-a9 -kernel vmlinuz-3.16.0-4-armmp -initrd initrd.img-3.16.0-4-armmp -sd armdisk.raw -m 1024M -dtb vexpress-v2p-ca9.dtb -append "root=/dev/mmcblk0p2 console=ttyAMA0,115200" -serial stdio -redir tcp:2223::22++### Setup rest of system++Log onto the VM as root, then (replace `<<<USERNAME>>>` with the user you set up+during Debian installation):++    apt-get update && \+    apt-get install -y sudo && \+    adduser <<<USERNAME>>> sudo++Now you can SSH to the VM using `ssh -p 2223 <<<USERNAME>>>@localhost` and use `sudo` in+the shell.++### Install clang+llvmGHC/clang++NOTE: the Debian jessie `llvm` packge does not work (executables built with it+just exit with "schedule: re-entered unsafely.").++The version of LLVM needed depends on the version of GHC you need.++#### GHC 7.10.3 (the standard for building Stack)++    sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make xz-utils zlib1g-dev git gnupg && \+    wget http://llvm.org/releases/3.5.2/clang+llvm-3.5.2-armv7a-linux-gnueabihf.tar.xz && \+    sudo tar xvf clang+llvm-3.5.2-armv7a-linux-gnueabihf.tar.xz -C /opt++Run this now and add it to the `.profile`:++    export PATH="$HOME/.local/bin:/opt/clang+llvm-3.5.2-armv7a-linux-gnueabihf/bin:$PATH"++#### GHC 8.0.1++    wget http://llvm.org/releases/3.7.1/clang+llvm-3.7.1-armv7a-linux-gnueabihf.tar.xz && \+    sudo tar xvf clang+llvm-3.7.1-armv7a-linux-gnueabihf.tar.xz -C /opt++Run this now and add it to the `.profile`:++    export PATH="$HOME/.local/bin:/opt/clang+llvm-3.5.2-armv7a-linux-gnueabihf/bin:$PATH"++### Install Stack++#### Binary++Get an [existing `stack` binary](https://github.com/commercialhaskell/stack/releases)+and put it in `~/.local/bin`.++#### From source (using cabal-install):++    wget http://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-armv7-deb8-linux.tar.xz && \+    tar xvf ghc-7.10.3-armv7-deb8-linux.tar.xz && \+    cd ghc-7.10.3 && \+    ./configure --prefix=/opt/ghc-7.10.3 && \+    sudo make install && \+    cd ..+    export PATH="/opt/ghc-7.10.3/bin:$PATH"+    wget https://www.haskell.org/cabal/release/cabal-install-1.24.0.0/cabal-install-1.24.0.0.tar.gz &&&&& \+    tar xvf cabal-install-1.24.0.0.tar.gz && \+    cd cabal-install-1.24.0.0 && \+    EXTRA_CONFIGURE_OPTS="" ./bootstrap.sh && \+    cd .. && \+    export PATH="$HOME/.cabal/bin:$PATH" && \+    cabal update++Edit `~/.cabal/config`, and set `executable-stripping: False` and+`library-stripping: False`.++    cabal unpack stack && \+    cd stack-* && \+    cabal install && \+    mv ~/.cabal/bin/stack ~/.local/bin++### Resources++  - http://mashu.github.io/2015/08/12/QEMU-Debian-armhf.html+  - https://www.aurel32.net/info/debian_arm_qemu.php+  - http://linuxdeveloper.blogspot.ca/2011/08/how-to-install-arm-debian-on-ubuntu.html+  - http://www.macworld.com/article/2855038/how-to-mount-and-manage-non-native-file-systems-in-os-x-with-fuse.html+  - https://github.com/alperakcan/fuse-ext2#mac-os+  - https://github.com/alperakcan/fuse-ext2/issues/31#issuecomment-214713801+  - https://github.com/alperakcan/fuse-ext2/issues/33#issuecomment-216758378+  - https://github.com/alperakcan/fuse-ext2/issues/32#issuecomment-216758019+  - http://osxdaily.com/2007/03/23/create-a-ram-disk-in-mac-os-x/+ ## Adding a new GHC version    * Push new tag to our fork:@@ -213,12 +365,13 @@     [stack-setup-2.yaml](https://github.com/fpco/stackage-content/blob/master/stack/stack-setup-2.yaml)     for the ones we used in the last GHC release). -    In the case of OS X, repackage the `.xz` bindist as a `.bz2`, since OS X does+    In the case of macOS, repackage the `.xz` bindist as a `.bz2`, since macOS does     not include `xz` by default or provide an easy way to install it.    * Build any additional required bindists (see below for instructions) -      * libtinfo6 (etc/vagrant/fedora24-x86_64)+      * tinfo6 (`etc/vagrant/fedora24-x86_64`)+      * ncurses6 (`etc/vagrant/arch-x86_64`)    * [Edit stack-setup-2.yaml](https://github.com/fpco/stackage-content/edit/master/stack/stack-setup-2.yaml)     and add the new bindists, pointing to the Github release version. Be sure to@@ -226,10 +379,17 @@  ### Building GHC -Set the `GHC_VERSION` environment variable to the version to build.+On systems with a small `/tmp`, you should set TMP and TEMP to an alternate+location. -For GHC >= 7.10.2, run (from [here](https://ghc.haskell.org/trac/ghc/wiki/Newcomers)):+For GHC >= 7.10.2, set the `GHC_VERSION` environment variable to the version to build: +    * `export GHC_VERSION=8.0.1`+    * `export GHC_VERSION=7.10.3a`+    * `export GHC_VERSION=7.10.2`++then, run (from [here](https://ghc.haskell.org/trac/ghc/wiki/Newcomers)):+     git config --global url."git://github.com/ghc/packages-".insteadOf git://github.com/ghc/packages/ && \     git clone -b ghc-${GHC_VERSION}-release --recursive git://github.com/ghc/ghc ghc-${GHC_VERSION} && \     cd ghc-${GHC_VERSION}/ && \@@ -243,6 +403,7 @@  GHC 7.8.4 is slightly different: +    export GHC_VERSION=7.8.4 && \     git config --global url."git://github.com/ghc/packages-".insteadOf git://github.com/ghc/packages/ && \     git clone -b ghc-${GHC_VERSION}-release --recursive git://github.com/ghc/ghc ghc-${GHC_VERSION} && \     cd ghc-${GHC_VERSION}/ && \
doc/README.md view
@@ -27,7 +27,7 @@ operating system/distribution:  * [Windows](install_and_upgrade.md#windows)-* [Mac OS X](install_and_upgrade.md#mac-os-x)+* [macOS](install_and_upgrade.md#mac-os-x) * [Ubuntu](install_and_upgrade.md#ubuntu) * [Debian](install_and_upgrade.md#debian) * [CentOS / Red Hat / Amazon Linux](install_and_upgrade.md#centos)@@ -58,8 +58,8 @@ the needed files to start a project correctly. - The `stack setup` will download the compiler if necessary in an isolated   location (default `~/.stack`) that won't interfere with any system-level-  installations. (For information on installation paths, please use the `stack-  path` command.).+  installations. (For information on installation paths, please use the+  `stack path` command.). - The `stack build` command will build the minimal project. - `stack exec my-project-exe` will execute the command. - If you just want to install an executable using stack, then all you have to do
doc/architecture.md view
@@ -3,27 +3,55 @@ ## Terminology  * Package identifier: a package name and version, e.g. text-1.2.1.0-* GhcPkgId: a package identifier plus the unique hash for the generated binary, e.g. text-1.2.1.0-bb83023b42179dd898ebe815ada112c2-* Package index: a collection of packages available for download. This is a combination of an index containing all of the .cabal files (either a tarball downloaded via HTTP(S) or a Git repository) and some way to download package tarballs.-    * By default, stack uses a single package index (the Github/S3 mirrors of Hackage), but supports customization and adding more than one index+* GhcPkgId: a package identifier plus the unique hash for the generated binary,+  e.g. text-1.2.1.0-bb83023b42179dd898ebe815ada112c2+* Package index: a collection of packages available for download. This is a+  combination of an index containing all of the .cabal files (either a tarball+  downloaded via HTTP(S) or a Git repository) and some way to download package+  tarballs.+    * By default, stack uses a single package index (the Github/S3 mirrors of+      Hackage), but supports customization and adding more than one index * Package database: a collection of metadata about built libraries-* Install root: a destination for installing packages into. Contains a bin path (for generated executables), lib (for the compiled libraries), pkgdb (for the package database), and a few other things-* Snapshot: an LTS Haskell or Stackage Nightly, which gives information on a complete set of packages. This contains a lot of metadata, but importantly it can be converted into a mini build plan...-* Mini build plan: a collection of package identifiers and their build flags that are known to build together-* Resolver: the means by which stack resolves dependencies for your packages. The two currently supported options are snapshot (using LTS or Nightly), and GHC (which installs no extra dependencies). Others may be added in the future (such as a SAT-based dependency solver). These packages are always taken from a package index-* extra-deps: additional packages to be taken from the package index for dependencies. This list will *shadow* packages provided by the resolver-* Local packages: source code actually present on your file system, and referred to by the `packages` field in your stack.yaml file. Each local package has exactly one .cabal file-* Project: a stack.yaml config file and all of the local packages it refers to. +* Install root: a destination for installing packages into. Contains a bin path+  (for generated executables), lib (for the compiled libraries), pkgdb (for the+  package database), and a few other things+* Snapshot: an LTS Haskell or Stackage Nightly, which gives information on a+  complete set of packages. This contains a lot of metadata, but importantly it+  can be converted into a mini build plan...+* Mini build plan: a collection of package identifiers and their build flags+  that are known to build together+* Resolver: the means by which stack resolves dependencies for your packages.+  The two currently supported options are snapshot (using LTS or Nightly), and+  GHC (which installs no extra dependencies). Others may be added in the future+  (such as a SAT-based dependency solver). These packages are always taken from+  a package index+* extra-deps: additional packages to be taken from the package index for+  dependencies. This list will *shadow* packages provided by the resolver+* Local packages: source code actually present on your file system, and+  referred to by the `packages` field in your stack.yaml file. Each local+  package has exactly one .cabal file+* Project: a stack.yaml config file and all of the local packages it refers to.  ## Databases -Every build uses three distinct install roots, which means three separate package databases and bin paths. These are:+Every build uses three distinct install roots, which means three separate+package databases and bin paths. These are: -* Global: the packages that ship with GHC. We never install anything into this database-* Snapshot: a database shared by all projects using the same snapshot. Packages installed in this database must use the exact same dependencies and build flags as specified in the snapshot, and cannot be affected by user flags, ensuring that one project cannot corrupt another. There are two caveats to this:-    * If different projects use different package indices, then their definitions of what package foo-1.2.3 are may be different, in which case they *can* corrupt each other's shared databases. This is warned about in the FAQ-    * Turning on profiling may cause a package to be recompiled, which will result in a different GhcPkgId-* Local: extra-deps, local packages, and snapshot packages which depend on them (more on that in shadowing)+* Global: the packages that ship with GHC. We never install anything into this+  database+* Snapshot: a database shared by all projects using the same snapshot. Packages+  installed in this database must use the exact same dependencies and build+  flags as specified in the snapshot, and cannot be affected by user flags,+  ensuring that one project cannot corrupt another. There are two caveats to+  this:+    * If different projects use different package indices, then their+      definitions of what package foo-1.2.3 are may be different, in which case+      they *can* corrupt each other's shared databases. This is warned about in+      the FAQ+    * Turning on profiling may cause a package to be recompiled, which will+      result in a different GhcPkgId+* Local: extra-deps, local packages, and snapshot packages which depend on them+  (more on that in shadowing)  ## Building @@ -34,8 +62,11 @@ the local/extradep *shadows* the snapshot version. The way this works is:  * The package is removed from the list of packages in the snapshot-* Any package that depends on that package (directly or indirectly) is moved from the snapshot to extra-deps, so that it is available to your packages as dependencies.-    * Note that there is no longer any guarantee that this package will build, since you're using an untested dependency+* Any package that depends on that package (directly or indirectly) is moved+  from the snapshot to extra-deps, so that it is available to your packages as+  dependencies.+    * Note that there is no longer any guarantee that this package will build,+      since you're using an untested dependency  After shadowing, you end up with what is called internally a `SourceMap`, which is `Map PackageName PackageSource`, where a `PackageSource` can be either a@@ -48,9 +79,12 @@ decide which of the installed packages you wish to use from them. We move from the global, to snapshot, and finally local, with the following rules: -* If we require profiling, and the library does not provide profiling, do not use it-* If the package is in the `SourceMap`, but belongs to a difference database, or has a different version, do not use it-* If after the above two steps, any of the dependencies are unavailable, do not use it+* If we require profiling, and the library does not provide profiling, do not+  use it+* If the package is in the `SourceMap`, but belongs to a difference database,+  or has a different version, do not use it+* If after the above two steps, any of the dependencies are unavailable, do not+  use it * Otherwise: include the package in the list of installed packages  We do something similar for executables, but maintain our own database of@@ -65,8 +99,10 @@ authoritative on this and should be consulted. The basic idea though is:  * If any of the dependencies have changed, reconfigure and rebuild-* If a local package has any files changed, rebuild (but don't bother reconfiguring)-* If a local package is wanted and we're running tests or benchmarks, run the test or benchmark even if the code and dependencies haven't changed+* If a local package has any files changed, rebuild (but don't bother+  reconfiguring)+* If a local package is wanted and we're running tests or benchmarks, run the+  test or benchmark even if the code and dependencies haven't changed  ### Plan execution @@ -97,14 +133,23 @@ configuration with a single package (the current directory) and an auto-detected snapshot. The algorithm it uses for selecting this snapshot is: -* Try the latest two LTS major versions at their most recent minor version release, and the most recent Stackage Nightly. For example, at the time of writing, this would be lts-2.10, lts-1.15, and nightly-2015-05-26-* For each of these, test the version bounds in the package's .cabal file to see if they are compatible with the snapshot, choosing the first one that matches-* If no snapshot matches, uses the most recent LTS snapshot, even though it will not compile+* Try the latest two LTS major versions at their most recent minor version+  release, and the most recent Stackage Nightly. For example, at the time of+  writing, this would be lts-2.10, lts-1.15, and nightly-2015-05-26+* For each of these, test the version bounds in the package's .cabal file to+  see if they are compatible with the snapshot, choosing the first one that+  matches+* If no snapshot matches, uses the most recent LTS snapshot, even though it+  will not compile -If you end up in the no compatible snapshot case, you typically have three options to fix things:+If you end up in the no compatible snapshot case, you typically have three+options to fix things: -* Manually specify a different snapshot that you know to be compatible. If you can do that, great, but typically if the auto-detection fails, it means that there's no compatible snapshot-* Modify version bounds in your .cabal file to be compatible with the selected snapshot+* Manually specify a different snapshot that you know to be compatible. If you+  can do that, great, but typically if the auto-detection fails, it means that+  there's no compatible snapshot+* Modify version bounds in your .cabal file to be compatible with the selected+  snapshot * Add `extra-deps` to your stack.yaml file to fix compatibility problems  Remember that running `stack build` will give you information on why your build@@ -128,6 +173,10 @@ *explicit* and *contained* activity. Specifically, you get the following guarantees: -* Since snapshots are immutable, the snapshot package database will not be invalidated by any action. If you change the snapshot you're using, however, you may need to build those packages from scratch.-* If you modify your extra-deps, stack may need to unregister and reinstall them.-* Any changes to your local packages trigger a rebuild of that package and its dependencies.+* Since snapshots are immutable, the snapshot package database will not be+  invalidated by any action. If you change the snapshot you're using, however,+  you may need to build those packages from scratch.+* If you modify your extra-deps, stack may need to unregister and reinstall+  them.+* Any changes to your local packages trigger a rebuild of that package and its+  dependencies.
doc/build_command.md view
@@ -60,20 +60,49 @@ build` takes a list of zero or more *targets* to be built. There are a number of different syntaxes supported for this list: -*   *package*, e.g. `stack build foobar`, is the most commonly used target. It will try to find the package in the following locations: local packages, extra dependencies, snapshots, and package index (e.g. Hackage). If it's found in the package index, then the latest version of that package from the index is implicitly added to your extra dependencies.+*   *package*, e.g. `stack build foobar`, is the most commonly used target. It+    will try to find the package in the following locations: local packages,+    extra dependencies, snapshots, and package index (e.g. Hackage). If it's+    found in the package index, then the latest version of that package from+    the index is implicitly added to your extra dependencies. -    This is where the `--test` and `--bench` flags come into play. If the package is a local package, then all of the test suite and benchmark components are selected to be built, respectively. In any event, the library and executable components are also selected to be built.+    This is where the `--test` and `--bench` flags come into play. If the+    package is a local package, then all of the test suite and benchmark+    components are selected to be built, respectively. In any event, the+    library and executable components are also selected to be built. -*   *package identifier*, e.g. `stack build foobar-1.2.3`, is usually used to include specific package versions from the index. If the version selected conflicts with an existing local package or extra dep, then stack fails with an error. Otherwise, this is the same as calling `stack build foobar`, except instead of using the latest version from the index, the version specified is used.+*   *package identifier*, e.g. `stack build foobar-1.2.3`, is usually used to+    include specific package versions from the index. If the version selected+    conflicts with an existing local package or extra dep, then stack fails+    with an error. Otherwise, this is the same as calling `stack build foobar`,+    except instead of using the latest version from the index, the version+    specified is used. -*   *component*. Instead of referring to an entire package and letting stack decide which components to build, you select individual components from inside a package. This can be done for more fine-grained control over which test suites to run, or to have a faster compilation cycle. There are multiple ways to refer to a specific component (provided for convenience):+*   *component*. Instead of referring to an entire package and letting stack+    decide which components to build, you select individual components from+    inside a package. This can be done for more fine-grained control over which+    test suites to run, or to have a faster compilation cycle. There are+    multiple ways to refer to a specific component (provided for convenience): -    * `packagename:comptype:compname` is the most explicit. The available comptypes are `exe`, `test`, and `bench`.-    * `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`.-    * `:compname` is a useful shortcut, saying "find the component in all of the local packages." This will result in an error if multiple packages have a component with the same name. To continue the above example, `stack build :mytestsuite`.-        * Side note: the commonly requested `run` command is not available because it's a simple combination of `stack build :exename && stack exec exename`+    * `packagename:comptype:compname` is the most explicit. The available+      comptypes are `exe`, `test`, and `bench`.+    * `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`.+    * `:compname` is a useful shortcut, saying "find the component in all of+      the local packages." This will result in an error if multiple packages+      have a component with the same name. To continue the above example,+      `stack build :mytestsuite`.+        * Side note: the commonly requested `run` command is not available+          because it's a simple combination of `stack build :exename && stack+          exec exename` -* *directory*, e.g. `stack build foo/bar`, will find all local packages that exist in the given directory hierarchy and then follow the same procedure as passing in package names as mentioned above. There's an important caveat here: if your directory name is parsed as one of the above target types, it will be treated as that. Explicitly starting your target with `./` can be a good way to avoid that, e.g. `stack build ./foo`+* *directory*, e.g. `stack build foo/bar`, will find all local packages that+  exist in the given directory hierarchy and then follow the same procedure as+  passing in package names as mentioned above. There's an important caveat+  here: if your directory name is parsed as one of the above target types, it+  will be treated as that. Explicitly starting your target with `./` can be a+  good way to avoid that, e.g. `stack build ./foo`  Finally: if you provide no targets (e.g., running `stack build`), stack will implicitly pass in all of your local packages. If you only want to target@@ -131,11 +160,28 @@  This command will: -* Start stack up in file watch mode, waiting for files in your project to change. When first starting, and each time a file changes, it will do all of the following.+* Start stack up in file watch mode, waiting for files in your project to+  change. When first starting, and each time a file changes, it will do all of+  the following. * Build the wai-extra package and its test suites * Build the `warp` executable-* Build the warp package's doctest component (which, as you may guess, is a test site)-* Run all of the wai-extra package's test suite components and the doctest test suite component+* Build the warp package's doctest component (which, as you may guess, is a+  test site)+* Run all of the wai-extra package's test suite components and the doctest test+  suite component * If all of that succeeds:     * Copy generated executables to the local bin path     * Run the command `echo Yay, it worked!`++## Build output++When building a single target package (e.g., `stack build` in a project with+only one package, or `stack build package-name` in a multi-package project),+the build output from GHC will be hidden for building all dependencies, and+will be displayed for the one target package.++By default, when building multiple target packages, the output from these will+end up in a log file instead of on the console unless it contains errors or+warnings, to avoid problems of interleaved output and decrease console noise.+If you would like to see this content instead, you can use the `--dump-logs`+command line option, or add `dump-logs: all` to your `stack.yaml` file.
+ doc/coverage.md view
@@ -0,0 +1,120 @@+# Code Coverage++Code coverage is enabled by passing the `--coverage` flag to `stack build`.++## Usage++`stack test --coverage` is quite streamlined for the following use-case:++1. You have test-suites which exercise your local packages.++2. These test-suites link against your library, rather than building the library+   directly. Coverage information is only given for libraries, ignoring the+   modules which get compiled directly into your executable. A common case where+   this doesn't happen is when your test-suite and library both have something+   like `hs-source-dirs: src/`. In this case, when building your test-suite you+   may also be compiling your library, instead of just linking against it.++When your project has these properties, you will get the following:++1) Textual coverage reports in the build output.++2) A unified textual and HTML report, considering the coverage on all local+  libraries, based on all of the tests that were run.++3) An index of all generated HTML reports, at `$(stack path+   --local-hpc-root)/index.html`.++## "stack hpc report" command++The `stack hpc report` command generates a report for a selection of targets and+`.tix` files.  For example, if we have 3 different packages with test-suites,+packages `A`, `B`, and `C`, the default unified report will have coverage from+all 3.  If we want a unified report with just two, we can instead run:++```+$ stack hpc report A B+```++This will output a textual report for the combined coverage from `A` and `B`'s+test-suites, along with a path to the HTML for the report.  To further+streamline this process, you can pass the `--open` option, to open the report in+your browser.++This command also supports taking extra `.tix` files.  If you've also built an+executable, against exactly the same library versions of `A`, `B`, and `C`, then+you could do the following:++```+$ stack exec -- an-exe+$ stack hpc report A B C an-exe.tix+```++This report will consider all test results as well as the newly generated+`an-exe.tix` file.  Since this is a common use-case, there is a convenient flag+to use all stored results - `stack hpc report --all an-exe.tix`.++## "extra-tix-files" directory++During the execution of the build, you can place additional tix files in+`$(stack path --local-hpc-root)/extra-tix-files/` in order for them to be+included in the unified report. A couple caveats:++* These tix files must be generated by executables that are built against the+exact same library versions. Also note that, on subsequent builds with coverage,+the `$(stack path --local-hpc-root)` directory will be recursively deleted. It+just stores the most recent coverage data.++* These tix files will not be considered by `stack hpc report` unless listed+explicitly by file name.++## Implementation details++Most users can get away with just understanding the above documentation.+However, advanced users may want to understand exactly how `--coverage` works:++1. The GHC option `-fhpc` gets passed to all local packages.  This tells GHC to+   output executables that track coverage information and output them to `.tix`+   files. `the-exe-name.tix` files will get written to the working directory of+   the executable.++   When switching on this flag, it will usually cause all local packages to be+   rebuilt (see [#1940](https://github.com/commercialhaskell/stack/issues/1940).++2. Before the build runs with `--coverage`, the contents of `stack path+   --local-hpc-root` gets deleted. This prevents old reports from getting mixed+   with new reports. If you want to preserve report information from multiple+   runs, copy the contents of this path to a new folder.++3. Before a test run, if a `test-name.tix` file exists in the package directory,+   it will be deleted.++4. After a test run, it will expect a `test-name.tix` file to exist. This file+   will then get loaded, modified, and outputted to `$(stack path+   --local-hpc-root)/pkg-name/test-name/test-name.tix)`.++   The `.tix` file gets modified to remove coverage file that isn't associated+   with a library. So, this means that you won't get coverage information for+   the modules compiled in the `executable` or `test-suite` stanza of your cabal+   file. This makes it possible to directly union multiple `*.tix` files from+   different executables (assuming they are using the exact same versions of the+   local packages).++   If there is enough popular demand, it may be possible in the future to give+   coverage information for modules that are compiled directly into the+   executable. See+   [#1359](https://github.com/commercialhaskell/stack/issues/1359).++5. Once we have a `.tix` file for a test, we also generate a textual and HTML+   report for it. The textual report is sent to the terminal. The index of the+   test-specific HTML report is available at `$(stack path+   --local-hpc-root)/pkg-name/test-name/index.html`++6. After the build completes, if there are multiple output `*.tix` files, they+   get combined into a unified report. The index of this report will be+   available at `$(stack path --local-hpc-root)/combined/all/index.html`++7. Finally, an index of the resulting coverage reports is generated. It links to+   the individual coverage reports (one for each test-suite), as well as the+   unified report. This index is available at `$(stack path+   --local-hpc-root)/index.html`
+ doc/custom_snapshot.md view
@@ -0,0 +1,173 @@+# Custom Snapshots++Custom snapshots allow you to create your own snapshots, which provide a list of+specific hackage packages to use, along with flags and ghc-options.  The+definition of a basic snapshot looks like the following:++```yaml+resolver: ghc-8.0++packages:+  - unordered-containers-0.2.7.1+  - hashable-1.2.4.0+  - text-1.2.2.1++flags:+  unordered-containers:+    debug: true+```++If you put this in a `snapshot.yaml` file in the same directory as your project,+you can now use the custom snapshot like this:++```yaml+resolver:+  name: simple-snapshot  # Human readable name for the snapshot+  location: simple-snapshot.yaml+```++This is an example of a custom snapshot stored in the filesystem. They are+assumed to be mutable, so you are free to modify it. We detect that the snapshot+has changed by hashing the contents of the involved files, and using it to+identify the snapshot internally. It is often reasonably efficient to modify a+custom snapshot, due to stack sharing snapshot packages whenever possible.++## Using a URL instead of a filepath++For efficiency, URLs are treated differently. If I uploaded the snapshot to+`https://domain.org/snapshot-1.yaml`, it is expected to be immutable. If you+change that file, then you lose any reproducibility guarantees.++## Extending snapshots++The example custom snapshot above uses a compiler resolver, and so has few+packages.  We can also extend existing snapshots, by using the usual+[resolver setting found in stack configurations](yaml_configuration.md#resolver).+All possible resolver choices are valid, so this means that custom snapshots can+even extend other custom snapshots.++Lets say that we want to use `lts-7.1`, but use a different version of `text`+than the one it comes with, `1.2.2.1`.  To downgrade it to `1.2.2.0`, we need a+custom snapshot file with the following:++```yaml+resolver: lts-7.1+packages:+  - text-1.2.2.0+```++### Overriding the compiler++The following snapshot specification will be identical to `lts-7.1`, but instead+use `ghc-7.10.3` instead of `ghc-8.0.1`:++```yaml+resolver: lts-7.1+compiler: ghc-7.10.3+```++### Dropping packages++The following snapshot specification will be identical to `lts-7.1`, but without+the `text` package in our snapshot. Removing this package will cause all the+packages that depend on `text` to be unbuildable, but they will still be present+in the snapshot.++```yaml+resolver: lts-7.1+drop-packages:+  - text+```++### Specifying ghc-options++In order to specify ghc-options for a package, you use the same syntax as the+[ghc-options](yaml_configuration.md#ghc-options) field for build configuration.+The following snapshot specification will be identical to `lts-7.1`, but+provides `-O1` as a ghc-option for `text`:++```yaml+resolver: lts-7.1+packages:+  - text-1.2.2.1+ghc-options:+  text: -O1+```++This works somewhat differently than the stack.yaml `ghc-options` field, in that+options can only be specified for packages that are mentioned in the custom+snapshot's `packages` list. It sets the ghc-options, rather than extending those+specified in the snapshot being extended.++Another difference is that the `*` entry for `ghc-options` applies to all+packages in the `packages` list, rather than all packages in the snapshot.++### Specifying flags++In order to specify flags for a package, you use the same syntax as the+[flags](yaml_configuration.md#flags) field for build configuration. The+following snapshot specification will be identical to `lts-7.1`, but+it enables the `developer` cabal flag:++```yaml+resolver: lts-7.1+packages:+  - text-1.2.2.1+ghc-options:+  text:+    developer: true+```++## YAML format++In summary, the YAML format of custom snapshots has the following fields which+are directly related to the same fields in the+[build configuration format](yaml_configuration.md):++* `resolver`, which specifies which snapshot to extend. It takes the same values+  as the [`resolver` field in stack.yaml](yaml_configuration.md#resolver).++* `compiler`, which specifies or overrides the selection of compiler. If+  `resolver` is absent, then a specification of `compiler` is required. Its+  semantics are the same as the+  [`compiler` field in stack.yaml](yaml_configuration.md#compiler).++Some fields look similar, but behave differently:++* `flags` specifies which cabal flags to use with each package. In order to+  specify a flag for a package, it *must* be listed in the `packages` list.++* `ghc-options`, which specifies which cabal flags to use with each package. In+  order to specify ghc-options for a package, it *must* be listed in the+  `packages` list. The `*` member of the map specifies flags that apply to every+  package in the `packages` list.++There are two fields which work differently than in the build configuration+format:++* `packages`, which specifies a list of hackage package versions.  Note that+  when a package version is overridden, no `flags` or `ghc-options` are taken+  from the snapshot that is being extended.  If you want the same options as the+  snapshot being extended, they must be re-specified.++* `drop-packages`, which specifies a list of packages to drop from the snapshot+  being overridden.++## Future enhancements++We plan to enhance extensible snapshots in several ways in the future. See+[issue #1265, about "implicit snapshots"](https://github.com/commercialhaskell/stack/issues/1265).+In summary, in the future:++1) It will be possible to use a specific git repository + commit hash in the+`packages` list, like in regular stack.yaml configuration. Currently, custom+snapshots only work with packages on hackage.++2) `stack.yaml` configurations will implicitly create a snapshot. This means+that the non-local packages will get shared between your projects, so there is+less redundant compilation!++3) `flags` and `ghc-options` for packages which are not listed in `packages` are+silently ignored. See+[#2654](https://github.com/commercialhaskell/stack/issues/2654) for the current+status of this.
doc/dependency_visualization.md view
@@ -1,6 +1,7 @@ # Dependency visualization -You can use stack to visualize the dependencies between your packages and optionally also external dependencies.+You can use stack to visualize the dependencies between your packages and+optionally also external dependencies.  As an example, let's look at `wreq`: @@ -15,7 +16,8 @@ ``` [![wreq_ext](https://cloud.githubusercontent.com/assets/591567/8478621/d247247e-20d2-11e5-993d-79096e382abd.png)](https://cloud.githubusercontent.com/assets/591567/8478621/d247247e-20d2-11e5-993d-79096e382abd.png) -Well that is certainly a lot.  As a start we can exclude `base` and then depending on our needs we can either limit the depth:+Well that is certainly a lot.  As a start we can exclude `base` and then+depending on our needs we can either limit the depth:  ``` $ stack dot --no-include-base --external --depth 1 | dot -Tpng -o wreq.png@@ -41,3 +43,13 @@ $ stack dot --external --prune base,lens,wreq-examples,http-client,aeson,tls,http-client-tls,exceptions | twopi -Groot=wreq -Goverlap=false -Tpng -o wreq_pruned.png ``` [![wreq_pruned](https://cloud.githubusercontent.com/assets/591567/8495538/9fae1184-216e-11e5-9931-99e6147f8aed.png)](https://cloud.githubusercontent.com/assets/591567/8495538/9fae1184-216e-11e5-9931-99e6147f8aed.png)++## Specifying local targets and flags++The `dot` and `list-dependencies` commands both also accept the following+options which affect how local packages are considered:++* `TARGET`, same as the targets passed to `build`+* `--test`, specifying that test components should be considered+* `--bench`, specifying that benchmark components should be considered+* `--flag`, specifying flags which may affect cabal file `build-depends`
doc/docker_integration.md view
@@ -27,9 +27,9 @@ a 64-bit kernel. If you do not already have one, we suggest Ubuntu 14.04 ("trusty") since this is what we test with. -**Mac OS X**: [Docker for Mac](https://docs.docker.com/docker-for-mac/) is the-supported way to use Docker integration on OS X (the older Docker Machine-(boot2docker) approach to using Docker on OS X is not supported due to issues+**macOS**: [Docker for Mac](https://docs.docker.com/docker-for-mac/) is the+supported way to use Docker integration on macOS (the older Docker Machine+(boot2docker) approach to using Docker on macOS is not supported due to issues with host volume mounting that make Stack nearly unusable for anything but the most trivial projects). @@ -77,6 +77,13 @@  See [configuration](#configuration) for additional options. You can enable it on the command-line using `stack --docker`.++Please note that in a docker-enabled configuration, stack uses the GHC installed+in the Docker container by default. To use a compiler installed by stack, add++    system-ghc: false++(see [`system-ghc`](yaml_configuration.md#system-ghc)).  ### Use stack as normal
doc/faq.md view
@@ -1,20 +1,31 @@ # FAQ  So that this doesn't become repetitive: for the reasons behind the answers-below, see the [Architecture](architecture.md) page. The goal of the answers here is to be as-helpful and concise as possible.+below, see the [Architecture](architecture.md) page. The goal of the answers+here is to be as helpful and concise as possible.  ## 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 used (see the [Install and upgrade](install_and_upgrade.md) page). Stack installs the Stackage libraries in `~/.stack` and any project libraries or extra dependencies in a `.stack-work` directory within each project's directory. None of this should affect any existing Haskell tools at all.+Stack itself is installed in normal system locations based on the mechanism you+used (see the [Install and upgrade](install_and_upgrade.md) page). Stack+installs the Stackage libraries in `~/.stack` and any project libraries or+extra dependencies in a `.stack-work` directory within each project's+directory. None of this should affect any existing Haskell tools at all.  ## What is the relationship between stack and cabal?  * Cabal-the-library is used by stack to build your Haskell code.-* cabal-install (the executable) is used by stack for its dependency solver functionality.-* A .cabal file is provided for each package, and defines all package-level metadata just like it does in the cabal-install world: modules, executables, test suites, etc. No change at all on this front.-* A stack.yaml file references 1 or more packages, and provides information on where dependencies come from.-* `stack build` currently initializes a stack.yaml from the existing .cabal file. Project initialization is something that is still being discussed and there may be more options here for new projects in the future (see issue [253](https://github.com/commercialhaskell/stack/issues/253))+* cabal-install (the executable) is used by stack for its dependency solver+  functionality.+* A .cabal file is provided for each package, and defines all package-level+  metadata just like it does in the cabal-install world: modules, executables,+  test suites, etc. No change at all on this front.+* A stack.yaml file references 1 or more packages, and provides information on+  where dependencies come from.+* `stack build` currently initializes a stack.yaml from the existing .cabal+  file. Project initialization is something that is still being discussed and+  there may be more options here for new projects in the future (see issue+  [253](https://github.com/commercialhaskell/stack/issues/253))  ## I need to use a different version of a package than what is provided by the LTS Haskell snapshot I'm using, what should I do? @@ -30,7 +41,9 @@  ## I need to use a package (or version of a package) that is not available on hackage, what should I do? -Add it to the `packages` list in your project's `stack.yaml`, specifying the package's source code location relative to the directory where your `stack.yaml` file lives, e.g.+Add it to the `packages` list in your project's `stack.yaml`, specifying the+package's source code location relative to the directory where your+`stack.yaml` file lives, e.g.  ```yaml resolver: lts-2.10@@ -42,7 +55,12 @@ extra-deps: [] ``` -The above example specifies that it should include the package at the root directory (`'.'`), that the `proprietary-dep` package is found in the project's `third-party` folder, that the `conduit` package is found in the project's `github-version-of` folder, and that the `diagrams` package is found in the project's `patched` folder. This autodetects changes and reinstalls the package.+The above example specifies that it should include the package at the root+directory (`'.'`), that the `proprietary-dep` package is found in the project's+`third-party` folder, that the `conduit` package is found in the project's+`github-version-of` folder, and that the `diagrams` package is found in the+project's `patched` folder. This autodetects changes and reinstalls the+package.  To install packages directly from a Git repository, use e.g.: @@ -60,9 +78,13 @@  Those are the targets of the build, and can have one of three formats: -* A package name (e.g., `my-package`) will mean that the `my-package` package must be built-* A package identifier (e.g., `my-package-1.2.3`), which includes a specific version. This is useful for passing to `stack install` for getting a specific version from upstream-* A directory (e.g., `./my-package`) for including a local directory's package, including any packages in subdirectories+* A package name (e.g., `my-package`) will mean that the `my-package` package+  must be built+* A package identifier (e.g., `my-package-1.2.3`), which includes a specific+  version. This is useful for passing to `stack install` for getting a specific+  version from upstream+* A directory (e.g., `./my-package`) for including a local directory's package,+  including any packages in subdirectories  ## I need to modify an upstream package, how should I do it? @@ -74,7 +96,10 @@  ## Am I required to use a Stackage snapshot to use stack? -No, not at all. If you prefer dependency solving to curation, you can continue with that workflow. Instead of describing the details of how that works here, it's probably easiest to just say: run `stack init --solver` and look at the generated stack.yaml.+No, not at all. If you prefer dependency solving to curation, you can continue+with that workflow. Instead of describing the details of how that works here,+it's probably easiest to just say: run `stack init --solver` and look at the+generated stack.yaml.  ## How do I use this with sandboxes? @@ -85,12 +110,18 @@  ## Can I run `cabal` commands inside `stack exec`? -With a recent enough version of cabal-install (>= 1.22), you can. For older versions, due to [haskell/cabal#1800](https://github.com/haskell/cabal/issues/1800), this does not work. Note that even with recent versions, for some commands you may need this extra level of indirection:+With a recent enough version of cabal-install (>= 1.22), you can. For older+versions, due to+[haskell/cabal#1800](https://github.com/haskell/cabal/issues/1800), this does+not work. Note that even with recent versions, for some commands you may need+this extra level of indirection: ``` $ stack exec -- cabal exec -- cabal <command> ``` -However, virtually all `cabal` commands have an equivalent in stack, so this should not be necessary. In particular, `cabal` users may be accustomed to the `cabal run` command. In stack:+However, virtually all `cabal` commands have an equivalent in stack, so this+should not be necessary. In particular, `cabal` users may be accustomed to the+`cabal run` command. In stack: ``` $ stack build && stack exec <program-name> ```@@ -124,29 +155,54 @@  ## I already have GHC installed, can I still use stack? -Yes. stack will default to using whatever GHC is on your `PATH`. If that GHC is a-compatible version with the snapshot you're using, it will simply use it.-Otherwise, it will prompt you to run `stack setup`. Note that `stack setup` installs GHC into `~/.stack/programs/$platform/ghc-$version/` and not a global location.+Yes. In its default configuration, stack will simply ignore any system GHC+installation and use a sandboxed GHC that it has installed itself (typically+via the `stack setup` command). You can find these sandboxed GHC installations+in `~/.stack/programs/$platform/ghc-$version/`. -Note that GHC installation doesn't work for all OSes, so in some cases the-first option will need to install GHC yourself.+If you would like stack to use your system GHC installation, use the+[`--system-ghc` flag](yaml_configuration.md#system-ghc) or run+`stack config set system-ghc --global true` to make stack check your+`PATH` for a suitable GHC by default. +Note that stack can only use a system GHC installation if its version is+compatible with the configuration of the current project, particularly the+[`resolver` setting](yaml_configuration.md#resolver).++Note that GHC installation doesn't work for all OSes, so in some cases you+will need to use `system-ghc` and install GHC yourself.+ ## How does stack determine what GHC to use? -It uses the first GHC that it finds on the `PATH`. If that GHC does not comply with the various requirements (version, architecture) that your project needs, it will prompt you to run `stack setup` to get it. `stack` is fully aware of all GHCs that it has installed itself.+In its default configuration, stack determines from the current project which+GHC version, architecture etc. it needs. It then looks in+`~/.stack/programs/$platform/ghc-$version/` for a compatible GHC, requesting+to install one via `stack setup` if none is found. -See [this issue](https://github.com/commercialhaskell/stack/issues/420) for a detailed discussion.+If you are using the [`--system-ghc` flag](yaml_configuration.md/#system-ghc) or+have configured `system-ghc: true` either in the project `stack.yaml`+or the global `~/.stack/config.yaml`, stack will use the first GHC that it finds+on your `PATH`, falling back on its sandboxed installations only if the found GHC+doesn't comply with the various requirements (version, architecture) that your+project needs. +See [this issue](https://github.com/commercialhaskell/stack/issues/420) for a+detailed discussion of stack's behavior when `system-ghc` is enabled.+ ## How do I upgrade to GHC 7.10.2 with stack? -If you already have a prior version of GHC use `stack --resolver ghc-7.10 setup --reinstall`. If you don't have any GHC installed, you can skip the `--reinstall`.+If you already have a prior version of GHC use `stack --resolver ghc-7.10 setup+--reinstall`. If you don't have any GHC installed, you can skip the+`--reinstall`.  ## How do I get extra build tools?  stack will automatically install build tools required by your packages or their dependencies, in particular alex and happy. -__NOTE__: This works when using lts or nightly resolvers, not with ghc or custom resolvers. You can manually install build tools by running, e.g., `stack build alex happy`.+__NOTE__: This works when using lts or nightly resolvers, not with ghc or+custom resolvers. You can manually install build tools by running, e.g., `stack+build alex happy`.  ## How does stack choose which snapshot to use when creating a new config file? @@ -163,7 +219,14 @@  ## My tests are failing. What should I do? -Like all other targets, `stack test` runs test suites in parallel by default. This can cause problems with test suites that depend on global resources such as a database or binding to a fixed port number. A quick hack is to force stack to run all test suites in sequence, using `stack test --jobs=1`. For test suites to run in parallel developers should ensure that their test suites do not depend on global resources (e.g. by asking the OS for a random port to bind to) and where unavoidable, add a lock in order to serialize access to shared resources.+Like all other targets, `stack test` runs test suites in parallel by default.+This can cause problems with test suites that depend on global resources such+as a database or binding to a fixed port number. A quick hack is to force stack+to run all test suites in sequence, using `stack test --jobs=1`. For test+suites to run in parallel developers should ensure that their test suites do+not depend on global resources (e.g. by asking the OS for a random port to bind+to) and where unavoidable, add a lock in order to serialize access to shared+resources.  ## Can I get bash autocompletion? @@ -220,42 +283,60 @@  ## How do I use this with Travis CI? -See the [Travis section in the GUIDE](GUIDE.md#travis-with-caching)+See the [Travis CI instructions](travis_ci.md)  ## What is licensing restrictions on Windows? -Currently on Windows GHC produces binaries linked statically with [GNU Multiple Precision Arithmetic Library](https://gmplib.org/) (GMP), which is used by [integer-gmp](https://hackage.haskell.org/package/integer-gmp) library to provide big integer implementation for Haskell. Contrary to the majority of Haskell code licensed under permissive BSD3 license, GMP library is licensed under LGPL, which means resulting binaries [have to be provided with source code or object files](http://www.gnu.org/licenses/gpl-faq.html#LGPLStaticVsDynamic). That may or may not be acceptable for your situation. Current workaround is to use GHC built with alternative big integer implementation called integer-simple, which is free from LGPL limitations as it's pure Haskell and does not use GMP. Unfortunately it has yet to be available out of the box with stack. See [issue #399](https://github.com/commercialhaskell/stack/issues/399) for the ongoing effort and information on workarounds.+Currently on Windows GHC produces binaries linked statically with [GNU Multiple+Precision Arithmetic Library](https://gmplib.org/) (GMP), which is used by+[integer-gmp](https://hackage.haskell.org/package/integer-gmp) library to+provide big integer implementation for Haskell. Contrary to the majority of+Haskell code licensed under permissive BSD3 license, GMP library is licensed+under LGPL, which means resulting binaries [have to be provided with source+code or object files](http://www.gnu.org/licenses/gpl-faq.html#LGPLStaticVsDynamic).+That may or may not be acceptable for your situation. Current workaround is to+use GHC built with alternative big integer implementation called+integer-simple, which is free from LGPL limitations as it's pure Haskell and+does not use GMP.  Unfortunately it has yet to be available out of the box with+stack. See [issue #399](https://github.com/commercialhaskell/stack/issues/399)+for the ongoing effort and information on workarounds.  ## How to get a working executable on Windows? -When executing a binary after building with `stack build` (e.g. for target "foo"), the command `foo.exe` might complain about missing runtime libraries (whereas `stack exec foo` works).+When executing a binary after building with `stack build` (e.g. for target+"foo"), the command `foo.exe` might complain about missing runtime libraries+(whereas `stack exec foo` works). -Windows is not able to find the necessary C++ libraries from the standard prompt because they're not in the PATH environment variable. `stack exec` works because it's modifying PATH to include extra things.+Windows is not able to find the necessary C++ libraries from the standard+prompt because they're not in the PATH environment variable. `stack exec` works+because it's modifying PATH to include extra things. -Those libraries are shipped with GHC (and, theoretically in some cases, MSYS). The easiest way to find them is `stack exec which`. E.g.+Those libraries are shipped with GHC (and, theoretically in some cases, MSYS).+The easiest way to find them is `stack exec which`. E.g.      >stack exec which libstdc++-6.dll     /c/Users/Michael/AppData/Local/Programs/stack/i386-windows/ghc-7.8.4/mingw/bin/libstdc++-6.dll -A quick workaround is adding this path to the PATH environment variable or copying the files somewhere Windows finds them (cf. https://msdn.microsoft.com/de-de/library/7d83bc18.aspx).+A quick workaround is adding this path to the PATH environment variable or+copying the files somewhere Windows finds them (cf. https://msdn.microsoft.com/de-de/library/7d83bc18.aspx).  Cf. issue [#425](https://github.com/commercialhaskell/stack/issues/425).  ## Can I change stack's default temporary directory? -Stack makes use of a temporary directory for some commands (/tmp by default on linux). If there is not enough free space in this directory, stack may fail (see issue [#429](https://github.com/commercialhaskell/stack/issues/429) ). For instance `stack setup` with a GHC installation requires roughly 1GB free.--A custom temporary directory can be forced:--* on Linux by setting the environment variable TMPDIR (eg `$ TMPDIR=path-to-tmp stack setup`)-* on Windows by setting one of the environment variable (given in priority order), TMP, TEMP, USERPROFILE+Stack downloads and extracts files to `$STACK_ROOT/programs` on most platforms,+which defaults to `~/.stack/programs`. On Windows `$LOCALAPPDATA\Programs\stack`+is used. If there is not enough free space in this directory, Stack may fail.+For instance, `stack setup` with a GHC installation requires roughly 1GB free.+If this is an issue, you can set `local-programs-path` in your+`~/.stack/config.yaml` to a directory on a file system with more free space. -If you use Stack with Nix integration, be aware that Nix _also_ uses that TMPDIR+If you use Stack with Nix integration, be aware that Nix uses a `TMPDIR` variable, and if it is not set Nix sets it to some subdirectory of `/run`, which-on most Linuxes is a Ramdir. Nix will run the builds in TMPDIR, therefore if you-don't have enough RAM you will get errors about disk space.  If this happens to-you, please _manually_ set TMPDIR before launching Stack to some directory on the-disk.+on most Linuxes is a Ramdir. Nix will run the builds in `TMPDIR`, therefore if+you don't have enough RAM you will get errors about disk space. If this happens+to you, please _manually_ set `TMPDIR` before launching Stack to some directory+on the disk.  ## Why doesn't stack rebuild my project when I specify `--ghc-options` on the command line? @@ -285,7 +366,11 @@  ## How do I reset / remove Stack (such as to to do a completely fresh build)? -The first thing to remove is project-specific `.stack-work` directory within the project's directory. Next, remove `~/.stack` directory overall. You may have errors if you remove the latter but leave the former. Removing Stack itself will relate to how it was installed, and if you used GHC installed outside of Stack, that would need to be removed separately.+The first thing to remove is project-specific `.stack-work` directory within+the project's directory. Next, remove `~/.stack` directory overall. You may+have errors if you remove the latter but leave the former. Removing Stack+itself will relate to how it was installed, and if you used GHC installed+outside of Stack, that would need to be removed separately.  ## How does stack handle parallel builds? What exactly does it run in parallel? @@ -293,7 +378,12 @@  ## I get strange `ld` errors about recompiling with "-fPIC" -Some users (myself included!) have come across a linker errors (example below) that seem to be dependent on the local environment, i.e. the package may compile on a different machine. The issue has been reported to be [non-deterministic](https://github.com/commercialhaskell/stack/issues/614) in some cases. I've had success using the docker functionality to build the project on a machine that would not compile it otherwise.+Some users (myself included!) have come across a linker errors (example below)+that seem to be dependent on the local environment, i.e. the package may+compile on a different machine. The issue has been reported to be+[non-deterministic](https://github.com/commercialhaskell/stack/issues/614) in+some cases. I've had success using the docker functionality to build the+project on a machine that would not compile it otherwise.  ``` tmp-0.1.0.0: build@@ -309,9 +399,16 @@     Process exited with code: ExitFailure 1 ``` -The issue may be related to the use of hardening flags in some cases, specifically those related to producing position independent executables (PIE). This is tracked upstream in the [following ticket](https://ghc.haskell.org/trac/ghc/ticket/9007). Some distributions add such hardening flags by default which may be the cause of some instances of the problem. Therefore, a possible workaround might be to turn off PIE related flags.+The issue may be related to the use of hardening flags in some cases,+specifically those related to producing position independent executables (PIE).+This is tracked upstream in the [following+ticket](https://ghc.haskell.org/trac/ghc/ticket/9007). Some distributions add+such hardening flags by default which may be the cause of some instances of the+problem. Therefore, a possible workaround might be to turn off PIE related+flags. -In Arch Linux, the support for this is provided by the `hardening-wrapper` package. Some possible workarounds:+In Arch Linux, the support for this is provided by the `hardening-wrapper`+package. Some possible workarounds:  * Selectively disabling its PIE forcing by setting `HARDENING_PIE=0` in `/etc/hardening-wrapper.conf`. * Uninstalling the `hardening-wrapper` package and logging out then into your account again.@@ -320,7 +417,12 @@  ## Where does the output from `--ghc-options=-ddump-splices` (and other `-ddump*` options) go? -These are written to `*.dump-*` files inside the package's `.stack-work` directory.+These are written to `*.dump-*` files inside the package's `.stack-work`+directory. Specifically, they will be available at `PKG-DIR/$(stack path+--dist-dir)/build/SOURCE-PATH`, where `SOURCE-PATH` is the path to the source+file, relative to the location of the `*.cabal` file. When building named+components such as test-suites, `SOURCE-PATH` will also include+`COMPONENT/COMPONENT-tmp`, where `COMPONENT` is the name of the component.  ## <a name="dyld-library-path-ignored"></a>Why is DYLD_LIBRARY_PATH ignored? @@ -372,13 +474,15 @@  ## How can I make `stack` aware of my custom SSL certificates? -### OS X+### macOS  In principle, you can use the following command to add a certificate to your system certificate keychain:      sudo security add-trusted-cert -d -r trustRoot -k /Library/Keychains/System.keychain <certificate> -Some users have reported issues with this approach, see [#907](https://github.com/commercialhaskell/stack/issues/907) for more information.+Some users have reported issues with this approach, see+[#907](https://github.com/commercialhaskell/stack/issues/907) for more+information.  ### Other *NIX OSs
+ doc/ghci.md view
@@ -0,0 +1,56 @@+# GHCi++`stack ghci` allows you to load components and files of your project into+`ghci`. It uses the same TARGET syntax as `stack build`, and can also take+options like `--test`, `--bench`, and `--flag`.  Similarly to `stack build`, the+default is to load up ghci with all libraries and executables in the project.++In order to load multiple components, `stack ghci` combines all of the ghc options+together.  This doesn't work in the general case, but when the packages being+loaded share similar conventions, it should work out.  A common source of issues+is when one component defines default extensions which aren't assumed by another+component.  For example, specifying `NoImplicitPrelude` in one component but+not another is quite likely to cause failures.  `ghci` will be run with+`-XNoImplicitPrelude`, but it is likely that modules in the other component+assume that the Prelude is implicitly imported.++## Selecting Main module++When loading multiple packages, there may be multiple definitions for the `Main`+module.  You can specify which Main module to load by passing in the+`--main-is TARGET` flag.  If no selection is made and there are multiple `Main`+modules, you will be asked to select from a list of options.++## Speeding up initial load++There are two ways to speed up the initial startup of ghci:++* `--no-build`, to skip an initial build step.  This only works if the+  dependencies have already been built.++* `--no-load`, to skip loading all defined modules into ghci.  You can then+  directly use `:load MyModule` to load a specific module in your project.++## Loading a filepath directly++Instead of the `TARGET` syntax, it is also possible to directly run+`stack ghci src/MyFile.hs`.  This will figure out which component the file is+associated with, and use the options from that component.++## Specifying extra packages to build / depend on++Sometimes you want to load ghci with an additional package, that isn't a direct+dependency of your components.  This can be achieved by using the `--package` flag.+For example, if I want to experiment with the lens library, I can run+`stack ghci --package lens`.++## Running plain ghci++`stack ghci` always runs ghci configured to load code from packages in your+project.  In particular, this means it passes in flags like `-hide-all-packages`+and `-package-id=` in order to configure which packages are visible to ghci.++For doing experiments which just involve packages installed in your databases,+it may be useful to run ghci plainly like `stack exec ghci`. This will run a+plain `ghci` in an environment which includes `GHC_PACKAGE_PATH`, and so will+have access to your databases.
doc/ghcjs.md view
@@ -1,50 +1,94 @@ # GHCJS -To use GHCJS with stack `>= 0.1.8`, place a GHCJS version in the [`compiler`](yaml_configuration.md#compiler) field of `stack.yaml`.  After this, all stack commands should work with GHCJS, except for `ide`.  In particular:+To use GHCJS with stack, place a GHCJS version in the [`compiler`](yaml_configuration.md#compiler) field of `stack.yaml`.  After this, all stack commands should work with GHCJS!  In particular:  * `stack setup` will install GHCJS from source and boot it, which takes a long time.+ * `stack build` will compile your code to JavaScript.  In particular, the generated code for an executable ends up in `$(stack path --local-install-root)/bin/EXECUTABLE.jsexe/all.js` (bash syntax, where `EXECUTABLE` is the name of your executable). -You can also build existing stack projects which target GHC, and instead build them with GHCJS.  For example: `stack build --compiler ghcjs-0.1.0.20150924_ghc-7.10.2`+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`  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-[stack issue #1496](https://github.com/commercialhaskell/stack/issues/1496).+[issue #1496](https://github.com/commercialhaskell/stack/issues/1496).  ## Example Configurations -### GHCJS `master` (a.k.a. improved base)+### Recent versions of GHCJS, repacked for stack -To use the master branch, a.k.a improved base, add the following to your `stack.yaml`:+These versions of GHCJS were created by+[Marcin Tolysz](https://github.com/tolysz), and were particularly crafted to+include package versions which match those expected by particular stackage+snapshots. -GHCJS compiled with GHC 7.10.3 LTS-5.12 (stack.yaml upgraded from stock GHCJS)+For `ghcjs` based on `ghc-7.10.3` one could try: ```yaml-compiler: ghcjs-0.2.0.20160414_ghc-7.10.3+resolver: lts-6.25+compiler: ghcjs-0.2.0.9006025_ghc-7.10.3 compiler-check: match-exact+ setup-info:   ghcjs:     source:-      ghcjs-0.2.0.20160414_ghc-7.10.3:-        url: https://s3.amazonaws.com/ghcjs/ghcjs-0.2.0.20160414_ghc-7.10.3.tar.gz-        sha1: 6d6f307503be9e94e0c96ef1308c7cf224d06be3+      ghcjs-0.2.0.9006025_ghc-7.10.3:+         url: http://ghcjs.tolysz.org/lts-6.25-9006025.tar.gz+         sha1: 3c87228579b55c05e227a7876682c2a7d4c9c007 ``` -GHCJS compiled with GHC 7.10.2 LTS-3.6 (stack.yaml that comes with GHCJS)+Or for the latest one based on `ghc-8.0.1` (with more features): ```yaml-compiler: ghcjs-0.2.0.20160414_ghc-7.10.2+resolver: lts-7.8+compiler: ghcjs-0.2.1.9007008_ghc-8.0.1 compiler-check: match-exact+ setup-info:   ghcjs:     source:-      ghcjs-0.2.0.20160414_ghc-7.10.2:-        url: https://s3.amazonaws.com/ghcjs/ghcjs-0.2.0.20160414_ghc-7.10.2.tar.gz-        sha1: f0a7243e781e27ebfe601eebaf5c57422007c142+      ghcjs-0.2.1.9007008_ghc-8.0.1:+          url: http://ghcjs.tolysz.org/ghc-8.0-2016-11-07-lts-7.8-9007008.tar.gz+          sha1: 190300a3725cde44b2a08be9ef829f2077bf8825 ```+The later can be generated via: https://github.com/tolysz/prepare-ghcjs+the fromer is a bit more manual. Those bundles are only tested against the latest `node-6.9.1`. +In order to corrrectly boot and use ghcjs, one might need to install `alex` `happy` `hscolour` `hsc2hs` with the normal ghc.++Older resolvers:++|resolver|url|sha1|+|---|---|---|+| lts-7.7 | http://ghcjs.tolysz.org/ghc-8.0-2016-11-03-lts-7.7-9007007.tar.gz | ce169f85f1c49ad613ae77fc494d5565452ff59a |+| lts-7.5 | http://ghcjs.tolysz.org/ghc-8.0-2016-10-24-lts-7.5-9007005.tar.gz | 450e81028d7f1eb82a16bc4b0809f30730c3e173 |+| lts-7.4 | http://ghcjs.tolysz.org/ghc-8.0-2016-10-22-lts-7.4-9007004.tar.gz | ed77b3c15fedbadad5ab0e0afe1bd42c0a8695b4 |+| lts-7.3 | http://ghcjs.tolysz.org/ghc-8.0-2016-10-11-lts-7.3-9007003.tar.gz | 3196fd5eaed670416083cf3678396d02c50096de |+| lts-7.2 | http://ghcjs.tolysz.org/ghc-8.0-2016-10-01-lts-7.2-9007002.tar.gz | a41ae415328e2b257d40724d13d1386390c26322 | +| lts-7.1 | http://ghcjs.tolysz.org/ghc-8.0-2016-09-26-lts-7.1-9007001-mem.tar.gz | e640724883238593e2d2f7f03991cb413ec0347b |+| lts-6.21 | http://ghcjs.tolysz.org/lts-6.21-9006021.tar.gz | 80b83f85dcec182093418e843979f4cee092fa85 |+| lts-6.20 | http://ghcjs.tolysz.org/lts-6.20-9006020.tar.gz | a6cea90cd8121eee3afb201183c6e9bd6bacd94a |+| lts-6.19 | http://ghcjs.tolysz.org/lts-6.19-9006019.tar.gz | ef4264d5a93b269ee4ec8f9d5139da030331d65a |+| lts-6.18 | http://ghcjs.tolysz.org/lts-6.18-9006018.tar.gz | 3e9f345116c851349a5a551ffd94f7e0b74bfabb |++If you do not use the same resolver, say, an older LTS snapshot, you will get+some warnings like this:++```+Ignoring that the GHCJS boot package "aeson" has a different version, 0.9.0.1, than the resolver's wanted version, 0.8.0.2+Ignoring that the GHCJS boot package "attoparsec" has a different version, 0.13.0.1, than the resolver's wanted version, 0.12.1.6+Ignoring that the GHCJS boot package "scientific" has a different version, 0.3.3.8, than the resolver's wanted version, 0.3.4.2+...+```++These warnings can usually be safely ignored, but they do indicate a divergence+between your snapshot's packages, and those that are being used to compile your+project. You will normally get these warnings when using a GHCJS tarball that+has not been packaged with a particular snapshot in mind.+ ### GHCJS (old base) -You can use this resolver for GHCJS (old base) in your `stack.yaml`:+If you want to build some older GHCJS packages, you may need to use the "old+base" GHCJS.  To do this, use the following compiler info:  ```yaml compiler: ghcjs-0.1.0.20150924_ghc-7.10.2@@ -63,9 +107,15 @@  ## Project with both client and server -For projects with both a server and client, the recommended project organization is to put one or both of your `stack.yaml` files in sub-directories.  This way, you can use the current working directory to specify whether you're working on the client or server.  This will also allow more straightforward editor tooling, once projects like `ghc-mod` and `haskell-ide-engine` support GHCJS.+For projects with both a server and client, the recommended project+organization is to put one or both of your `stack.yaml` files in+sub-directories.  This way, you can use the current working directory to+specify whether you're working on the client or server.  This will also allow+more straightforward editor tooling, once projects like `ghc-mod` and+`haskell-ide-engine` support GHCJS. -For example, here's what a script for building both client and server looks like:+For example, here's what a script for building both client and server looks+like:  ```bash #!/bin/bash@@ -81,8 +131,15 @@ stack build --stack-yaml=server/stack.yaml ``` -You can also put both the yaml files in the same directory, and have e.g. `ghcjs-stack.yaml`, but this won't work well with editor integrations.+You can also put both the yaml files in the same directory, and have e.g.+`ghcjs-stack.yaml`, but this won't work well with editor integrations.  ## Using stack without a snapshot  If you don't want to use a snapshot, instead place the ghcjs version in the `resolver` field of your `stack.yaml`.  This is also necessary when using stack `< 0.1.8`.++## Setting up GHCJS on Windows++If `stack setup` command fails to successfully complete with message: `commitBuffer: invalid argument (invalid character)`, it means you have a locale problem.+This problem is not exclusive to GHCJS, and might happen also during other builds. A workaround is to set _Language for non-Unicode programs_ to _English (US)_.+For details see [stack issue #1448](https://github.com/commercialhaskell/stack/issues/1448).
doc/install_and_upgrade.md view
@@ -60,10 +60,31 @@ been tested. If you do test, please edit and update this page to indicate as such. -## Mac OS X+## 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+versions (YMMV).++**macOS Sierra warning**: There are new limitations in the dynamic linker that+are causing problems for GHC when building projects with many+dependencies. See+[#2577](https://github.com/commercialhaskell/stack/issues/2577) for more+information.++### Manual download++* Download the latest release:+    * [macOS 64-bit](https://www.stackage.org/stack/osx-x86_64)+* Extract the archive and place `stack` somewhere on your `$PATH` (see+  [Path section below](#path))+* Now you can run `stack` from the terminal.+ ### Using Homebrew +**macOS Sierra warning**: Homebrew's haskell-stack formula may not currently+work on Sierra, so we suggest using the manual above for now.+ If you have a popular [brew](http://brew.sh/) tool installed, you can just do:      brew install haskell-stack@@ -75,17 +96,6 @@ 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). -### Manual download--* Download the latest release:-    * [Mac OS X 64-bit](https://www.stackage.org/stack/osx-x86_64)-* Extract the archive and place `stack` somewhere on your `$PATH` (see-  [Path section below](#path))-* Now you can run `stack` from the terminal.--We generally test on the current version of Mac OS X, but stack is known to work on-Yosemite and Mavericks as well, and may also work on older versions (YMMV).- ### Notes  After installation, running `stack setup` might fail with `configure: error: cannot run C compiled programs.` in which case you should run:@@ -219,7 +229,7 @@        * SUSE Linux Enterprise 12 -            sudo zypper ar http://download.opensuse.org/repositories/devel:/languages:/haskell/SLE_12/devel:languages:haskell.repo +            sudo zypper ar http://download.opensuse.org/repositories/devel:/languages:/haskell/SLE_12/devel:languages:haskell.repo   2. Install:
doc/nix_integration.md view
@@ -24,6 +24,18 @@ such as using custom Nix packages that override the standard ones or using system libraries with special requirements. +### Checking Nix installation++Follow the instructions on the+[Nix download page](http://nixos.org/nix/download.html) to install Nix.  After+doing so, when opening a terminal, the nix commands (`nix-build`, `nix-shell`,+etc) should be available.  If they are not, it should be because the file+located at `$HOME/.nix-profile/etc/profile.d/nix.sh` is not sourced by your shell.++You should either run `source ~/.nix-profile/etc/profile.d/nix.sh` manually+everytime you open a terminal and need Nix or add this command to your+`~/.bashrc` or `~/.bash_profile`.+ ### Additions to your `stack.yaml`  Add a section to your `stack.yaml` as follows:@@ -107,8 +119,8 @@ passing the `--nix` flag to stack, for instance `stack --nix build`.  Passing any `--nix*` option to the command line will do the same. -**Known limitation on OS X:** currently, `stack --nix ghci` fails on-OS X, due to a bug in GHCi when working with external shared+**Known limitation on macOS:** currently, `stack --nix ghci` fails on+macOS, due to a bug in GHCi when working with external shared libraries.  ### The Nix shell@@ -122,8 +134,8 @@ behaviour, add `pure: false` to your `stack.yaml` or pass the `--no-nix-pure` option to the command line. -**Note:** On OS X shells are non-pure by default currently. This is-due soon to be resolved locale issues. So on OS X you'll need to be+**Note:** On macOS shells are non-pure by default currently. This is+due soon to be resolved locale issues. So on macOS you'll need to be a bit more careful to check that you really have listed all dependencies. @@ -186,6 +198,14 @@   # `[nixpkgs=/my/local/nixpkgs/clone]` that will be used to override   # NIX_PATH.   path: []+  +  # false by default. Whether to add your nix dependencies as nix garbage+  # collection roots. This way, calling nix-collect-garbage will not remove+  # those packages from the nix store, saving you some time when running+  # stack build again with nix support activated.+  # This creates a `nix-gc-symlinks` directory in the project `.stack-work`.+  # To revert that, just delete this `nix-gc-symlinks` directory.+  add-gc-roots: false ```  ## Using a custom shell.nix file
doc/nonstandard_project_init.md view
@@ -1,19 +1,30 @@ # Non-standard project initialization  ## Introduction-The purpose of this page is to collect information about issues that arise when users either have an existing cabal project or another nonstandard setup such as a private hackage database.+The purpose of this page is to collect information about issues that arise when+users either have an existing cabal project or another nonstandard setup such+as a private hackage database. -## Using a Cabal File-New users may be confused by the fact that you must add dependencies to the package's cabal file, even in the case when you have already listed the package in the `stack.yaml`. In most cases, dependencies for your package that are in the Stackage snapshot need *only* be added to the cabal file. stack makes heavy use of Cabal the library under the hood. In general, your stack packages should also end up being valid cabal-install packages.+## Using a Cabal File New users may be confused by the fact that you must add+dependencies to the package's cabal file, even in the case when you have+already listed the package in the `stack.yaml`. In most cases, dependencies for+your package that are in the Stackage snapshot need *only* be added to the+cabal file. stack makes heavy use of Cabal the library under the hood. In+general, your stack packages should also end up being valid cabal-install+packages.  ### Issues Referenced   - https://github.com/commercialhaskell/stack/issues/105  ## Passing Flags to Cabal -Any build command, `bench`, `install`, `haddock`, `test`, etc. takes a `--flag` option which passes flags to cabal. Another way to do this is using the flags field in a `stack.yaml`, with the option to specify flags on a per package basis.+Any build command, `bench`, `install`, `haddock`, `test`, etc. takes a `--flag`+option which passes flags to cabal. Another way to do this is using the flags+field in a `stack.yaml`, with the option to specify flags on a per package+basis. -As an example, in a `stack.yaml` for multi-package project with packages `foo`, `bar`, `baz`:+As an example, in a `stack.yaml` for multi-package project with packages `foo`,+`bar`, `baz`:  ``` flags:@@ -25,9 +36,13 @@     manual: true ``` -It is also possible to pass the same flag to multiple packages, i.e. `stack build --flag *:necessary`+It is also possible to pass the same flag to multiple packages, i.e. `stack+build --flag *:necessary` -Currently one needs to list all of your modules that interpret flags in the `other-modules` section of a cabal file. `cabal-install` has a different behavior currently and doesn't require that the modules be listed. This may change in a future release.+Currently one needs to list all of your modules that interpret flags in the+`other-modules` section of a cabal file. `cabal-install` has a different+behavior currently and doesn't require that the modules be listed. This may+change in a future release.   ### Issues Referenced@@ -40,10 +55,18 @@  ## Selecting a Resolver -`stack init` or `stack new` will try to default to the current Haskell LTS present on `https://www.stackage.org/snapshots` if no snapshot has been previously used locally, and to the latest LTS snapshot locally used for a build otherwise. Using an incorrect resolver can cause a build to fail if the version of GHC it requires is not present.+`stack init` or `stack new` will try to default to the current Haskell LTS+present on `https://www.stackage.org/snapshots` if no snapshot has been+previously used locally, and to the latest LTS snapshot locally used for a+build otherwise. Using an incorrect resolver can cause a build to fail if the+version of GHC it requires is not present. -In order to override the resolver entry at project initialization one can pass `--prefer-lts` or `--prefer-nightly`. These options will choose the latest LTS or nightly versions locally used.-Alternatively the `--resolver` option can be used with the name of any snapshots on Stackage, or with `lts` or `nightly` to select the latest versions, disregarding previously used ones. This is not the default so as to avoid unnecessary recompilation time.+In order to override the resolver entry at project initialization one can pass+`--prefer-lts` or `--prefer-nightly`. These options will choose the latest LTS+or nightly versions locally used.  Alternatively the `--resolver` option can be+used with the name of any snapshots on Stackage, or with `lts` or `nightly` to+select the latest versions, disregarding previously used ones. This is not the+default so as to avoid unnecessary recompilation time.  :TODO: Document `--solver` @@ -70,10 +93,16 @@  ## Private Hackage Working with a private Hackage is currently supported in certain situations.-There exist special entries in `stack.yaml` that may help you. In a `stack.yaml` file, it is possible-to add lines for packages in your database referencing the sdist locations via an `http` entry, or to use a `Hackage` entry.+There exist special entries in `stack.yaml` that may help you. In a+`stack.yaml` file, it is possible to add lines for packages in your database+referencing the sdist locations via an `http` entry, or to use a `Hackage`+entry. -The recommended stack workflow is to use git submodules instead of a private Hackage. Either by using git submodules and listing the directories in the packages section of `stack.yaml`, or by adding the private dependencies as git URIs with a commit SHA to the `stack.yaml`. This has the large benefit of eliminating the need to manage a Hackage database and pointless version bumps.+The recommended stack workflow is to use git submodules instead of a private+Hackage. Either by using git submodules and listing the directories in the+packages section of `stack.yaml`, or by adding the private dependencies as git+URIs with a commit SHA to the `stack.yaml`. This has the large benefit of+eliminating the need to manage a Hackage database and pointless version bumps.  For further information see [YAML configuration](yaml_configuration.md) @@ -89,7 +118,8 @@   - https://github.com/commercialhaskell/stack/issues/137  ## Intra-package Targets-stack supports intra-package targets, similar to `cabal build COMPONENTS` for situations when you don't want to build every target inside your package.+stack supports intra-package targets, similar to `cabal build COMPONENTS` for+situations when you don't want to build every target inside your package.  Example: ```
doc/shell_autocompletion.md view
@@ -1,10 +1,13 @@ # Shell Auto-completion -Note: if you installed a package for you Linux distribution, the bash completion-file was automatically installed (you may need the `bash-completion` package to-have it take effect).+Note: if you installed a package for you Linux distribution, the bash+completion file was automatically installed (you may need the `bash-completion`+package to have it take effect). -The following adds support for shell tab completion for standard Stack arguments, although completion for filenames and executables etc. within stack is still lacking (see [issue 823](https://github.com/commercialhaskell/stack/issues/832)).+The following adds support for shell tab completion for standard Stack+arguments, although completion for filenames and executables etc. within stack+is still lacking (see [issue+823](https://github.com/commercialhaskell/stack/issues/832)).  ## for bash users @@ -17,7 +20,12 @@ ## for ZSH users  documentation says:-> Zsh can handle bash completions functions. The latest development version of zsh has a function bashcompinit, that when run will allow zsh to read bash completion specifications and functions. This is documented in the zshcompsys man page. To use it all **you need to do is run bashcompinit at any time after compinit**. It will define complete and compgen functions corresponding to the bash builtins.+> Zsh can handle bash completions functions. The latest development version of+> zsh has a function bashcompinit, that when run will allow zsh to read bash+> completion specifications and functions. This is documented in the zshcompsys+> man page. To use it all **you need to do is run bashcompinit at any time+> after compinit**. It will define complete and compgen functions corresponding+> to the bash builtins.  You must so:   1. launch compinint@@ -30,6 +38,9 @@ eval "$(stack --bash-completion-script stack)" ``` -:information_source: If you already have quite a large zshrc, or if you use oh-my-zsh, **compinit** will probably already be loaded. If you have a blank zsh config, all of the 3 lines above are necessary.+:information_source: If you already have quite a large zshrc, or if you use+oh-my-zsh, **compinit** will probably already be loaded. If you have a blank+zsh config, all of the 3 lines above are necessary. -:gem: tip: instead of running those 3 lines from your shell every time you want to use stack, you can add those 3 lines in your $HOME/.zshrc file+:gem: tip: instead of running those 3 lines from your shell every time you want+to use stack, you can add those 3 lines in your $HOME/.zshrc file
doc/travis_ci.md view
@@ -1,12 +1,39 @@ # Travis CI -For many use cases, the-[Travis caching section of the user guide](GUIDE.md#travis-with-caching)-will be sufficient.+This page documents how to use Stack on+[Travis CI](https://travis-ci.org/). We assume you have basic+familiarity with Travis. We provide two fully baked example files+ready to be used on your projects: -This page documents how to use Stack on [Travis CI](https://travis-ci.org/). We-assume you have basic familiarity with Travis.+* [The simple Travis configuration](https://raw.githubusercontent.com/commercialhaskell/stack/master/doc/travis-simple.yml)+  is intended for applications that do not require multiple GHC+  support or cross-platform support. It builds and tests your project+  with just the settings present in your `stack.yaml` file.+* [The complex Travis configuration](https://raw.githubusercontent.com/commercialhaskell/stack/master/doc/travis-complex.yml)+  is intended for projects that need to support multiple GHC versions+  and multiple OSes, such as open source libraries to be released to+  Hackage. It tests against cabal-install, as well as Stack on Linux+  and macOS. The configuration is significantly more involved to allow+  for all of this branching behavior. +  __NOTE__: It is likely going to be necessary to modify this configuration to+  match the needs of your project, such as tweaking the build matrix to alter+  which GHC versions you test against, or to specify GHC-version-specific+  `stack.yaml` files if necessary. Don't be surprised if it doesn't work the+  first time around. See the multiple GHC section below for more information.++Each of these configurations is ready to be used immediately, just+copy-paste the content into the `.travis.yml` file in the root or your+repo, enable Travis on the repo, and you're good to go.++You may also be interested in using AppVeyor, which supports Windows+builds, for more cross-platform testing. There's a+[short blog post available on how to do this](http://www.snoyman.com/blog/2016/08/appveyor-haskell-windows-ci).++The rest of this document explains the details of common Travis+configurations for those of you who want to tweak the above+configuration files or write your own.+ *Note:* both Travis and Stack infrastructures are actively developed. We try to  document best practices at the moment. @@ -59,13 +86,16 @@ - Let Stack download GHC - Install GHC using [apt plugin](http://docs.travis-ci.com/user/apt/) -See the-[Travis caching section of the user guide](GUIDE.md#travis-with-caching) for-an example of the first option (letting Stack download GHC). Here, we will-explain the second option. With single GHC the situation is simple:+See the above scripts for an example of the first option (letting Stack+download GHC). Here, we will explain the second option. With single GHC the+situation is simple:  ```yaml before_install:+  # Install stack as above+  # ...+  # Configure stack to use the system GHC installation+  - stack config set system-ghc --global true   - export PATH=/opt/ghc/7.10.2/bin:$PATH  addons:@@ -130,16 +160,20 @@   - stack --no-terminal --skip-ghc-check test ``` +In case you're wondering: we need `--no-terminal` because stack does some fancy+sticky display on smart terminals to give nicer status and progress messages,+and the terminal detection is broken on Travis.+ ## Other details  Some Stack commands will run for long time (when cache is cold) without-producing any output. For Travis not to timeout, one can wrap commands in-[a simple script](https://github.com/futurice/fum2github/blob/master/travis_long).+producing any output. To avoid timeouts, use the built in [travis_wait](https://docs.travis-ci.com/user/common-build-problems/#Build-times-out-because-no-output-was-received). + ```yaml install:-  - ./travis_long stack --no-terminal --skip-ghc-check setup-  - ./travis_long stack --no-terminal --skip-ghc-check test --only-snapshot+  - travis_wait stack --no-terminal --skip-ghc-check setup+  - travis_wait stack --no-terminal --skip-ghc-check test --only-snapshot ```  ## Examples@@ -149,3 +183,14 @@ - [simonmichael/hledger](https://github.com/simonmichael/hledger/blob/master/.travis.yml) - [fpco/wai-middleware-crowd](https://github.com/fpco/wai-middleware-crowd/blob/master/.travis.yml) - [commercialhaskell/all-cabal-hashes-tool](https://github.com/commercialhaskell/all-cabal-hashes-tool/blob/master/.travis.yml)++## Future enhancements++Once Travis whitelists the stack .deb files, we'll be able to simply include+stack in the `addons` section, and automatically use the newest version of+stack, avoiding that complicated `before_install` section This is being+tracked in the+[apt-source-whitelist](https://github.com/travis-ci/apt-source-whitelist/pull/7)+and+[apt-package-whitelist](https://github.com/travis-ci/apt-package-whitelist/issues/379)+issue trackers.
doc/yaml_configuration.md view
@@ -1,6 +1,9 @@ # YAML Configuration -This page is intended to fully document all configuration options available in the stack.yaml file. Note that this page is likely to be both *incomplete* and sometimes *inaccurate*. If you see such cases, please update the page, and if you're not sure how, open an issue labeled "question".+This page is intended to fully document all configuration options available in+the stack.yaml file. Note that this page is likely to be both *incomplete* and+sometimes *inaccurate*. If you see such cases, please update the page, and if+you're not sure how, open an issue labeled "question".  The stack.yaml configuration options break down into [project-specific](#project-config) options in: @@ -12,7 +15,9 @@ -  `~/.stack/config.yaml` -- for user non-project default options - 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`.+*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`.  ## Project-specific config @@ -180,9 +185,11 @@ * No snapshot, just use packages shipped with the compiler     * For GHC this looks like `resolver: ghc-7.10.2`     * For GHCJS this looks like `resolver: ghcjs-0.1.0_ghc-7.10.2`.-* [Custom snapshot](https://github.com/commercialhaskell/stack/wiki/Custom-Snapshot)+* [Custom snapshot](custom_snapshot.md) -Each of these resolvers will also determine what constraints are placed on the compiler version. See the [compiler-check](#compiler-check) option for some additional control over compiler version.+Each of these resolvers will also determine what constraints are placed on the+compiler version. See the [compiler-check](#compiler-check) option for some+additional control over compiler version.  ### flags @@ -299,13 +306,14 @@  ### system-ghc -Enables or disables using the GHC available on the PATH. Useful to disable if-you want to force stack to use its own installed GHC (via `stack setup`), in-cases where your system GHC my be incomplete for some reason. Default is `true`.+Enables or disables using the GHC available on the PATH.+Useful to enable if you want to save the time, bandwidth or storage space needed to setup an isolated GHC.+Default is `false` unless the [Docker](docker_integration.md) or [Nix](nix_integration.md) integration is enabled.+In a Nix-enabled configuration, stack is incompatible with `system-ghc: false`.  ```yaml-# Turn off system GHC-system-ghc: false+# Turn on system GHC+system-ghc: true ```  ### install-ghc@@ -315,7 +323,8 @@  ### skip-ghc-check -Should we skip the check to confirm that your system GHC version (on the PATH) matches what your project expects? Default is `false`.+Should we skip the check to confirm that your system GHC version (on the PATH)+matches what your project expects? Default is `false`.  ### require-stack-version @@ -359,9 +368,14 @@  Specifies how the compiler version in the resolver is matched against concrete versions. Valid values: -* `match-minor`: make sure that the first three components match, but allow patch-level differences. For example< 7.8.4.1 and 7.8.4.2 would both match 7.8.4. This is useful to allow for custom patch levels of a compiler. This is the default+* `match-minor`: make sure that the first three components match, but allow+  patch-level differences. For example< 7.8.4.1 and 7.8.4.2 would both match+  7.8.4. This is useful to allow for custom patch levels of a compiler. This is+  the default * `match-exact`: the entire version number must match precisely-* `newer-minor`: the third component can be increased, e.g. if your resolver is `ghc-7.10.1`, then 7.10.2 will also be allowed. This was the default up through stack 0.1.3+* `newer-minor`: the third component can be increased, e.g. if your resolver is+  `ghc-7.10.1`, then 7.10.2 will also be allowed. This was the default up+  through stack 0.1.3  ### compiler @@ -416,7 +430,11 @@  (Since 0.1.6) -Should we rebuild a package when its GHC options change? Before 0.1.6, this was a non-configurable true. However, in most cases, the flag is used to affect optimization levels and warning behavior, for which GHC itself doesn't actually recompile the modules anyway. Therefore, the new behavior is to not recompile on an options change, but this behavior can be changed back with the following:+Should we rebuild a package when its GHC options change? Before 0.1.6, this was+a non-configurable true. However, in most cases, the flag is used to affect+optimization levels and warning behavior, for which GHC itself doesn't actually+recompile the modules anyway. Therefore, the new behavior is to not recompile+on an options change, but this behavior can be changed back with the following:  ```yaml rebuild-ghc-options: true@@ -435,6 +453,16 @@   [setup-info](#setup-info) so `stack setup` knows where to download it, or   pass the `stack setup --ghc-bindist` argument on the command-line +This option is incompatible with `system-ghc: true`.++### ghc-build++(Since 1.3.0)++Specify a specialized architecture bindist to use.  Normally this is+determined automatically, but you can override the autodetected value here.+Possible arguments include `standard`, `gmp4`, `tinfo6`, and `nopie`.+ ### setup-info  (Since 0.1.5)@@ -451,6 +479,12 @@         url: "https://example.com/ghc-7.10.2-i386-unknown-mingw32-foo.tar.xz" ``` +Or without using `ghc-variant`:++```yaml+setup-info: "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/stack-setup-2.yaml"+```+ `url` may be either URL or (since 1.2.0) absolute file path.  ### pvp-bounds@@ -464,8 +498,10 @@ is:  * If an upper or lower bound already exists on a dependency, it's left alone-* When adding a lower bound, we look at the current version specified by stack.yaml, and set it as the lower bound (e.g., `foo >= 1.2.3`)-* When adding an upper bound, we require less than the next major version (e.g., `foo < 1.3`)+* When adding a lower bound, we look at the current version specified by+  stack.yaml, and set it as the lower bound (e.g., `foo >= 1.2.3`)+* When adding an upper bound, we require less than the next major version+  (e.g., `foo < 1.3`)  ```yaml pvp-bounds: none@@ -554,6 +590,7 @@   haddock-arguments: ""   open-haddocks: false    # --open   haddock-deps: false     # if unspecified, defaults to true if haddock is set+  haddock-internal: false    # These are inadvisable to use in your global configuration, as they make the   # stack build CLI behave quite differently.@@ -569,17 +606,44 @@ same name. See the [build command docs](build_command.md) and the [users guide](GUIDE.md#the-build-command) for more info. +### dump-logs++(Since 1.3.0)++Control which log output from local non-dependency packages to print to the+console. By default, Stack will only do this when building a single target+package or if the log contains warnings, to avoid generating unnecessarily+verbose output.++```yaml+dump-logs: none      # don't dump logs even if they contain warnings+dump-logs: warning   # default: dump logs that contain warnings+dump-logs: all       # dump all logs for local non-dependency packages+```+ ### templates -Templates used with `stack new` have a number of parameters that affect the generated code. These can be set for all new projects you create. The result of them can be observed in the generated LICENSE and cabal files.+Templates used with `stack new` have a number of parameters that affect the+generated code. These can be set for all new projects you create. The result of+them can be observed in the generated LICENSE and cabal files.  The 5 parameters are: `author-email`, `author-name`, `category`, `copyright` and `github-username`.  * _author-email_ - sets the `maintainer` property in cabal-* _author-name_ - sets the `author` property in cabal and the name used in LICENSE-* _category_ - sets the `category` property in cabal. This is used in Hackage. For examples of categories see [Packages by category](https://hackage.haskell.org/packages/). It makes sense for `category` to be set on a per project basis because it is uncommon for all projects a user creates to belong to the same category. The category can be set per project by passing `-p "category:value"` to the `stack new` command.-* _copyright_ - sets the `copyright` property in cabal. It is typically the name of the holder of the copyright on the package and the year(s) from which copyright is claimed. For example: `Copyright: (c) 2006-2007 Joe Bloggs`-* _github-username_ - used to generate `homepage` and `source-repository` in cabal. For instance `github-username: myusername` and `stack new my-project new-template` would result:+* _author-name_ - sets the `author` property in cabal and the name used in+  LICENSE+* _category_ - sets the `category` property in cabal. This is used in Hackage.+  For examples of categories see [Packages by+  category](https://hackage.haskell.org/packages/). It makes sense for+  `category` to be set on a per project basis because it is uncommon for all+  projects a user creates to belong to the same category. The category can be+  set per project by passing `-p "category:value"` to the `stack new` command.+* _copyright_ - sets the `copyright` property in cabal. It is typically the+  name of the holder of the copyright on the package and the year(s) from which+  copyright is claimed. For example: `Copyright: (c) 2006-2007 Joe Bloggs`+* _github-username_ - used to generate `homepage` and `source-repository` in+  cabal. For instance `github-username: myusername` and `stack new my-project+  new-template` would result:  ```yaml homepage: http://github.com/myusername/my-project#readme@@ -600,6 +664,15 @@     github-username: yourusername ``` +Additionally, `stack new` can automatically initialize source control repositories+in the directories it creates.  Source control tools can be specified with the+`scm-init` option.  At the moment, only `git` is supported.++```yaml+templates:+  scm-init: git+```+   # urls  Customize the URLs where `stack` looks for snapshot build plans.
src/Control/Concurrent/Execute.hs view
@@ -38,8 +38,9 @@ data ActionContext = ActionContext     { acRemaining :: !(Set ActionId)     -- ^ Does not include the current action+    , acDownstream :: [Action]+    -- ^ Actions which depend on the current action     }-    deriving Show  data ExecuteState = ExecuteState     { esActions    :: TVar [Action]@@ -123,6 +124,7 @@                 return $ mask $ \restore -> do                     eres <- try $ restore $ actionDo action ActionContext                         { acRemaining = remaining+                        , acDownstream = downstreamActions (actionId action) as'                         }                     atomically $ do                         unlock@@ -134,3 +136,6 @@                                 let dropDep a = a { actionDeps = Set.delete (actionId action) $ actionDeps a }                                  in modifyTVar esActions $ map dropDep                     restore loop++downstreamActions :: ActionId -> [Action] -> [Action]+downstreamActions aid = filter (\a -> aid `Set.member` actionDeps a)
src/Data/Attoparsec/Interpreter.hs view
@@ -100,8 +100,8 @@       (">" *> horizontalSpace *> "{-")       *> P.skipMany (("" <$ horizontalSpace) <|> (P.endOfLine *> ">"))       *> (P.string (pack progName) <?> progName)-      *> (P.manyTill' (P.satisfy (not . P.isEndOfLine)-                       <|> (' ' <$ (P.endOfLine *> ">" <?> ">"))) "-}")+      *> P.manyTill' (P.satisfy (not . P.isEndOfLine)+                       <|> (' ' <$ (P.endOfLine *> ">" <?> ">"))) "-}"      interpreterComment = if isLiterate                             then literateLineComment <|> literateBlockComment@@ -140,15 +140,14 @@       case P.parseOnly (argsParser Escaping) (pack str) of         Left err -> handleFailure ("Error parsing command specified in the \                         \stack options comment: " ++ err)-        Right [] -> handleFailure ("Empty argument list in stack options \-                        \comment")+        Right [] -> handleFailure "Empty argument list in stack options comment"         Right args -> return args      decodeError e =       case e of         ParseError ctxs _ (Position line col) ->-          if length ctxs == 0+          if null ctxs           then "Parse error"-          else ("Expecting " ++ (intercalate " or " ctxs))-          ++ " at line " ++ (show line) ++ ", column " ++ (show col)+          else ("Expecting " ++ intercalate " or " ctxs)+          ++ " at line " ++ show line ++ ", column " ++ show col         DivergentParser -> "Divergent parser"
+ src/Data/Text/Extra.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Text.Extra where++import Data.Maybe (fromMaybe)+import qualified Data.Text as T++-- | Strip trailing carriage return from Text+stripCR :: T.Text -> T.Text+stripCR t = fromMaybe t (T.stripSuffix "\r" t)
− src/Data/Yaml/Extra.hs 
@@ -1,27 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- | Wrappers for Yaml functions to workaround--- https://github.com/commercialhaskell/stack/issues/2491.--- Import Data.Yaml.Extra in place of Data.Yaml to use this workaround.--- Beware these functions construct/deconstruct the entire file at once!-module Data.Yaml.Extra (decodeFileEither, encodeFile, module Data.Yaml) where--import           Control.Exception-import           Data.Yaml hiding (decodeFileEither, encodeFile)-import qualified Data.ByteString as B-import           System.IO---- Note: we refrain from using 'B.readFile' and 'B.writeFile', as they open--- the file in binary mode rather than text mode.-decodeFileEither :: FromJSON a => FilePath -> IO (Either ParseException a)-decodeFileEither path =-  handle (\(e :: IOException) -> return . Left . OtherParseException . SomeException $ e) $-  withFile path ReadMode $-  \hnd -> do-    fileContent <- B.hGetContents hnd-    return $ decodeEither' fileContent--encodeFile :: ToJSON a => FilePath -> a -> IO ()-encodeFile path v = withFile path WriteMode $-  \hnd -> do-    let fileContent = encode v-    B.hPut hnd fileContent
src/Network/HTTP/Download.hs view
@@ -14,54 +14,37 @@      , download     , redownload-    , downloadJSON+    , httpJSON     , parseRequest     , parseUrlThrow-    , liftHTTP-    , ask-    , getHttpManager-    , MonadReader-    , HasHttpManager+    , setGithubHeaders     ) where  import           Control.Exception           (Exception)-import           Control.Exception.Enclosed  (handleIO)+import           Control.Exception.Safe      (handleIO) import           Control.Monad               (void)-import           Control.Monad.Catch         (MonadMask, throwM)+import           Control.Monad.Catch         (throwM) import           Control.Monad.IO.Class      (MonadIO, liftIO) import           Control.Monad.Logger        (MonadLogger, logDebug)-import           Control.Monad.Reader        (MonadReader, ReaderT, ask,-                                              runReaderT)-import           Data.Aeson.Extended         (FromJSON, parseJSON)-import           Data.Aeson.Parser           (json')-import           Data.Aeson.Types            (parseEither)-import qualified Data.ByteString             as S import qualified Data.ByteString.Lazy        as L-import           Data.Conduit                (($$))-import           Data.Conduit.Attoparsec     (sinkParser)-import           Data.Conduit.Binary         (sinkHandle, sourceHandle)+import           Data.Conduit                (runConduit, runConduitRes, (.|), yield)+import           Data.Conduit.Binary         (sourceHandle) import qualified Data.Conduit.Binary         as CB import           Data.Foldable               (forM_) import           Data.Monoid                 ((<>)) import           Data.Text.Encoding.Error    (lenientDecode) import           Data.Text.Encoding          (decodeUtf8With) import           Data.Typeable               (Typeable)-import           Network.HTTP.Client         (path, checkResponse)-import           Network.HTTP.Client.Conduit (HasHttpManager, Manager, Request,-                                              Response, parseRequest,-                                              getHttpManager, parseUrlThrow,-                                              requestHeaders, responseBody,-                                              responseHeaders, responseStatus,-                                              withResponse)+import           Network.HTTP.Client         (Request, Response, path, checkResponse, parseUrlThrow, parseRequest)+import           Network.HTTP.Client.Conduit (requestHeaders) import           Network.HTTP.Download.Verified-import           Network.HTTP.Types          (status200, status304)+import           Network.HTTP.Simple         (httpJSON, withResponse, getResponseBody, getResponseHeaders, getResponseStatusCode,+                                              setRequestHeader) import           Path                        (Abs, File, Path, toFilePath) import           System.Directory            (createDirectoryIfMissing,-                                              removeFile,-                                              renameFile)+                                              removeFile) import           System.FilePath             (takeDirectory, (<.>)) import           System.IO                   (IOMode (ReadMode),-                                              IOMode (WriteMode),                                               withBinaryFile)  -- | Download the given URL to the given location. If the file already exists,@@ -70,7 +53,7 @@ -- appropriate destination. -- -- Throws an exception if things go wrong-download :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m)+download :: (MonadIO m, MonadLogger m)          => Request          -> Path Abs File -- ^ destination          -> m Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)?@@ -87,7 +70,7 @@ -- | Same as 'download', but will download a file a second time if it is already present. -- -- Returns 'True' if the file was downloaded, 'False' otherwise-redownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m)+redownload :: (MonadIO m, MonadLogger m)            => Request            -> Path Abs File -- ^ destination            -> m Bool@@ -98,7 +81,7 @@      metag <- liftIO $ handleIO (const $ return Nothing) $ fmap Just $         withBinaryFile etagFilePath ReadMode $ \h ->-            sourceHandle h $$ CB.take 512+            runConduit $ sourceHandle h .| CB.take 512      let req1 =             case metag of@@ -109,56 +92,30 @@                         [("If-None-Match", L.toStrict etag)]                     }         req2 = req1 { checkResponse = \_ _ -> return () }-    env <- ask-    liftIO $ recoveringHttp drRetryPolicyDefault $ flip runReaderT env $-      withResponse req2 $ \res -> case () of-        ()-          | responseStatus res == status200 -> liftIO $ do-              createDirectoryIfMissing True $ takeDirectory destFilePath--              -- Order here is important: first delete the etag, then write the-              -- file, then write the etag. That way, if any step fails, it will-              -- force the download to happen again.-              handleIO (const $ return ()) $ removeFile etagFilePath+    liftIO $ recoveringHttp drRetryPolicyDefault $+      withResponse req2 $ \res -> case getResponseStatusCode res of+        200 -> do+          createDirectoryIfMissing True $ takeDirectory destFilePath -              let destFilePathTmp = destFilePath <.> "tmp"-              withBinaryFile destFilePathTmp WriteMode $ \h ->-                  responseBody res $$ sinkHandle h-              renameFile destFilePathTmp destFilePath+          -- Order here is important: first delete the etag, then write the+          -- file, then write the etag. That way, if any step fails, it will+          -- force the download to happen again.+          handleIO (const $ return ()) $ removeFile etagFilePath -              forM_ (lookup "ETag" (responseHeaders res)) $ \e -> do-                  let tmp = etagFilePath <.> "tmp"-                  S.writeFile tmp e-                  renameFile tmp etagFilePath+          runConduitRes $ getResponseBody res .| CB.sinkFileCautious destFilePath -              return True-          | responseStatus res == status304 -> return False-          | otherwise -> throwM $ RedownloadFailed req2 dest $ void res+          forM_ (lookup "ETag" (getResponseHeaders res)) $ \e ->+            runConduitRes $ yield e .| CB.sinkFileCautious etagFilePath --- | Download a JSON value and parse it using a 'FromJSON' instance.-downloadJSON :: (FromJSON a, MonadReader env m, HasHttpManager env, MonadIO m, MonadMask m)-             => Request-             -> m a-downloadJSON req = do-    val <- recoveringHttp drRetryPolicyDefault $-        liftHTTP $ withResponse req $ \res ->-            responseBody res $$ sinkParser json'-    case parseEither parseJSON val of-        Left e -> throwM $ DownloadJSONException req e-        Right x -> return x+          return True+        304 -> return False+        _ -> throwM $ RedownloadFailed req2 dest $ void res -data DownloadException-    = DownloadJSONException Request String-    | RedownloadFailed Request (Path Abs File) (Response ())+data DownloadException = RedownloadFailed Request (Path Abs File) (Response ())     deriving (Show, Typeable) instance Exception DownloadException --- | A convenience method for asking for the environment and then running an--- action with its 'Manager'. Useful for avoiding a 'MonadBaseControl'--- constraint.-liftHTTP :: (MonadIO m, MonadReader env m, HasHttpManager env)-         => ReaderT Manager IO a-         -> m a-liftHTTP inner = do-    env <- ask-    liftIO $ runReaderT inner $ getHttpManager env+-- | Set the user-agent request header+setGithubHeaders :: Request -> Request+setGithubHeaders = setRequestHeader "User-Agent" ["The Haskell Stack"]+                 . setRequestHeader "Accept" ["application/vnd.github.v3+json"]
src/Network/HTTP/Download/Verified.hs view
@@ -33,7 +33,6 @@ import              Control.Monad.Catch import              Control.Monad.IO.Class import              Control.Monad.Logger (logDebug, MonadLogger)-import              Control.Monad.Reader import              Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay) import "cryptohash" Crypto.Hash import              Crypto.Hash.Conduit (sinkHash)@@ -49,7 +48,8 @@ import              Data.Text.Encoding.Error (lenientDecode) import              Data.Typeable (Typeable) import              GHC.IO.Exception (IOException(..),IOErrorType(..))-import              Network.HTTP.Client.Conduit+import              Network.HTTP.Client (getUri, path)+import              Network.HTTP.Simple (Request, HttpException, httpSink, getResponseHeaders) import              Network.HTTP.Types.Header (hContentLength, hContentMD5) import              Path import              Prelude -- Fix AMP warning@@ -221,22 +221,20 @@ -- Throws VerifiedDownloadException. -- Throws IOExceptions related to file system operations. -- Throws HttpException.-verifiedDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m)+verifiedDownload :: (MonadIO m, MonadLogger m)          => DownloadRequest          -> Path Abs File -- ^ destination-         -> (Maybe Integer -> Sink ByteString (ReaderT env IO) ()) -- ^ custom hook to observe progress+         -> (Maybe Integer -> Sink ByteString IO ()) -- ^ custom hook to observe progress          -> m Bool -- ^ Whether a download was performed verifiedDownload DownloadRequest{..} destpath progressSink = do     let req = drRequest-    env <- ask     whenM' (liftIO getShouldDownload) $ do         $logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req)         liftIO $ do             createDirectoryIfMissing True dir-            withBinaryFile fptmp WriteMode $ \h ->-                recoveringHttp drRetryPolicy $-                    flip runReaderT env $-                        withResponse req (go h)+            recoveringHttp drRetryPolicy $+                withBinaryFile fptmp WriteMode $ \h ->+                    httpSink req (go h)             renameFile fptmp fp   where     whenM' mp m = do@@ -284,7 +282,7 @@             _ -> return ()      go h res = do-        let headers = responseHeaders res+        let headers = getResponseHeaders res             mcontentLength = do               hLength <- List.lookup hContentLength headers               (i,_) <- readInteger hLength@@ -300,9 +298,8 @@                 Nothing -> []                 ) ++ drHashChecks -        responseBody res-            $= maybe (awaitForever yield) CB.isolate drLengthCheck-            $$ getZipSink+        maybe id (\len -> (CB.isolate len =$=)) drLengthCheck+            $ getZipSink                 ( hashChecksToZipSink drRequest hashChecks                   *> maybe (pure ()) (assertLengthSink drRequest) drLengthCheck                   *> ZipSink (sinkHandle h)
src/Options/Applicative/Builder/Extra.hs view
@@ -93,8 +93,8 @@             mods)) <|>        flag'            disabledValue-           (long (concat ["[no-]", name]) <>-            help (concat ["Enable/disable ", helpSuffix]) <>+           (long ("[no-]" ++ name) <>+            help ("Enable/disable " ++ helpSuffix) <>             mods))  -- | Show an extra help option (e.g. @--docker-help@ shows help for all @--docker*@ args).
src/Path/Extra.hs view
@@ -53,21 +53,19 @@ -- > collapseFilePath "parent/foo/.." ==  "parent" -- > collapseFilePath "/parent/foo/../../bar" ==  "/bar" ----- (borrowed from @Text.Pandoc.Shared@)+-- (adapted from @Text.Pandoc.Shared@) collapseFilePath :: FilePath -> FilePath collapseFilePath = FP.joinPath . reverse . foldl go [] . FP.splitDirectories   where     go rs "." = rs     go r@(p:rs) ".." = case p of                             ".." -> "..":r-                            (checkPathSeperator -> Just True) -> "..":r+                            (checkPathSeparator -> True) -> "..":r                             _ -> rs-    go _ (checkPathSeperator -> Just True) = [[FP.pathSeparator]]+    go _ (checkPathSeparator -> True) = [[FP.pathSeparator]]     go rs x = x:rs-    isSingleton [] = Nothing-    isSingleton [x] = Just x-    isSingleton _ = Nothing-    checkPathSeperator = fmap FP.isPathSeparator . isSingleton+    checkPathSeparator [x] = FP.isPathSeparator x+    checkPathSeparator _ = False  -- | Drop the root (either @\/@ on POSIX or @C:\\@, @D:\\@, etc. on -- Windows).
src/Stack/Build.hs view
@@ -22,7 +22,6 @@  import           Control.Exception (Exception) import           Control.Monad-import           Control.Monad.Catch (MonadMask, MonadMask) import           Control.Monad.IO.Class import           Control.Monad.Logger import           Control.Monad.Reader (MonadReader, asks)@@ -37,9 +36,11 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import           Data.Map.Strict (Map)+import           Data.Maybe (catMaybes) import           Data.Monoid import           Data.Set (Set) import qualified Data.Set as Set+import           Data.String import           Data.Text (Text) import qualified Data.Text as T import           Data.Text.Encoding (decodeUtf8)@@ -48,7 +49,6 @@ import           Data.Typeable (Typeable) import qualified Data.Vector as V import qualified Data.Yaml as Yaml-import           Network.HTTP.Client.Conduit (HasHttpManager) import           Path import           Prelude hiding (FilePath, writeFile) import           Stack.Build.ConstructPlan@@ -60,14 +60,17 @@ import           Stack.Fetch as Fetch import           Stack.GhcPkg import           Stack.Package+import           Stack.PackageIndex+import           Stack.PrettyPrint+import           Stack.Types.Build+import           Stack.Types.Config import           Stack.Types.FlagName+import           Stack.Types.Package import           Stack.Types.PackageIdentifier import           Stack.Types.PackageName+import           Stack.Types.StackT import           Stack.Types.Version-import           Stack.Types.Config-import           Stack.Types.Build-import           Stack.Types.Package-import           Stack.Types.Internal+ #ifdef WINDOWS import           Stack.Types.Compiler #endif@@ -78,14 +81,12 @@ import qualified Control.Monad.Catch as Catch #endif -type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLoggerIO m,MonadBaseUnlift IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)- -- | Build. -- --   If a buildLock is passed there is an important contract here.  That lock must --   protect the snapshot, and it must be safe to unlock it if there are no further --   modifications to the snapshot to be performed by this build.-build :: M env m+build :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)       => (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files       -> Maybe FileLock       -> BuildOptsCLI@@ -95,7 +96,7 @@     let profiling = boptsLibProfile bopts || boptsExeProfile bopts     menv <- getMinimalEnvOverride -    (targets, mbp, locals, extraToBuild, sourceMap) <- loadSourceMap NeedTargets boptsCli+    (targets, mbp, locals, extraToBuild, extraDeps, sourceMap) <- loadSourceMapFull NeedTargets boptsCli      -- Set local files, necessary for file watching     stackYaml <- asks $ bcStackYaml . getBuildConfig@@ -111,6 +112,8 @@                          , getInstalledHaddock   = shouldHaddockDeps bopts }                      sourceMap +    warnMissingExtraDeps installedMap extraDeps+     baseConfigOpts <- mkBaseConfigOpts boptsCli     plan <- withLoadPackage menv $ \loadPackage ->         constructPlan mbp baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap@@ -150,7 +153,7 @@     Map.elems .     planTasks -checkCabalVersion :: M env m => m ()+checkCabalVersion :: (StackM env m, HasEnvConfig env) => m () checkCabalVersion = do     allowNewer <- asks (configAllowNewer . getConfig)     cabalVer <- asks (envConfigCabalVersion . getEnvConfig)@@ -167,6 +170,25 @@ instance Show CabalVersionException where show = unCabalVersionException instance Exception CabalVersionException +warnMissingExtraDeps+    :: (StackM env m, HasConfig env)+    => InstalledMap -> Map PackageName Version -> m ()+warnMissingExtraDeps installed extraDeps = do+    missingExtraDeps <-+        fmap catMaybes $ forM (Map.toList extraDeps) $ \(n, v) ->+            if Map.member n installed+                then return Nothing+                else do+                    vs <- getPackageVersions n+                    if Set.null vs+                        then return $ Just $+                            fromString (packageNameString n ++ "-" ++ versionString v)+                        else return Nothing+    unless (null missingExtraDeps) $+        $prettyWarn $+            "Some extra-deps are neither installed nor in the index:" <> line <>+            indent 4 (bulletedList missingExtraDeps)+ -- | See https://github.com/commercialhaskell/stack/issues/1198. warnIfExecutablesWithSameNameCouldBeOverwritten     :: MonadLogger m => [LocalPackage] -> Plan -> m ()@@ -275,13 +297,7 @@         }  -- | Provide a function for loading package information from the package index-withLoadPackage :: ( MonadIO m-                   , HasHttpManager env-                   , MonadReader env m-                   , MonadBaseUnlift IO m-                   , MonadMask m-                   , MonadLogger m-                   , HasEnvConfig env)+withLoadPackage :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)                 => EnvOverride                 -> ((PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -> m a)                 -> m a@@ -311,7 +327,7 @@ -- | Set the code page for this process as necessary. Only applies to Windows. -- See: https://github.com/commercialhaskell/stack/issues/738 #ifdef WINDOWS-fixCodePage :: M env m => m a -> m a+fixCodePage :: (StackM env m, HasBuildConfig env, HasEnvConfig env) => m a -> m a fixCodePage inner = do     mcp <- asks $ configModifyCodePage . getConfig     ec <- asks getEnvConfig@@ -358,7 +374,7 @@ #endif  -- | Query information about the build and print the result to stdout in YAML format.-queryBuildInfo :: M env m+queryBuildInfo :: (StackM env m, HasEnvConfig env)                => [Text] -- ^ selectors                -> m () queryBuildInfo selectors0 =@@ -385,9 +401,9 @@         err msg = error $ msg ++ ": " ++ show (front [sel])  -- | Get the raw build information object-rawBuildInfo :: M env m => m Value+rawBuildInfo :: (StackM env m, HasEnvConfig env) => m Value rawBuildInfo = do-    (_, _mbp, locals, _extraToBuild, _sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI+    (locals, _sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI     return $ object         [ "locals" .= Object (HM.fromList $ map localToPair locals)         ]
src/Stack/Build/Cache.hs view
@@ -31,8 +31,9 @@     , BuildCache(..)     ) where +import           Control.Applicative import           Control.DeepSeq (NFData)-import           Control.Exception.Enclosed (handleIO, tryAnyDeep)+import           Control.Exception.Safe (handleIO, tryAnyDeep) import           Control.Monad (liftM) import           Control.Monad.Catch (MonadThrow, MonadCatch) import           Control.Monad.IO.Class@@ -62,6 +63,7 @@ import           Data.Traversable (forM) import           Path import           Path.IO+import           Prelude -- Fix redundant import warnings import           Stack.Constants import           Stack.Types.Build import           Stack.Types.Compiler@@ -301,11 +303,11 @@             Library _ ipid -> liftM Just $ do                 ipid' <- parseRelFile $ ghcPkgIdString ipid ++ ".conf"                 relPath <- stackRootRelative $ bcoSnapDB baseConfigOpts </> ipid'-                return $ toFilePath $ relPath+                return $ toFilePath relPath     exes' <- forM (Set.toList exes) $ \exe -> do         name <- parseRelFile $ T.unpack exe         relPath <- stackRootRelative $ bcoSnapInstallRoot baseConfigOpts </> bindirSuffix </> name-        return $ toFilePath $ relPath+        return $ toFilePath relPath     $(versionedEncodeFile precompiledCacheVC) file PrecompiledCache         { pcLibrary = mlibpath         , pcExes = exes'@@ -337,7 +339,7 @@         Nothing -> do             -- Fallback on trying the old binary format.             oldFile <- getOldFile-            mpc <- fmap (fmap toAbsPC) $ binaryDecodeFileOrFailDeep oldFile+            mpc <- fmap toAbsPC <$> binaryDecodeFileOrFailDeep oldFile             -- Write out file in new format. Keep old file around for             -- the benefit of older stack versions.             forM_ mpc ($(versionedEncodeFile precompiledCacheVC) file)@@ -349,7 +351,7 @@ binaryDecodeFileOrFailDeep :: (BinarySchema a, MonadIO m)                            => Path loc File                            -> m (Maybe a)-binaryDecodeFileOrFailDeep fp = liftIO $ fmap (either (\_ -> Nothing) id) $ tryAnyDeep $ do+binaryDecodeFileOrFailDeep fp = liftIO $ fmap (either (const Nothing) id) $ tryAnyDeep $ do     eres <- BinaryTagged.taggedDecodeFileOrFail (toFilePath fp)     case eres of         Left _ -> return Nothing
src/Stack/Build/ConstructPlan.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}@@ -17,7 +18,6 @@ import           Control.Arrow ((&&&)) import           Control.Exception.Lifted import           Control.Monad-import           Control.Monad.Catch (MonadCatch) import           Control.Monad.IO.Class import           Control.Monad.Logger import           Control.Monad.RWS.Strict@@ -42,7 +42,6 @@ import qualified Distribution.Version as Cabal import           GHC.Generics (Generic) import           Generics.Deriving.Monoid (memptydefault, mappenddefault)-import           Network.HTTP.Client.Conduit (HasHttpManager) import           Path import           Prelude hiding (pi, writeFile) import           Stack.Build.Cache@@ -50,24 +49,28 @@ import           Stack.Build.Installed import           Stack.Build.Source import           Stack.BuildPlan+import           Stack.Constants import           Stack.Package import           Stack.PackageDump import           Stack.PackageIndex import           Stack.PrettyPrint import           Stack.Types.Build+import           Stack.Types.Compiler import           Stack.Types.Config import           Stack.Types.FlagName import           Stack.Types.GhcPkgId-import           Stack.Types.Internal (HasTerminal) import           Stack.Types.Package import           Stack.Types.PackageIdentifier import           Stack.Types.PackageName+import           Stack.Types.StackT (StackM) import           Stack.Types.Version+import           System.Process.Read (findExecutable)  data PackageInfo     = PIOnlyInstalled InstallLocation Installed     | PIOnlySource PackageSource     | PIBoth PackageSource Installed+    deriving (Show)  combineSourceInstalled :: PackageSource                        -> (InstallLocation, Installed)@@ -142,8 +145,7 @@ instance HasEnvConfig Ctx where     getEnvConfig = ctxEnvConfig -constructPlan :: forall env m.-                 (MonadCatch m, MonadReader env m, HasEnvConfig env, MonadLoggerIO m, MonadBaseControl IO m, HasHttpManager env, HasTerminal env)+constructPlan :: forall env m. (StackM env m, HasEnvConfig env)               => MiniBuildPlan               -> BaseConfigOpts               -> [LocalPackage]@@ -192,6 +194,7 @@                         else Map.empty                 }         else do+            planDebug $ show errs             $prettyError $ pprintExceptions errs (bcStackYaml (getBuildConfig econfig)) parents (wantedLocalPackages locals)             throwM $ ConstructPlanFailed "Plan construction failed."   where@@ -277,12 +280,18 @@     when treatAsDep $ markAsDep name     m <- get     case Map.lookup name m of-        Just res -> return res+        Just res -> do+            planDebug $ "addDep: Using cached result for " ++ show name ++ ": " ++ show res+            return res         Nothing -> do             res <- if name `elem` callStack ctx-                then return $ Left $ DependencyCycleDetected $ name : callStack ctx-                else local (\ctx' -> ctx' { callStack = name : callStack ctx' }) $-                    case Map.lookup name $ combinedMap ctx of+                then do+                    planDebug $ "addDep: Detected cycle " ++ show name ++ ": " ++ show (callStack ctx)+                    return $ Left $ DependencyCycleDetected $ name : callStack ctx+                else local (\ctx' -> ctx' { callStack = name : callStack ctx' }) $ do+                    let mpackageInfo = Map.lookup name $ combinedMap ctx+                    planDebug $ "addDep: Package info for " ++ show name ++ ": " ++ show mpackageInfo+                    case mpackageInfo of                         -- TODO look up in the package index and see if there's a                         -- recommendation available                         Nothing -> return $ Left $ UnknownPackage name@@ -296,7 +305,7 @@                         Just (PIBoth ps installed) -> do                             tellExecutables name ps                             installPackage treatAsDep name ps (Just installed)-            modify $ Map.insert name res+            updateLibMap name res             return res  tellExecutables :: PackageName -> PackageSource -> M ()@@ -329,7 +338,7 @@         goSource (PSLocal lp)             | lpWanted lp = exeComponents (lpComponents lp)             | otherwise = Set.empty-        goSource (PSUpstream{}) = Set.empty+        goSource PSUpstream{} = Set.empty      tell mempty { wInstall = Map.fromList $ map (, loc) $ Set.toList $ filterComps myComps $ packageExes p }   where@@ -346,11 +355,14 @@     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 False treatAsDep ps package minstalled+            resolveDepsAndInstall True treatAsDep ps package minstalled         PSLocal lp ->             case lpTestBench lp of-                Nothing -> resolveDepsAndInstall False treatAsDep ps (lpPackage lp) minstalled+                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                 Just tb -> do                     -- Attempt to find a plan which performs an all-in-one                     -- build.  Ignore the writer action + reset the state if@@ -364,6 +376,7 @@                         return (res, writerFunc)                     case res of                         Right deps -> do+                          planDebug $ "installPackage: For " ++ show name ++ ", successfully added package deps"                           adr <- installPackageGivenDeps True ps tb minstalled deps                           -- FIXME: this redundantly adds the deps (but                           -- they'll all just get looked up in the map)@@ -373,6 +386,7 @@                             -- Reset the state to how it was before                             -- attempting to find an all-in-one build                             -- plan.+                            planDebug $ "installPackage: Before trying cyclic plan, resetting lib result map to " ++ show s                             put s                             -- Otherwise, fall back on building the                             -- tests / benchmarks in a separate step.@@ -380,7 +394,7 @@                             when (isRight res') $ do                                 -- Insert it into the map so that it's                                 -- available for addFinal.-                                modify $ Map.insert name res'+                                updateLibMap name res'                                 addFinal lp tb False                             return res' @@ -442,6 +456,14 @@             , taskAllInOne = isAllInOne             } +-- Update response in the lib map. If it is an error, and there's+-- already an error about cyclic dependencies, prefer the cyclic error.+updateLibMap :: PackageName -> Either ConstructPlanException AddDepRes -> M ()+updateLibMap name val = modify $ \mp ->+    case (M.lookup name mp, val) of+        (Just (Left DependencyCycleDetected{}), Left _) -> mp+        _ -> M.insert name val mp+ addEllipsis :: Text -> Text addEllipsis t     | T.length t < 100 = t@@ -584,18 +606,22 @@         go       where         go [] = []-        go ("--ghc-option":x:xs) = go' x xs-        go ("--ghc-options":x:xs) = go' x xs-        go ((T.stripPrefix "--ghc-option=" -> Just x):xs) = go' x xs-        go ((T.stripPrefix "--ghc-options=" -> Just x):xs) = go' x xs+        go ("--ghc-option":x:xs) = go' Ghc x xs+        go ("--ghc-options":x:xs) = go' Ghc x xs+        go ((T.stripPrefix "--ghc-option=" -> Just x):xs) = go' Ghc x xs+        go ((T.stripPrefix "--ghc-options=" -> Just x):xs) = go' Ghc x xs+        go ("--ghcjs-option":x:xs) = go' Ghcjs x xs+        go ("--ghcjs-options":x:xs) = go' Ghcjs x xs+        go ((T.stripPrefix "--ghcjs-option=" -> Just x):xs) = go' Ghcjs x xs+        go ((T.stripPrefix "--ghcjs-options=" -> Just x):xs) = go' Ghcjs x xs         go (x:xs) = x : go xs -        go' x xs = checkKeepers x $ go xs+        go' wc x xs = checkKeepers wc x $ go xs -        checkKeepers x xs =+        checkKeepers wc x xs =             case filter isKeeper $ T.words x of                 [] -> xs-                keepers -> "--ghc-options" : T.unwords keepers : xs+                keepers -> T.pack (compilerOptionsCabalFlag wc) : T.unwords keepers : xs          -- GHC options which affect build results and therefore should always         -- force a rebuild@@ -622,15 +648,15 @@  psForceDirty :: PackageSource -> Bool psForceDirty (PSLocal lp) = lpForceDirty lp-psForceDirty (PSUpstream {}) = False+psForceDirty PSUpstream{} = False  psDirty :: PackageSource -> Maybe (Set FilePath) psDirty (PSLocal lp) = lpDirtyFiles lp-psDirty (PSUpstream {}) = Nothing -- files never change in an upstream package+psDirty PSUpstream{} = Nothing -- files never change in an upstream package  psLocal :: PackageSource -> Bool psLocal (PSLocal _) = True-psLocal (PSUpstream {}) = False+psLocal PSUpstream{} = False  -- | Get all of the dependencies for a given package, including guessed build -- tool dependencies.@@ -639,15 +665,25 @@     ctx <- ask     -- TODO: it would be cool to defer these warnings until there's an     -- actual issue building the package.-    -- TODO: check if the tool is on the path before warning?     let toEither (Cabal.Dependency (Cabal.PackageName name) _) mp =             case Map.toList mp of                 [] -> Left (NoToolFound name (packageName p))                 [_] -> Right mp                 xs -> Left (AmbiguousToolsFound name (packageName p) (map fst xs))-        (warnings, toolDeps) =+        (warnings0, toolDeps) =              partitionEithers $              map (\dep -> toEither dep (toolToPackages ctx dep)) (packageTools p)+    -- Check whether the tool is on the PATH before warning about it.+    warnings <- fmap catMaybes $ forM warnings0 $ \warning -> do+        let toolName = case warning of+                NoToolFound tool _ -> tool+                AmbiguousToolsFound tool _ _ -> tool+        config <- asks getConfig+        menv <- liftIO $ configEnvOverride config minimalEnvSettings { esIncludeLocals = True }+        mfound <- findExecutable menv toolName+        case mfound of+            Nothing -> return (Just warning)+            Just _ -> return Nothing     tell mempty { wWarnings = (map toolWarningText warnings ++) }     when (any isNoToolFound warnings) $ do         let msg = T.unlines@@ -725,7 +761,7 @@     | 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)+    deriving (Typeable, Eq, Show)  -- | For display purposes only, Nothing if package not found type LatestApplicableVersion = Maybe Version@@ -735,7 +771,7 @@     = NotInBuildPlan     | Couldn'tResolveItsDependencies Version     | DependencyMismatch Version-    deriving (Typeable, Eq)+    deriving (Typeable, Eq, Show)  -- TODO: Consider intersecting version ranges for multiple deps on a -- package.  This is why VersionRange is in the parent map.@@ -747,7 +783,6 @@     -> Set PackageName     -> AnsiDoc pprintExceptions exceptions stackYaml parentMap wanted =-    line <>     "While constructing the build plan, the following exceptions were encountered:" <> line <> line <>     mconcat (intersperse (line <> line) (mapMaybe pprintException exceptions')) <> line <>     if Map.null extras then "" else@@ -774,9 +809,9 @@     pprintExtra (name, version) =       fromString (concat ["- ", packageNameString name, "-", versionString version]) -    pprintException (DependencyCycleDetected pNames) = Just $ errorRed $+    pprintException (DependencyCycleDetected pNames) = Just $         "Dependency cycle detected in packages:" <> line <>-        indent 4 (encloseSep "[" "]" "," (map (fromString . packageNameString) pNames))+        indent 4 (encloseSep "[" "]" "," (map (errorRed . fromString . packageNameString) pNames))     pprintException (DependencyPlanFailures pkg (Map.toList -> pDeps)) =         case mapMaybe pprintDep pDeps of             [] -> Nothing@@ -819,8 +854,7 @@         -- I think the main useful info is these explain why missing         -- packages are needed. Instead lets give the user the shortest         -- path from a target to the package.-        Couldn'tResolveItsDependencies _version ->-            Nothing+        Couldn'tResolveItsDependencies _version -> Nothing       where         goodRange = goodGreen (fromString (Cabal.display range))         latestApplicable mversion =@@ -901,3 +935,7 @@ instance (Ord k, Monoid a) => Monoid (MonoidMap k a) where     mappend (MonoidMap mp1) (MonoidMap mp2) = MonoidMap (M.unionWith mappend mp1 mp2)     mempty = MonoidMap mempty++-- Switch this to 'True' to enable some debugging putStrLn in this module+planDebug :: MonadIO m => String -> m ()+planDebug = if False then liftIO . putStrLn else \_ -> return ()
src/Stack/Build/Execute.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE TypeFamilies          #-} -- | Perform a build module Stack.Build.Execute     ( printPlan@@ -22,24 +23,27 @@ import           Control.Concurrent.Execute import           Control.Concurrent.MVar.Lifted import           Control.Concurrent.STM-import           Control.Exception.Enclosed (catchIO)+import           Control.Exception.Safe (catchIO) import           Control.Exception.Lifted import           Control.Monad (liftM, when, unless, void)-import           Control.Monad.Catch (MonadCatch, MonadMask)+import           Control.Monad.Catch (MonadCatch) import           Control.Monad.Extra (anyM, (&&^)) import           Control.Monad.IO.Class import           Control.Monad.Logger-import           Control.Monad.Reader (MonadReader, asks)+import           Control.Monad.Reader (asks) import           Control.Monad.Trans.Control (liftBaseWith) import           Control.Monad.Trans.Resource+import qualified Crypto.Hash.SHA256 as SHA256 import           Data.Attoparsec.Text hiding (try) import qualified Data.ByteString as S+import qualified Data.ByteString.Base64.URL as B64URL import           Data.Char (isSpace) import           Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import qualified Data.Conduit.Text as CT import           Data.Either (isRight)+import           Data.FileEmbed (embedFile, makeRelativeToProject) import           Data.Foldable (forM_, any) import           Data.Function import           Data.IORef.RunOnce (runOnce)@@ -48,21 +52,23 @@ import qualified Data.Map.Strict as Map import           Data.Maybe import           Data.Maybe.Extra (forMaybeM)-import           Data.Monoid ((<>))+import           Data.Monoid import           Data.Set (Set) import qualified Data.Set as Set import           Data.Streaming.Process hiding (callProcess, env)+import           Data.String import           Data.Text (Text) import qualified Data.Text as T-import           Data.Text.Encoding (decodeUtf8)+import           Data.Text.Encoding (decodeUtf8, encodeUtf8)+import           Data.Text.Extra (stripCR) import           Data.Time.Clock (getCurrentTime) import           Data.Traversable (forM) import           Data.Tuple import qualified Distribution.PackageDescription as C import           Distribution.System            (OS (Windows),                                                  Platform (Platform))+import qualified Distribution.Text as C import           Language.Haskell.TH as TH (location)-import           Network.HTTP.Client.Conduit (HasHttpManager) import           Path import           Path.Extra (toFilePathNoTrailingSep, rejectMissingFile) import           Path.IO hiding (findExecutable, makeAbsolute)@@ -79,16 +85,17 @@ import           Stack.GhcPkg import           Stack.Package import           Stack.PackageDump-import           Stack.Types.GhcPkgId-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Version-import           Stack.Types.Config+import           Stack.PrettyPrint import           Stack.Types.Build-import           Stack.Types.Package import           Stack.Types.Compiler+import           Stack.Types.Config+import           Stack.Types.GhcPkgId import           Stack.Types.Internal+import           Stack.Types.Package+import           Stack.Types.PackageIdentifier+import           Stack.Types.PackageName import           Stack.Types.StackT+import           Stack.Types.Version import qualified System.Directory as D import           System.Environment (getExecutablePath) import           System.Exit (ExitCode (ExitSuccess))@@ -103,10 +110,8 @@ import           System.Process.Internals (createProcess_) #endif -type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env, HasConfig env)- -- | Fetch the packages necessary for a build, for example in combination with a dry run.-preFetch :: M env m => Plan -> m ()+preFetch :: (StackM env m, HasEnvConfig env) => Plan -> m () preFetch plan     | Set.null idents = $logDebug "Nothing to fetch"     | otherwise = do@@ -126,7 +131,7 @@                 (packageVersion package)  -- | Print a description of build plan for human consumption.-printPlan :: M env m+printPlan :: (StackM env m)           => Plan           -> m () printPlan plan = do@@ -192,10 +197,8 @@         Local -> "local"     , ", source="     , case taskType task of-        TTLocal lp -> concat-            [ toFilePath $ lpDir lp-            ]-        TTUpstream _ _ _ -> "package index"+        TTLocal lp -> toFilePath $ lpDir lp+        TTUpstream{} -> "package index"     , if Set.null missing         then ""         else ", after: " ++ intercalate "," (map packageIdentifierString $ Set.toList missing)@@ -214,6 +217,8 @@     , eeTempDir        :: !(Path Abs Dir)     , eeSetupHs        :: !(Path Abs File)     -- ^ Temporary Setup.hs for simple builds+    , eeSetupShimHs    :: !(Path Abs File)+    -- ^ Temporary SetupShim.hs, to provide access to initial-build-steps     , eeSetupExe       :: !(Maybe (Path Abs File))     -- ^ Compiled version of eeSetupHs     , eeCabalPkgVer    :: !Version@@ -224,22 +229,52 @@     , eeGlobalDumpPkgs :: !(Map GhcPkgId (DumpPackage () ()))     , eeSnapshotDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () ())))     , eeLocalDumpPkgs  :: !(TVar (Map GhcPkgId (DumpPackage () ())))+    , eeLogFiles       :: !(TChan (Path Abs Dir, Path Abs File))     } +buildSetupArgs :: [String]+buildSetupArgs =+     [ "-rtsopts"+     , "-threaded"+     , "-clear-package-db"+     , "-global-package-db"+     , "-hide-all-packages"+     , "-package"+     , "base"+     , "-main-is"+     , "StackSetupShim.mainOverride"+     ]++setupGhciShimCode :: S.ByteString+setupGhciShimCode = $(do+    path <- makeRelativeToProject "src/setup-shim/StackSetupShim.hs"+    embedFile path)++simpleSetupCode :: S.ByteString+simpleSetupCode = "import Distribution.Simple\nmain = defaultMain"++simpleSetupHash :: String+simpleSetupHash =+    T.unpack $ decodeUtf8 $ S.take 8 $ B64URL.encode $ SHA256.hash $+    encodeUtf8 (T.pack (unwords buildSetupArgs)) <> setupGhciShimCode <> simpleSetupCode+ -- | Get a compiled Setup exe-getSetupExe :: M env m+getSetupExe :: (StackM env m, HasEnvConfig env)             => Path Abs File -- ^ Setup.hs input file+            -> Path Abs File -- ^ SetupShim.hs input file             -> Path Abs Dir -- ^ temporary directory             -> m (Maybe (Path Abs File))-getSetupExe setupHs tmpdir = do+getSetupExe setupHs setupShimHs tmpdir = do     wc <- getWhichCompiler     econfig <- asks getEnvConfig     platformDir <- platformGhcRelDir     let config = getConfig econfig         baseNameS = concat-            [ "setup-Simple-Cabal-"+            [ "Cabal-simple_"+            , simpleSetupHash+            , "_"             , versionString $ envConfigCabalVersion econfig-            , "-"+            , "_"             , compilerVersionString $ envConfigCompilerVersion econfig             ]         exeNameS = baseNameS ++@@ -257,8 +292,8 @@             $(mkRelDir "setup-exe-cache") </>             platformDir -    exePath <- fmap (setupDir </>) $ parseRelFile exeNameS-    jsExePath <- fmap (setupDir </>) $ parseRelDir jsExeNameS+    exePath <- (setupDir </>) <$> parseRelFile exeNameS+    jsExePath <- (setupDir </>) <$> parseRelDir jsExeNameS      exists <- liftIO $ D.doesFileExist $ toFilePath exePath @@ -268,22 +303,15 @@             tmpExePath <- fmap (setupDir </>) $ parseRelFile $ "tmp-" ++ exeNameS             tmpOutputPath <- fmap (setupDir </>) $ parseRelFile $ "tmp-" ++ outputNameS             tmpJsExePath <- fmap (setupDir </>) $ parseRelDir $ "tmp-" ++ jsExeNameS--            liftIO $ D.createDirectoryIfMissing True $ toFilePath setupDir-+            ensureDir setupDir             menv <- getMinimalEnvOverride-            let args =-                    [ "-clear-package-db"-                    , "-global-package-db"-                    , "-hide-all-packages"-                    , "-package"-                    , "base"-                    , "-package"+            let args = buildSetupArgs +++                    [ "-package"                     , "Cabal-" ++ versionString (envConfigCabalVersion econfig)                     , toFilePath setupHs+                    , toFilePath setupShimHs                     , "-o"                     , toFilePath tmpOutputPath-                    , "-rtsopts"                     ] ++                     ["-build-runner" | wc == Ghcjs]             runCmd' (\cp -> cp { std_out = UseHandle stderr }) (Cmd (Just tmpdir) (compilerExeName wc) menv args) Nothing@@ -292,7 +320,7 @@             return $ Just exePath  -- | Execute a callback that takes an 'ExecuteEnv'.-withExecuteEnv :: M env m+withExecuteEnv :: (StackM env m, HasEnvConfig env)                => EnvOverride                -> BuildOpts                -> BuildOptsCLI@@ -308,13 +336,29 @@         configLock <- newMVar ()         installLock <- newMVar ()         idMap <- liftIO $ newTVarIO Map.empty-        let setupHs = tmpdir </> $(mkRelFile "Setup.hs")-        liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain"-        setupExe <- getSetupExe setupHs tmpdir+        config <- asks (getConfig . getEnvConfig)++        -- Create files for simple setup and setup shim, if necessary+        let setupSrcDir =+                configStackRoot config </>+                $(mkRelDir "setup-exe-src")+        ensureDir setupSrcDir+        setupFileName <- parseRelFile ("setup-" ++ simpleSetupHash ++ ".hs")+        let setupHs = setupSrcDir </> setupFileName+        setupHsExists <- doesFileExist setupHs+        unless setupHsExists $ liftIO $ S.writeFile (toFilePath setupHs) simpleSetupCode+        setupShimFileName <- parseRelFile ("setup-shim-" ++ simpleSetupHash ++ ".hs")+        let setupShimHs = setupSrcDir </> setupShimFileName+        setupShimHsExists <- doesFileExist setupShimHs+        unless setupShimHsExists $ liftIO $ S.writeFile (toFilePath setupShimHs) setupGhciShimCode+        setupExe <- getSetupExe setupHs setupShimHs tmpdir+         cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)         globalDB <- getGlobalDB menv =<< getWhichCompiler         snapshotPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages)         localPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId localPackages)+        logFilesTChan <- liftIO $ atomically newTChan+        let totalWanted = length $ filter lpWanted locals         inner ExecuteEnv             { eeEnvOverride = menv             , eeBuildOpts = bopts@@ -329,21 +373,72 @@             , eeGhcPkgIds = idMap             , eeTempDir = tmpdir             , eeSetupHs = setupHs+            , eeSetupShimHs = setupShimHs             , eeSetupExe = setupExe             , eeCabalPkgVer = cabalPkgVer-            , eeTotalWanted = length $ filter lpWanted locals+            , eeTotalWanted = totalWanted             , eeWanted = wantedLocalPackages locals             , eeLocals = locals             , eeGlobalDB = globalDB             , eeGlobalDumpPkgs = toDumpPackagesByGhcPkgId globalPackages             , eeSnapshotDumpPkgs = snapshotPackagesTVar             , eeLocalDumpPkgs = localPackagesTVar-            }+            , eeLogFiles = logFilesTChan+            } `finally` dumpLogs logFilesTChan totalWanted   where     toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dpGhcPkgId dp, dp)) +    dumpLogs chan totalWanted = do+        allLogs <- fmap reverse $ liftIO $ atomically drainChan+        case allLogs of+            -- No log files generated, nothing to dump+            [] -> return ()+            firstLog:_ -> do+                toDump <- asks (configDumpLogs . getConfig)+                case toDump of+                    DumpAllLogs -> mapM_ (dumpLog "") allLogs+                    DumpWarningLogs -> mapM_ dumpLogIfWarning allLogs+                    DumpNoLogs+                        | totalWanted > 1 ->+                            $logInfo $ T.concat+                                [ "Build output has been captured to log files, use "+                                , "--dump-logs to see it on the console"+                                ]+                        | otherwise -> return ()+                $logInfo $ T.pack $ "Log files have been written to: "+                        ++ toFilePath (parent (snd firstLog))+      where+        drainChan = do+            mx <- tryReadTChan chan+            case mx of+                Nothing -> return []+                Just x -> do+                    xs <- drainChan+                    return $ x:xs++    dumpLogIfWarning (pkgDir, filepath) = do+      firstWarning <- runResourceT+          $ CB.sourceFile (toFilePath filepath)+         $$ CT.decodeUtf8Lenient+         =$ CT.lines+         =$ CL.map stripCR+         =$ CL.filter isWarning+         =$ CL.take 1+      unless (null firstWarning) $ dumpLog " due to warnings" (pkgDir, filepath)++    isWarning t = ": Warning:" `T.isSuffixOf` t++    dumpLog msgSuffix (pkgDir, filepath) = do+        $logInfo $ T.pack $ concat ["\n--  Dumping log file", msgSuffix, ": ", toFilePath filepath, "\n"]+        runResourceT+            $ CB.sourceFile (toFilePath filepath)+           $$ CT.decodeUtf8Lenient+           =$ mungeBuildOutput True True pkgDir+           =$ CL.mapM_ $logInfo+        $logInfo $ T.pack $ "\n--  End of log file: " ++ toFilePath filepath ++ "\n"+ -- | Perform the actual plan-executePlan :: M env m+executePlan :: (StackM env m, HasEnvConfig env)             => EnvOverride             -> BuildOptsCLI             -> BaseConfigOpts@@ -478,7 +573,7 @@     old = dest ++ ".old"  -- | Perform the actual plan (internal)-executePlan' :: M env m+executePlan' :: (StackM env m, HasEnvConfig env)              => InstalledMap              -> Map PackageName SimpleTarget              -> Plan@@ -524,9 +619,7 @@     threads <- asks $ configJobs . getConfig     concurrentTests <- asks $ configConcurrentTests . getConfig     let keepGoing =-            case boptsKeepGoing eeBuildOpts of-                Just kg -> kg-                Nothing -> boptsTests eeBuildOpts || boptsBenchmarks eeBuildOpts+            fromMaybe (boptsTests eeBuildOpts || boptsBenchmarks eeBuildOpts) (boptsKeepGoing eeBuildOpts)         concurrentFinal =             -- TODO it probably makes more sense to use a lock for test suites             -- and just have the execution blocked. Turning off all concurrency@@ -548,9 +641,7 @@                         check $ done /= prev                         return done                     loop done-        if total > 1-            then loop 0-            else return ()+        when (total > 1) $ loop 0     when (toCoverage $ boptsTestOpts eeBuildOpts) $ do         generateHpcUnifiedReport         generateHpcMarkupIndex@@ -578,7 +669,7 @@                   $ Map.elems                   $ planUnregisterLocal plan -toActions :: M env m+toActions :: (StackM env m, HasEnvConfig env)           => InstalledMap           -> (m () -> IO ())           -> ExecuteEnv@@ -594,7 +685,7 @@                 [ Action                     { actionId = ActionId taskProvides ATBuild                     , actionDeps =-                        (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts))+                        Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)                     , actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap False                     }                 ]@@ -632,7 +723,7 @@     beopts = boptsBenchmarkOpts bopts  -- | Generate the ConfigCache-getConfigCache :: M env m+getConfigCache :: (StackM env m, HasEnvConfig env)                => ExecuteEnv -> Task -> InstalledMap -> Bool -> Bool                -> m (Map PackageIdentifier GhcPkgId, ConfigCache) getConfigCache ExecuteEnv {..} Task {..} installedMap enableTest enableBench = do@@ -644,17 +735,12 @@             -- 'stack test'. See:             -- https://github.com/commercialhaskell/stack/issues/805             case taskType of-                TTLocal lp -> concat-                    -- FIXME: make this work with exact-configuration.-                    -- Not sure how to plumb the info atm. See-                    -- https://github.com/commercialhaskell/stack/issues/2049-                    [ [ "--enable-tests"-                      | enableTest ||-                        (not useExactConf && depsPresent installedMap (lpTestDeps lp))]-                    , [ "--enable-benchmarks"-                      | enableBench ||-                        (not useExactConf && depsPresent installedMap (lpBenchDeps lp))]-                    ]+                TTLocal lp ->+                  -- FIXME: make this work with exact-configuration.+                  -- Not sure how to plumb the info atm. See+                  -- https://github.com/commercialhaskell/stack/issues/2049+                  [ "--enable-tests" | enableTest || (not useExactConf && depsPresent installedMap (lpTestDeps lp))] +++                  [ "--enable-benchmarks" | enableBench || (not useExactConf && depsPresent installedMap (lpBenchDeps lp))]                 _ -> []     idMap <- liftIO $ readTVarIO eeGhcPkgIds     let getMissing ident =@@ -674,7 +760,7 @@             , configCacheComponents =                 case taskType of                     TTLocal lp -> Set.map renderComponent $ lpComponents lp-                    TTUpstream _ _ _ -> Set.empty+                    TTUpstream{} -> Set.empty             , configCacheHaddock =                 shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides)             }@@ -682,7 +768,7 @@     return (allDepsMap, cache)  -- | Ensure that the configuration for the package matches what is given-ensureConfig :: M env m+ensureConfig :: (StackM env m, HasEnvConfig env)              => ConfigCache -- ^ newConfigCache              -> Path Abs Dir -- ^ package directory              -> ExecuteEnv@@ -743,7 +829,7 @@     , x     ] -withSingleContext :: M env m+withSingleContext :: (StackM env m, HasEnvConfig env)                   => (m () -> IO ())                   -> ActionContext                   -> ExecuteEnv@@ -764,7 +850,7 @@                   -> m a withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 =     withPackage $ \package cabalfp pkgDir ->-    withLogFile package $ \mlogFile ->+    withLogFile pkgDir package $ \mlogFile ->     withCabal package pkgDir mlogFile $ \cabal ->     inner0 package cabalfp pkgDir cabal announce console mlogFile   where@@ -773,7 +859,7 @@     wanted =         case taskType of             TTLocal lp -> lpWanted lp-            TTUpstream _ _ _ -> False+            TTUpstream{} -> False      console = wanted            && all (\(ActionId ident _) -> ident == taskProvides) (Set.toList acRemaining)@@ -795,12 +881,19 @@                             inner package cabalfp dir                     _ -> error $ "withPackage: invariant violated: " ++ show m -    withLogFile package inner+    withLogFile pkgDir package inner         | console = inner Nothing         | otherwise = do             logPath <- buildLogPath package msuffix             ensureDir (parent logPath)             let fp = toFilePath logPath++            -- We only want to dump logs for local non-dependency packages+            case taskType of+                TTLocal lp | lpWanted lp ->+                    liftIO $ atomically $ writeTChan eeLogFiles (pkgDir, logPath)+                _ -> return ()+             bracket                 (liftIO $ openBinaryFile fp WriteMode)                 (liftIO . hClose)@@ -828,7 +921,7 @@             -- https://github.com/commercialhaskell/stack/issues/370             case (packageSimpleType package, eeSetupExe) of                 (True, Just setupExe) -> return $ Left setupExe-                _ -> liftIO $ fmap Right $ getSetupHs pkgDir+                _ -> liftIO $ Right <$> getSetupHs pkgDir         inner $ \stripTHLoading args -> do             let cabalPackageArg                     -- Omit cabal package dependency when building@@ -940,7 +1033,11 @@                         , "-i", "-i."                         ] ++ packageArgs ++                         [ toFilePath setuphs+                        , toFilePath eeSetupShimHs+                        , "-main-is"+                        , "StackSetupShim.mainOverride"                         , "-o", toFilePath outputFile+                        , "-threaded"                         ] ++                         (case compiler of                             Ghc -> []@@ -948,7 +1045,7 @@                     return (outputFile, setupArgs)             runExe exeName $ (if boptsCabalVerbose eeBuildOpts then ("--verbose":) else id) fullArgs -singleBuild :: M env m+singleBuild :: (StackM env m, HasEnvConfig env)             => (m () -> IO ())             -> ActionContext             -> ExecuteEnv@@ -983,7 +1080,7 @@      annSuffix = if result == "" then "" else " (" <> result <> ")"       where-        result = T.intercalate " + " $ concat $+        result = T.intercalate " + " $ concat             [ ["lib" | taskAllInOne && hasLib]             , ["exe" | taskAllInOne && hasExe]             , ["test" | enableTests]@@ -1007,13 +1104,13 @@                     -- the snapshot.                     Just pc | maybe False                                     (bcoSnapInstallRoot eeBaseConfigOpts `isParentOf`)-                                    (parseAbsFile =<< (pcLibrary pc)) ->+                                    (parseAbsFile =<< pcLibrary pc) ->                         return Nothing                     -- If old precompiled cache files are left around but snapshots are deleted,                     -- it is possible for the precompiled file to refer to the very library                     -- we're building, and if flags are changed it may try to copy the library                     -- to itself. This check prevents that from happening.-                    Just pc | otherwise -> do+                    Just pc -> do                         let allM _ [] = return True                             allM f (x:xs) = do                                 b <- f x@@ -1048,7 +1145,7 @@                         , packageIdentifierString taskProvides                         ])                     (\ex -> case ex of-                        ReadProcessException{} -> return ()+                        ProcessFailed{} -> return ()                         _ -> throwM ex)                  readProcessNull Nothing menv' ghcPkgExe@@ -1083,10 +1180,27 @@         $ \package cabalfp pkgDir cabal announce _console _mlogFile -> do             _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix)) cabal cabalfp -            if boptsCLIOnlyConfigure eeBuildOptsCLI-                then return Nothing-                else liftM Just $ realBuild cache package pkgDir cabal announce+            case ( boptsCLIOnlyConfigure eeBuildOptsCLI+                 , boptsCLIInitialBuildSteps eeBuildOptsCLI && isTarget+                 , acDownstream) 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+                    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"]+     realBuild cache package pkgDir cabal announce = do         wc <- getWhichCompiler @@ -1095,25 +1209,38 @@             TTLocal lp -> do                 when enableTests $ unsetTestSuccess pkgDir                 writeBuildCache pkgDir $ lpNewBuildCache lp-            TTUpstream _ _ _ -> return ()+            TTUpstream{} -> return ()          -- FIXME: only output these if they're in the build plan.          preBuildTime <- modTime <$> liftIO getCurrentTime-        let postBuildCheck succeeded = do-                warnings <- checkForUnlistedFiles taskType preBuildTime pkgDir-                let hasUnlistedModule = any $ \case-                        UnlistedModulesWarning{} -> True-                        _ -> False-                when (not (null warnings)) $ $logInfo ""-                when (not succeeded && hasUnlistedModule warnings) $ do-                    $logInfo "If the above build failed with a linker error or .so/DLL error, addressing these may help:"-                mapM_ ($logWarn . ("Warning: " <>) . T.pack . show) warnings+        let postBuildCheck _succeeded = do+                mlocalWarnings <- case taskType of+                    TTLocal lp -> do+                        warnings <- checkForUnlistedFiles taskType preBuildTime pkgDir+                        return (Just (lpCabalFile lp, warnings))+                    _ -> return Nothing+                -- NOTE: once+                -- https://github.com/commercialhaskell/stack/issues/2649+                -- is resolved, we will want to partition the warnings+                -- based on variety, and output in different lists.+                let showModuleWarning (UnlistedModulesWarning mcomp modules) =+                      "- In" <+>+                      maybe "the library component" (\c -> fromString c <+> "component") mcomp <>+                      ":" <> line <>+                      indent 4 (mconcat $ intersperse line $ map (goodGreen . fromString . C.display) modules)+                forM_ mlocalWarnings $ \(cabalfp, warnings) -> do+                    unless (null warnings) $ $prettyWarn $+                        "The following modules should be added to exposed-modules or other-modules in" <+>+                        display cabalfp <> ":" <> line <>+                        indent 4 (mconcat $ map showModuleWarning warnings) <>+                        line <> line <>+                        "Missing modules in the cabal file are likely to cause undefined reference errors from the linker, along with other problems."          () <- announce ("build" <> annSuffix)         config <- asks getConfig-        extraOpts <- extraBuildOptions eeBuildOpts-        (cabal (configHideTHLoading config) $ ("build" :) $ (++ extraOpts) $+        extraOpts <- extraBuildOptions wc eeBuildOpts+        cabal (configHideTHLoading config) (("build" :) $ (++ extraOpts) $             case (taskType, taskAllInOne, isFinalBuild) of                 (_, True, True) -> fail "Invariant violated: cannot have an all-in-one build that also has a final build step."                 (TTLocal lp, False, False) -> primaryComponentOptions lp@@ -1142,7 +1269,7 @@                              "found on PATH (use 'stack install hscolour' to install).")                         return ["--hyperlink-source" | hscolourExists]             cabal False (concat [["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"]-                                ,sourceFlag])+                                ,sourceFlag, ["--internal" | boptsHaddockInternal eeBuildOpts]])          unless isFinalBuild $ withMVar eeInstallLock $ \() -> do             announce "copy/register"@@ -1191,7 +1318,7 @@             _ -> error "singleBuild: invariant violated: multiple results when describing installed package"  -- | Check if any unlisted files have been found, and add them to the build cache.-checkForUnlistedFiles :: M env m => TaskType -> ModTime -> Path Abs Dir -> m [PackageWarning]+checkForUnlistedFiles :: (StackM env m, HasEnvConfig env) => TaskType -> ModTime -> Path Abs Dir -> m [PackageWarning] checkForUnlistedFiles (TTLocal lp) preBuildTime pkgDir = do     (addBuildCache,warnings) <-         addUnlistedToBuildCache@@ -1203,7 +1330,7 @@         writeBuildCache pkgDir $         Map.unions (lpNewBuildCache lp : addBuildCache)     return warnings-checkForUnlistedFiles (TTUpstream _ _ _) _ _ = return []+checkForUnlistedFiles TTUpstream{} _ _ = return []  -- | Determine if all of the dependencies given are installed depsPresent :: InstalledMap -> Map PackageName VersionRange -> Bool@@ -1214,7 +1341,7 @@             Nothing -> False)     (Map.toList deps) -singleTest :: M env m+singleTest :: (StackM env m, HasEnvConfig env)            => (m () -> IO ())            -> TestOpts            -> [Text]@@ -1357,7 +1484,7 @@                 (fmap fst mlogFile)                 bs -singleBench :: M env m+singleBench :: (StackM env m, HasEnvConfig env)             => (m () -> IO ())             -> BenchmarkOpts             -> [Text]@@ -1393,7 +1520,7 @@                  -> ConduitM Text Text m () mungeBuildOutput excludeTHLoading makeAbsolute pkgDir = void $     CT.lines-    =$ CL.map stripCarriageReturn+    =$ CL.map stripCR     =$ CL.filter (not . isTHLoading)     =$ CL.mapM toAbsolutePath   where@@ -1429,10 +1556,6 @@            >> return ()         where num = some digit -    -- | Strip @\r@ characters from the byte vector. Used because Windows.-    stripCarriageReturn :: Text -> Text-    stripCarriageReturn = T.filter (/= '\r')- -- | Find the Setup.hs or Setup.lhs in the given directory. If none exists, -- throw an exception. getSetupHs :: Path Abs Dir -- ^ project directory@@ -1453,25 +1576,25 @@ -- Do not pass `-hpcdir` as GHC option if the coverage is not enabled. -- This helps running stack-compiled programs with dynamic interpreters like `hint`. -- Cfr: https://github.com/commercialhaskell/stack/issues/997-extraBuildOptions :: M env m => BuildOpts -> m [String]-extraBuildOptions bopts = do+extraBuildOptions :: (StackM env m, HasEnvConfig env) => WhichCompiler -> BuildOpts -> m [String]+extraBuildOptions wc bopts = do     let ddumpOpts = " -ddump-hi -ddump-to-file"-    case toCoverage (boptsTestOpts bopts) of-      True -> do+        optsFlag = compilerOptionsCabalFlag wc+    if toCoverage (boptsTestOpts bopts)+      then do         hpcIndexDir <- toFilePathNoTrailingSep <$> hpcRelativeDir-        return ["--ghc-options", "-hpcdir " ++ hpcIndexDir ++ ddumpOpts]-      False -> return ["--ghc-options", ddumpOpts]+        return [optsFlag, "-hpcdir " ++ hpcIndexDir ++ ddumpOpts]+      else+        return [optsFlag, ddumpOpts]  -- Library and executable build components. primaryComponentOptions :: LocalPackage -> [String]-primaryComponentOptions lp = concat-    [ ["lib:" ++ packageNameString (packageName (lpPackage lp))+primaryComponentOptions lp = ["lib:" ++ packageNameString (packageName (lpPackage lp))       -- TODO: get this information from target parsing instead,       -- which will allow users to turn off library building if       -- desired-      | packageHasLibrary (lpPackage lp)]-    , map (T.unpack . T.append "exe:") $ Set.toList $ exesToBuild lp-    ]+      | packageHasLibrary (lpPackage lp)] +++      map (T.unpack . T.append "exe:") (Set.toList $ exesToBuild lp)  exesToBuild :: LocalPackage -> Set Text exesToBuild lp = packageExes (lpPackage lp)
src/Stack/Build/Haddock.hs view
@@ -42,20 +42,22 @@ import           Path.IO import           Prelude import           Stack.PackageDump+import           Stack.PrettyPrint+import           Stack.Types.Build+import           Stack.Types.Compiler+import           Stack.Types.Config import           Stack.Types.GhcPkgId+import           Stack.Types.Package import           Stack.Types.PackageIdentifier import           Stack.Types.PackageName-import           Stack.Types.Config-import           Stack.Types.Build-import           Stack.Types.Package-import           Stack.Types.Compiler+import           Stack.Types.StackT (StackM) import qualified System.FilePath as FP import           System.IO.Error (isDoesNotExistError) import           System.Process.Read import           Web.Browser (openBrowser)  openHaddocksInBrowser-    :: (MonadIO m, MonadThrow m, MonadLogger m)+    :: StackM env m     => BaseConfigOpts     -> Map PackageName (PackageIdentifier, InstallLocation)     -- ^ Available packages and their locations for the current project@@ -94,7 +96,7 @@                             ", but that file is missing.  Opening doc index instead."                         getDocIndex             _ -> getDocIndex-    $logInfo ("Opening " <> T.pack (toFilePath docFile) <> " in the browser.")+    $prettyInfo $ "Opening" <+> display docFile <+> "in the browser."     _ <- liftIO $ openBrowser (toFilePath docFile)     return ()
src/Stack/Build/Installed.hs view
@@ -12,12 +12,10 @@     ) where  import           Control.Applicative+import           Control.Arrow import           Control.Monad-import           Control.Monad.Catch (MonadMask)-import           Control.Monad.IO.Class import           Control.Monad.Logger-import           Control.Monad.Reader (MonadReader, asks)-import           Control.Monad.Trans.Resource+import           Control.Monad.Reader (asks) import           Data.Conduit import qualified Data.Conduit.List as CL import qualified Data.Foldable as F@@ -31,7 +29,6 @@ import           Data.Maybe.Extra (mapMaybeM) import           Data.Monoid import qualified Data.Text as T-import           Network.HTTP.Client.Conduit (HasHttpManager) import           Path import           Prelude hiding (FilePath, writeFile) import           Stack.Build.Cache@@ -42,15 +39,13 @@ import           Stack.Types.Compiler import           Stack.Types.Config import           Stack.Types.GhcPkgId-import           Stack.Types.Internal import           Stack.Types.Package import           Stack.Types.PackageDump import           Stack.Types.PackageIdentifier import           Stack.Types.PackageName+import           Stack.Types.StackT import           Stack.Types.Version -type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasEnvConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env)- -- | Options for 'getInstalled'. data GetInstalledOpts = GetInstalledOpts     { getInstalledProfiling :: !Bool@@ -60,7 +55,7 @@     }  -- | Returns the new InstalledMap and all of the locally registered packages.-getInstalled :: (M env m, PackageInstallInfo pii)+getInstalled :: (StackM env m, HasEnvConfig env, PackageInstallInfo pii)              => EnvOverride              -> GetInstalledOpts              -> Map PackageName pii -- ^ does not contain any installed information@@ -86,9 +81,9 @@      (installedLibs0, globalDumpPkgs) <- loadDatabase' Nothing []     (installedLibs1, _extraInstalled) <--      (foldM (\lhs' pkgdb ->+      foldM (\lhs' pkgdb ->         loadDatabase' (Just (ExtraGlobal, pkgdb)) (fst lhs')-        ) (installedLibs0, globalDumpPkgs) extraDBPaths)+        ) (installedLibs0, globalDumpPkgs) extraDBPaths     (installedLibs2, snapshotDumpPkgs) <-         loadDatabase' (Just (InstalledTo Snap, snapDBPath)) installedLibs1     (installedLibs3, localDumpPkgs) <-@@ -130,7 +125,7 @@ -- The goal is to ascertain that the dependencies for a package are present, -- that it has profiling if necessary, and that it matches the version and -- location needed by the SourceMap-loadDatabase :: (M env m, PackageInstallInfo pii)+loadDatabase :: (StackM env m, HasEnvConfig env, PackageInstallInfo pii)              => EnvOverride              -> GetInstalledOpts              -> Maybe InstalledCache -- ^ if Just, profiling or haddock is required@@ -167,7 +162,7 @@     mloc = fmap fst mdb     sinkDP = conduitProfilingCache           =$ conduitHaddockCache-          =$ CL.map (\dp -> (isAllowed opts mcache sourceMap mloc dp, toLoadHelper mloc dp))+          =$ CL.map (isAllowed opts mcache sourceMap mloc &&& toLoadHelper mloc)           =$ CL.consume     sink = getZipSink $ (,)         <$> ZipSink sinkDP
src/Stack/Build/Source.hs view
@@ -6,9 +6,11 @@ {-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE TupleSections         #-} {-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE ConstraintKinds #-} -- Load information on package sources module Stack.Build.Source     ( loadSourceMap+    , loadSourceMapFull     , SourceMap     , PackageSource (..)     , getLocalFlags@@ -25,7 +27,6 @@ import              Control.Arrow ((&&&)) import              Control.Exception (assert, catch) import              Control.Monad hiding (sequence)-import              Control.Monad.Catch (MonadMask) import              Control.Monad.IO.Class import              Control.Monad.Logger import              Control.Monad.Reader (MonadReader, asks)@@ -54,38 +55,53 @@ import              Distribution.Package (pkgName, pkgVersion) import              Distribution.PackageDescription (GenericPackageDescription, package, packageDescription) import qualified    Distribution.PackageDescription as C-import              Network.HTTP.Client.Conduit (HasHttpManager) import              Path import              Path.IO import              Prelude hiding (sequence) import              Stack.Build.Cache import              Stack.Build.Target import              Stack.BuildPlan (shadowMiniBuildPlan)+import              Stack.Config (getLocalPackages) import              Stack.Constants (wiredInPackages) import              Stack.Package import              Stack.PackageIndex (getPackageVersions)+import              Stack.Types.Build import              Stack.Types.BuildPlan+import              Stack.Types.Config import              Stack.Types.FlagName+import              Stack.Types.Package import              Stack.Types.PackageName+import              Stack.Types.Resolver+import              Stack.Types.StackT import              Stack.Types.Version-import              Stack.Types.Config-import              Stack.Types.Build-import              Stack.Types.Package import qualified    System.Directory as D import              System.FilePath (takeFileName) import              System.IO (withBinaryFile, IOMode (ReadMode)) import              System.IO.Error (isDoesNotExistError) -loadSourceMap :: (MonadIO m, MonadMask m, MonadReader env m, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env)+-- | Like 'loadSourceMapFull', but doesn't return values that aren't as+-- commonly needed.+loadSourceMap :: (StackM env m, HasEnvConfig env)               => NeedTargets               -> BuildOptsCLI-              -> m ( Map PackageName SimpleTarget-                   , MiniBuildPlan-                   , [LocalPackage]-                   , Set PackageName -- non-local targets+              -> m ( [LocalPackage]                    , SourceMap                    ) loadSourceMap needTargets boptsCli = do+    (_, _, locals, _, _, sourceMap) <- loadSourceMapFull needTargets boptsCli+    return (locals, sourceMap)++loadSourceMapFull :: (StackM env m, HasEnvConfig env)+                  => NeedTargets+                  -> BuildOptsCLI+                  -> m ( Map PackageName SimpleTarget+                       , MiniBuildPlan+                       , [LocalPackage]+                       , Set PackageName -- non-local targets+                       , Map PackageName Version -- extra-deps from configuration and cli+                       , SourceMap+                       )+loadSourceMapFull needTargets boptsCli = do     bconfig <- asks getBuildConfig     rawLocals <- getLocalPackageViews     (mbp0, cliExtraDeps, targets) <- parseTargetsFromBuildOptsWith rawLocals needTargets boptsCli@@ -159,7 +175,7 @@                  in PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi) (mpiGhcOptions mpi ++ configOpts) (mpiGitSHA1 mpi)             ] `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages)) -    return (targets, mbp, locals, nonLocalTargets, sourceMap)+    return (targets, mbp, locals, nonLocalTargets, extraDeps0, sourceMap)  -- | All flags for a local package getLocalFlags@@ -179,7 +195,7 @@ getGhcOptions bconfig boptsCli name isTarget isLocal = concat     [ ghcOptionsFor name (configGhcOptions config)     , concat [["-fhpc"] | isLocal && toCoverage (boptsTestOpts bopts)]-    , if (boptsLibProfile bopts || boptsExeProfile bopts)+    , if boptsLibProfile bopts || boptsExeProfile bopts          then ["-auto-all","-caf-all"]          else []     , if includeExtraOptions@@ -200,7 +216,7 @@ -- If the local packages views are already known, use 'parseTargetsFromBuildOptsWith' -- instead. parseTargetsFromBuildOpts-    :: (MonadIO m, MonadMask m, MonadReader env m, MonadLogger m, HasEnvConfig env)+    :: (StackM env m, HasEnvConfig env)     => NeedTargets     -> BuildOptsCLI     -> m (MiniBuildPlan, M.Map PackageName Version, M.Map PackageName SimpleTarget)@@ -209,7 +225,7 @@     parseTargetsFromBuildOptsWith rawLocals needTargets boptscli  parseTargetsFromBuildOptsWith-    :: (MonadIO m, MonadMask m, MonadReader env m, MonadLogger m, HasEnvConfig env)+    :: (StackM env m, HasEnvConfig env)     => Map PackageName (LocalPackageView, GenericPackageDescription)        -- ^ Local package views     -> NeedTargets@@ -276,12 +292,12 @@                 go (Map.insert flag version extra) flags  -- | Parse out the local package views for the current project-getLocalPackageViews :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m)+getLocalPackageViews :: (StackM env m, HasEnvConfig env)                      => m (Map PackageName (LocalPackageView, GenericPackageDescription)) getLocalPackageViews = do     $logDebug "Parsing the cabal files of the local packages"-    econfig <- asks getEnvConfig-    locals <- forM (Map.toList $ envConfigPackages econfig) $ \(dir, treatLikeExtraDep) -> do+    packages <- getLocalPackages+    locals <- forM (Map.toList packages) $ \(dir, treatLikeExtraDep) -> do         cabalfp <- findOrGenerateCabalFile dir         (warnings,gpkg) <- readPackageUnresolved cabalfp         mapM_ (printCabalFileWarning cabalfp) warnings@@ -334,8 +350,7 @@ -- | Upgrade the initial local package info to a full-blown @LocalPackage@ -- based on the selected components loadLocalPackage-    :: forall m env.-       (MonadReader env m, HasEnvConfig env, MonadMask m, MonadLogger m, MonadIO m, MonadBaseControl IO m)+    :: forall m env. (StackM env m, HasEnvConfig env)     => BuildOptsCLI     -> Map PackageName SimpleTarget     -> (PackageName, (LocalPackageView, GenericPackageDescription))@@ -351,10 +366,10 @@                 Just (STLocalComps comps) -> splitComponents $ Set.toList comps                 Just STLocalAll ->                     ( packageExes pkg-                    , if boptsTests bopts+                    , if boptsTests bopts && not (lpvExtraDep lpv)                         then Map.keysSet (packageTests pkg)                         else Set.empty-                    , if boptsBenchmarks bopts+                    , if boptsBenchmarks bopts && not (lpvExtraDep lpv)                         then packageBenchmarks pkg                         else Set.empty                     )@@ -410,6 +425,14 @@         , lpCabalFile = lpvCabalFP lpv         , lpDir = lpvRoot lpv         , lpWanted = isJust mtarget+                  -- A local package marked as extra-dep should never+                  -- be treated as a target. Perhaps we should be+                  -- fixing this upstream of this function, not+                  -- certain, but this works for now. If in the future+                  -- we decide to move the extra-dep checking logic+                  -- upstream, this lpvExtraDep check should be+                  -- changed to an assertion.+                  && not (lpvExtraDep lpv)         , lpComponents = toComponents exes tests benches         -- TODO: refactor this so that it's easier to be sure that these         -- components are indeed unbuildable.@@ -474,7 +497,7 @@ -- this was then superseded by -- https://github.com/commercialhaskell/stack/issues/651 extendExtraDeps-    :: (HasBuildConfig env, MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m, MonadMask m)+    :: (StackM env m, HasBuildConfig env)     => Map PackageName Version -- ^ original extra deps     -> Map PackageName Version -- ^ package identifiers from the command line     -> Set PackageName -- ^ all packages added on the command line@@ -543,7 +566,7 @@  -- | Returns entries to add to the build cache for any newly found unlisted modules addUnlistedToBuildCache-    :: (MonadIO m, MonadReader env m, MonadMask m, MonadLogger m, HasEnvConfig env)+    :: (StackM env m, HasEnvConfig env)     => ModTime     -> Package     -> Path Abs File@@ -570,7 +593,7 @@  -- | Gets list of Paths for files in a package getPackageFilesSimple-    :: (MonadIO m, MonadReader env m, MonadMask m, MonadLogger m, HasEnvConfig env)+    :: (StackM env m, HasEnvConfig env)     => Package -> Path Abs File -> m (Set (Path Abs File), [PackageWarning]) getPackageFilesSimple pkg cabalFP = do     (_,compFiles,cabalFiles,warnings) <-
src/Stack/BuildPlan.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds    #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric      #-} {-# LANGUAGE EmptyDataDecls     #-}@@ -39,10 +40,9 @@ import           Control.Monad.Catch import           Control.Monad.IO.Class import           Control.Monad.Logger-import           Control.Monad.Reader (asks)+import           Control.Monad.Reader (MonadReader, asks) import           Control.Monad.State.Strict      (State, execState, get, modify,                                                   put)-import           Control.Monad.Trans.Control (MonadBaseControl) import qualified Crypto.Hash.SHA256 as SHA256 import           Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings) import           Data.Store.VersionTagged@@ -66,7 +66,7 @@ import           Data.Text.Encoding (encodeUtf8) import qualified Data.Traversable as Tr import           Data.Typeable (Typeable)-import           Data.Yaml.Extra (decodeEither', decodeFileEither)+import           Data.Yaml (decodeEither', decodeFileEither) import qualified Distribution.Package as C import           Distribution.PackageDescription (GenericPackageDescription,                                                   flagDefault, flagManual,@@ -93,6 +93,7 @@ import           Stack.Types.Config import           Stack.Types.Urls import           Stack.Types.Compiler+import           Stack.Types.Resolver import           Stack.Types.StackT  data BuildPlanException@@ -165,10 +166,7 @@                 , ["Note: further dependencies may need to be added"]                 ]           where-            go (dep, users) | Set.null users = concat-                [ packageNameString dep-                , " (internal stack error: this should never be null)"-                ]+            go (dep, users) | Set.null users = packageNameString dep ++ " (internal stack error: this should never be null)"             go (dep, users) = concat                 [ packageNameString dep                 , " (used by "@@ -198,13 +196,14 @@ -- This function will not provide test suite and benchmark dependencies. -- -- This may fail if a target package is not present in the @BuildPlan@.-resolveBuildPlan :: (MonadThrow m, MonadIO m, MonadReader env m, HasBuildConfig env, MonadLogger m, HasHttpManager env, MonadBaseControl IO m,MonadCatch m)-                 => MiniBuildPlan-                 -> (PackageName -> Bool) -- ^ is it shadowed by a local package?-                 -> Map PackageName (Set PackageName) -- ^ required packages, and users of it-                 -> m ( Map PackageName (Version, Map FlagName Bool)-                      , Map PackageName (Set PackageName)-                      )+resolveBuildPlan+    :: (StackMiniM env m, HasBuildConfig env)+    => MiniBuildPlan+    -> (PackageName -> Bool) -- ^ is it shadowed by a local package?+    -> Map PackageName (Set PackageName) -- ^ required packages, and users of it+    -> m ( Map PackageName (Version, Map FlagName Bool)+         , Map PackageName (Set PackageName)+         ) resolveBuildPlan mbp isShadowed packages     | Map.null (rsUnknown rs) && Map.null (rsShadowed rs) = return (rsToInstall rs, rsUsedBy rs)     | otherwise = do@@ -231,11 +230,12 @@     , rsUsedBy    :: Map PackageName (Set PackageName)     } -toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadMask m, HasConfig env, MonadBaseControl IO m)-                => CompilerVersion -- ^ Compiler version-                -> Map PackageName Version -- ^ cores-                -> Map PackageName (Version, Map FlagName Bool, [Text], Maybe GitSHA1) -- ^ non-core packages-                -> m MiniBuildPlan+toMiniBuildPlan+    :: (StackMiniM env m, HasConfig env)+    => CompilerVersion -- ^ Compiler version+    -> Map PackageName Version -- ^ cores+    -> Map PackageName (Version, Map FlagName Bool, [Text], Maybe GitSHA1) -- ^ non-core packages+    -> m MiniBuildPlan toMiniBuildPlan compilerVersion corePackages packages = do     -- Determine the dependencies of all of the packages in the build plan. We     -- handle core packages specially, because some of them will not be in the@@ -272,11 +272,12 @@         }  -- | Add in the resolved dependencies from the package index-addDeps :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadMask m, HasConfig env, MonadBaseControl IO m)-        => Bool -- ^ allow missing-        -> CompilerVersion -- ^ Compiler version-        -> Map PackageName (Version, Map FlagName Bool, [Text], Maybe GitSHA1)-        -> m (Map PackageName MiniPackageInfo, Set PackageIdentifier)+addDeps+    :: (StackMiniM env m, HasConfig env)+    => Bool -- ^ allow missing+    -> CompilerVersion -- ^ Compiler version+    -> Map PackageName (Version, Map FlagName Bool, [Text], Maybe GitSHA1)+    -> m (Map PackageName MiniPackageInfo, Set PackageIdentifier) addDeps allowMissing compilerVersion toCalc = do     menv <- getMinimalEnvOverride     platform <- asks $ configPlatform . getConfig@@ -423,7 +424,7 @@       $ mpiExes mpi  loadResolver-    :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadMask m)+    :: (StackMiniM env m, HasConfig env, HasGHCVariant env)     => Maybe (Path Abs File)     -> Resolver     -> m (MiniBuildPlan, LoadedResolver)@@ -447,9 +448,8 @@  -- | Load up a 'MiniBuildPlan', preferably from cache loadMiniBuildPlan-    :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadMask m)-    => SnapName-    -> m MiniBuildPlan+    :: (StackMiniM env m, HasConfig env, HasGHCVariant env)+    => SnapName -> m MiniBuildPlan loadMiniBuildPlan name = do     path <- configMiniBuildPlanCache name     $(versionedDecodeOrLoad miniBuildPlanVC) path $ liftM buildPlanFixes $ do@@ -457,7 +457,7 @@         toMiniBuildPlan             (siCompilerVersion $ bpSystemInfo bp)             (siCorePackages $ bpSystemInfo bp)-            (fmap goPP $ bpPackages bp)+            (goPP <$> bpPackages bp)   where     goPP pp =         ( ppVersion pp@@ -488,12 +488,9 @@  -- | Load the 'BuildPlan' for the given snapshot. Will load from a local copy -- if available, otherwise downloading from Github.-loadBuildPlan :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env)-              => SnapName-              -> m BuildPlan+loadBuildPlan :: (StackMiniM env m, HasConfig env) => SnapName -> m BuildPlan loadBuildPlan name = do-    env <- ask-    let stackage = getStackRoot env+    stackage <- asks getStackRoot     file' <- parseRelFile $ T.unpack file     let fp = buildPlanDir stackage </> file'     $logDebug $ "Decoding build plan from: " <> T.pack (toFilePath fp)@@ -638,10 +635,11 @@ -- | Checks if the given package dependencies can be satisfied by the given set -- of packages. Will fail if a package is either missing or has a version -- outside of the version range.-checkPackageDeps :: PackageName -- ^ package using dependencies, for constructing DepErrors-          -> Map PackageName VersionRange -- ^ dependency constraints-          -> Map PackageName Version -- ^ Available package pool or index-          -> DepErrors+checkPackageDeps+    :: PackageName -- ^ package using dependencies, for constructing DepErrors+    -> Map PackageName VersionRange -- ^ dependency constraints+    -> Map PackageName Version -- ^ Available package pool or index+    -> DepErrors checkPackageDeps myName deps packages =     Map.unionsWith combineDepError $ map go $ Map.toList deps   where@@ -691,7 +689,7 @@             selectPackageBuildPlan platform compiler pool' gpd         pkgPlan (Just f) gpd =             checkPackageBuildPlan platform compiler pool' (flags' f gpd) gpd-        flags' f gpd = maybe Map.empty id (Map.lookup (gpdPackageName gpd) f)+        flags' f gpd = fromMaybe Map.empty (Map.lookup (gpdPackageName gpd) f)         pool' = Map.union (gpdPackages gpds) pool          dupError _ _ = error "Bug: Duplicate packages are not expected here"@@ -725,9 +723,7 @@ -- given snapshot. Returns how well the snapshot satisfies the dependencies of -- the packages. checkSnapBuildPlan-    :: ( MonadIO m, MonadMask m, MonadLogger m, MonadReader env m-       , HasHttpManager env, HasConfig env, HasGHCVariant env-       , MonadBaseControl IO m)+    :: (StackM env m, HasConfig env, HasGHCVariant env)     => [GenericPackageDescription]     -> Maybe (Map PackageName (Map FlagName Bool))     -> SnapName@@ -738,7 +734,7 @@      let         compiler = mbpCompilerVersion mbp-        snapPkgs = fmap mpiVersion $ mbpPackages mbp+        snapPkgs = mpiVersion <$> mbpPackages mbp         (f, errs) = checkBundleBuildPlan platform compiler snapPkgs flags gpds         cerrs = compilerErrors compiler errs @@ -760,9 +756,7 @@ -- | Find a snapshot and set of flags that is compatible with and matches as -- best as possible with the given 'GenericPackageDescription's. selectBestSnapshot-    :: ( MonadIO m, MonadMask m, MonadLogger m, MonadReader env m-       , HasHttpManager env, HasConfig env, HasGHCVariant env-       , MonadBaseControl IO m)+    :: (StackM env m, HasConfig env, HasGHCVariant env)     => [GenericPackageDescription]     -> NonEmpty SnapName     -> m (SnapName, BuildPlanCheck)@@ -812,7 +806,7 @@  showPackageFlags :: PackageName -> Map FlagName Bool -> Text showPackageFlags pkg fl =-    if (not $ Map.null fl) then+    if not $ Map.null fl then         T.concat             [ "    - "             , T.pack $ packageNameString pkg@@ -823,7 +817,7 @@             ]     else ""     where-        formatFlags (f, v) = (show f) ++ " = " ++ (show v)+        formatFlags (f, v) = show f ++ " = " ++ show v  showMapPackages :: Map PackageName a -> Text showMapPackages mp = showItems $ Map.keys mp@@ -846,7 +840,7 @@     T.concat         [ T.concat $ map formatError (Map.toList errs)         , if T.null flagVals then ""-          else ("Using package flags:\n" <> flagVals)+          else "Using package flags:\n" <> flagVals         ]     where         formatError (depName, DepError mversion neededBy) = T.concat@@ -884,7 +878,7 @@ shadowMiniBuildPlan (MiniBuildPlan cv pkgs0) shadowed =     (MiniBuildPlan cv (Map.fromList met), Map.fromList unmet)   where-    pkgs1 = Map.difference pkgs0 $ Map.fromSet (\_ -> ()) shadowed+    pkgs1 = Map.difference pkgs0 $ Map.fromSet (const ()) shadowed      depsMet = flip execState Map.empty $ mapM_ (check Set.empty) (Map.keys pkgs1) @@ -957,7 +951,7 @@ -- TODO: Allow custom plan to specify a name.  parseCustomMiniBuildPlan-    :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m)+    :: (StackMiniM env m, HasConfig env, HasGHCVariant env)     => Maybe (Path Abs File) -- ^ Root directory for when url is a filepath     -> T.Text     -> m (MiniBuildPlan, SnapshotHash)@@ -1075,7 +1069,7 @@     doHash = SnapshotHash . B64URL.encode . SHA256.hash  applyCustomSnapshot-    :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m, MonadMask m)+    :: (StackMiniM env m, HasConfig env)     => CustomSnapshot     -> MiniBuildPlan     -> m MiniBuildPlan@@ -1100,9 +1094,9 @@         packageMap = Map.fromList $ map addFlagsAndOpts $ Set.toList packages         cv = fromMaybe (mbpCompilerVersion mbp0) mcompilerVersion         packages0 =-             mbpPackages mbp0 `Map.difference` (Map.fromSet (\_ -> ()) dropPackages)+             mbpPackages mbp0 `Map.difference` Map.fromSet (const ()) dropPackages     mbp1 <- toMiniBuildPlan cv mempty packageMap-    return $ MiniBuildPlan+    return MiniBuildPlan         { mbpCompilerVersion = cv         , mbpPackages = Map.union (mbpPackages mbp1) packages0         }
src/Stack/Clean.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}  -- | Clean a project. module Stack.Clean@@ -8,10 +10,7 @@     ) where  import           Control.Exception (Exception)-import           Control.Monad.Catch (MonadCatch, MonadThrow, throwM)-import           Control.Monad.IO.Class (MonadIO)-import           Control.Monad.Logger (MonadLogger)-import           Control.Monad.Reader (MonadReader, asks)+import           Control.Monad.Catch (throwM) import           Data.Foldable (forM_) import           Data.List ((\\),intercalate) import qualified Data.Map.Strict as Map@@ -21,15 +20,17 @@ import           Path.IO (ignoringAbsence, removeDirRecur) import           Stack.Build.Source (getLocalPackageViews) import           Stack.Build.Target (LocalPackageView(..))+import           Stack.Config (getLocalPackages) import           Stack.Constants (distDirFromDir, workDirFromDir) import           Stack.Types.PackageName import           Stack.Types.Config+import           Stack.Types.StackT  -- | Deletes build artifacts in the current project. -- -- Throws 'StackCleanException'. clean-    :: (MonadCatch m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m)+    :: (StackM env m, HasEnvConfig env)     => CleanOpts     -> m () clean cleanOpts = do@@ -37,11 +38,12 @@     forM_ dirs (ignoringAbsence . removeDirRecur)  dirsToDelete-    :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m)+    :: (StackM env m, HasEnvConfig env)     => CleanOpts     -> m [Path Abs Dir] dirsToDelete cleanOpts = do-    localPkgDirs <- asks (Map.keys . envConfigPackages . getEnvConfig)+    packages <- getLocalPackages+    let localPkgDirs = Map.keys packages     case cleanOpts of         CleanShallow [] -> do             mapM distDirFromDir localPkgDirs
src/Stack/Config.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -27,12 +28,16 @@   ,loadConfigMaybeProject   ,loadMiniConfig   ,packagesParser+  ,getLocalPackages   ,resolvePackageEntry   ,getImplicitGlobalProjectDir+  ,getStackYaml   ,getSnapshots   ,makeConcreteResolver   ,checkOwnership   ,getInContainer+  ,getInNixShell+  ,defaultConfigYaml   ) where  import qualified Codec.Archive.Tar as Tar@@ -42,32 +47,32 @@ import           Control.Arrow ((***)) import           Control.Exception (assert) import           Control.Monad (liftM, unless, when, filterM)-import           Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask, catchAll, throwM, catch, handle)+import           Control.Monad.Catch (MonadThrow, MonadCatch, catchAll, throwM, catch) import           Control.Monad.Extra (firstJustM) import           Control.Monad.IO.Class import           Control.Monad.Logger hiding (Loc)-import           Control.Monad.Reader (MonadReader, ask, asks, runReaderT)-import           Control.Monad.Trans.Control (MonadBaseControl)+import           Control.Monad.Reader (ask, asks, runReaderT) import qualified Crypto.Hash.SHA256 as SHA256 import           Data.Aeson.Extended import qualified Data.ByteString as S import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.ByteString.Lazy as L import           Data.Foldable (forM_)-import           Data.IORef (newIORef)+import           Data.IORef import qualified Data.IntMap as IntMap import qualified Data.Map as Map import           Data.Maybe import           Data.Monoid.Extra import qualified Data.Text as T import           Data.Text.Encoding (encodeUtf8, decodeUtf8)-import qualified Data.Yaml.Extra as Yaml+import qualified Data.Yaml as Yaml import           Distribution.System (OS (..), Platform (..), buildPlatform) import qualified Distribution.Text import           Distribution.Version (simplifyVersionRange) import           GHC.Conc (getNumProcessors)-import           Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager, parseUrlThrow)-import           Network.HTTP.Download (download, downloadJSON)+import           Network.HTTP.Client (parseUrlThrow)+import           Network.HTTP.Download (download)+import           Network.HTTP.Simple (httpJSON, getResponseBody) import           Options.Applicative (Parser, strOption, long, help) import           Path import           Path.Extra (toFilePathNoTrailingSep)@@ -81,11 +86,14 @@ import           Stack.Config.Urls import           Stack.Constants import qualified Stack.Image as Image-import           Stack.Types.Config import           Stack.Types.BuildPlan-import           Stack.Types.Docker import           Stack.Types.Compiler+import           Stack.Types.Config+import           Stack.Types.Docker import           Stack.Types.Internal+import           Stack.Types.Nix+import           Stack.Types.Resolver+import           Stack.Types.StackT import           Stack.Types.Urls import           Stack.Types.Version import           System.Environment@@ -140,21 +148,34 @@   where     stackRoot = configStackRoot config +-- | This is slightly more expensive than @'asks' ('bcStackYaml' '.' 'getBuildConfig')@+-- and should only be used when no 'BuildConfig' is at hand.+getStackYaml+    :: (StackMiniM env m, HasConfig env)+    => m (Path Abs File)+getStackYaml = do+    config <- asks getConfig+    case configMaybeProject config of+        Just (_project, stackYaml) -> return stackYaml+        Nothing -> liftM (</> stackDotYaml) (getImplicitGlobalProjectDir config)+ -- | Download the 'Snapshots' value from stackage.org.-getSnapshots :: (MonadThrow m, MonadMask m, MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m)-             => m Snapshots+getSnapshots+    :: (StackMiniM env m, HasConfig env)+    => m Snapshots getSnapshots = do     latestUrlText <- askLatestSnapshotUrl     latestUrl <- parseUrlThrow (T.unpack latestUrlText)     $logDebug $ "Downloading snapshot versions file from " <> latestUrlText-    result <- downloadJSON latestUrl+    result <- httpJSON latestUrl     $logDebug $ "Done downloading and parsing snapshot versions file"-    return result+    return $ getResponseBody result  -- | Turn an 'AbstractResolver' into a 'Resolver'.-makeConcreteResolver :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadMask m, HasHttpManager env, MonadLogger m)-                     => AbstractResolver-                     -> m Resolver+makeConcreteResolver+    :: (StackMiniM env m, HasConfig env)+    => AbstractResolver+    -> m Resolver makeConcreteResolver (ARResolver r) = return r makeConcreteResolver ar = do     snapshots <- getSnapshots@@ -183,9 +204,7 @@     return r  -- | Get the latest snapshot resolver available.-getLatestResolver-    :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m)-    => m Resolver+getLatestResolver :: (StackMiniM env m, HasConfig env) => m Resolver getLatestResolver = do     snapshots <- getSnapshots     let mlts = do@@ -226,8 +245,7 @@             configMonoidPackageIndices           configGHCVariant0 = getFirst configMonoidGHCVariant--         configSystemGHC = fromFirst (isNothing configGHCVariant0) configMonoidSystemGHC+         configGHCBuild = getFirst configMonoidGHCBuild          configInstallGHC = fromFirst False configMonoidInstallGHC          configSkipGHCCheck = fromFirst False configMonoidSkipGHCCheck          configSkipMsys = fromFirst False configMonoidSkipMsys@@ -240,7 +258,7 @@          -- in the future, allow it to be configured.          (Platform defArch defOS) = buildPlatform          arch = fromMaybe defArch-              $ (getFirst configMonoidArch) >>= Distribution.Text.simpleParse+              $ getFirst configMonoidArch >>= Distribution.Text.simpleParse          os = defOS          configPlatform = Platform arch os @@ -258,21 +276,29 @@          dockerOptsFromMonoid (fmap fst mproject) configStackRoot mresolver configMonoidDockerOpts      configNix <- nixOptsFromMonoid configMonoidNixOpts os +     configSystemGHC <-+         case (getFirst configMonoidSystemGHC, nixEnable configNix) of+             (Just False, True) ->+                 throwM NixRequiresSystemGhc+             _ ->+                 return+                     (fromFirst+                         (dockerEnable configDocker || nixEnable configNix)+                         configMonoidSystemGHC)++     when (isJust configGHCVariant0 && configSystemGHC) $+         throwM ManualGHCVariantSettingsAreIncompatibleWithSystemGHC+      rawEnv <- liftIO getEnvironment      pathsEnv <- augmentPathMap configMonoidExtraPath                                 (Map.fromList (map (T.pack *** T.pack) rawEnv))      origEnv <- mkEnvOverride configPlatform pathsEnv      let configEnvOverride _ = return origEnv -     platformOnlyDir <- runReaderT platformOnlyRelDir (configPlatform,configPlatformVariant)-     configLocalProgramsBase <--         case configPlatform of-             Platform _ Windows -> do-                 progsDir <- getWindowsProgsDir configStackRoot origEnv-                 return $ progsDir </> $(mkRelDir stackProgName)-             _ ->-                 return $-                 configStackRoot </> $(mkRelDir "programs")+     configLocalProgramsBase <- case getFirst configMonoidLocalProgramsBase of+       Nothing -> getDefaultLocalProgramsBase configStackRoot configPlatform origEnv+       Just path -> return path+     platformOnlyDir <- runReaderT platformOnlyRelDir (configPlatform, configPlatformVariant)      let configLocalPrograms = configLocalProgramsBase </> platformOnlyDir       configLocalBin <-@@ -309,6 +335,7 @@          configApplyGhcOptions = fromFirst AGOLocals configMonoidApplyGhcOptions          configAllowNewer = fromFirst False configMonoidAllowNewer          configDefaultTemplate = getFirst configMonoidDefaultTemplate+         configDumpLogs = fromFirst DumpWarningLogs configMonoidDumpLogs       configAllowDifferentUser <-         case getFirst configMonoidAllowDifferentUser of@@ -321,43 +348,50 @@       return Config {..} --- | Get the directory on Windows where we should install extra programs. For--- more information, see discussion at:--- https://github.com/fpco/minghc/issues/43#issuecomment-99737383-getWindowsProgsDir :: MonadThrow m-                   => Path Abs Dir-                   -> EnvOverride-                   -> m (Path Abs Dir)-getWindowsProgsDir stackRoot m =-    case Map.lookup "LOCALAPPDATA" $ unEnvOverride m of-        Just t -> do+-- | Get the default location of the local programs directory.+getDefaultLocalProgramsBase :: MonadThrow m+                            => Path Abs Dir+                            -> Platform+                            -> EnvOverride+                            -> m (Path Abs Dir)+getDefaultLocalProgramsBase configStackRoot configPlatform override =+  let+    defaultBase = configStackRoot </> $(mkRelDir "programs")+  in+    case configPlatform of+      -- For historical reasons, on Windows a subdirectory of LOCALAPPDATA is+      -- used instead of a subdirectory of STACK_ROOT. Unifying the defaults would+      -- mean that Windows users would manually have to move data from the old+      -- 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")-        Nothing -> return $ stackRoot </> $(mkRelDir "Programs")+            return $ lad </> $(mkRelDir "Programs") </> $(mkRelDir stackProgName)+          Nothing -> return defaultBase+      _ -> return defaultBase  -- | An environment with a subset of BuildConfig used for setup.-data MiniConfig = MiniConfig Manager GHCVariant Config+data MiniConfig = MiniConfig GHCVariant Config instance HasConfig MiniConfig where-    getConfig (MiniConfig _ _ c) = c+    getConfig (MiniConfig _ c) = c instance HasStackRoot MiniConfig-instance HasHttpManager MiniConfig where-    getHttpManager (MiniConfig man _ _) = man instance HasPlatform MiniConfig instance HasGHCVariant MiniConfig where-    getGHCVariant (MiniConfig _ v _) = v+    getGHCVariant (MiniConfig v _) = v  -- | Load the 'MiniConfig'. loadMiniConfig-    :: (MonadIO m)-    => Manager -> Config -> m MiniConfig-loadMiniConfig manager config = do+    :: MonadIO m+    => Config -> m MiniConfig+loadMiniConfig config = do     let ghcVariant = fromMaybe GHCStandard (configGHCVariant0 config)-    return (MiniConfig manager ghcVariant config)+    return (MiniConfig ghcVariant config)  -- Load the configuration, using environment variables, and defaults as -- necessary. loadConfigMaybeProject-    :: (MonadLogger m,MonadIO m,MonadMask m,MonadBaseControl IO m,MonadReader env m,HasHttpManager env,HasTerminal env)+    :: StackM env m     => ConfigMonoid     -- ^ Config monoid from parsed command-line arguments     -> Maybe AbstractResolver@@ -399,7 +433,7 @@ -- | Load the configuration, using current directory, environment variables, -- and defaults as necessary. The passed @Maybe (Path Abs File)@ is an -- override for the location of the project's stack.yaml.-loadConfig :: (MonadLogger m,MonadIO m,MonadMask m,MonadBaseControl IO m,MonadReader env m,HasHttpManager env,HasTerminal env)+loadConfig :: StackM env m            => ConfigMonoid            -- ^ Config monoid from parsed command-line arguments            -> Maybe AbstractResolver@@ -412,7 +446,7 @@  -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@. -- values.-loadBuildConfig :: (MonadLogger m, MonadIO m, MonadMask m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m, HasTerminal env)+loadBuildConfig :: StackM env m                 => Maybe (Project, Path Abs File, ConfigMonoid)                 -> Config                 -> Maybe AbstractResolver -- override resolver@@ -420,15 +454,14 @@                 -> m BuildConfig loadBuildConfig mproject config mresolver mcompiler = do     env <- ask-    manager <- getHttpManager <$> ask-    miniConfig <- loadMiniConfig manager config+    miniConfig <- loadMiniConfig config      (project', stackYamlFP) <- case mproject of       Just (project, fp, _) -> do           forM_ (projectUserMsg project) ($logWarn . T.pack)           return (project, fp)       Nothing -> do-            $logInfo "Run from outside a project, using implicit global project config"+            $logDebug "Run from outside a project, using implicit global project config"             destDir <- getImplicitGlobalProjectDir config             let dest :: Path Abs File                 dest = destDir </> stackDotYaml@@ -442,7 +475,7 @@                    when (getTerminal env) $                        case mresolver of                            Nothing ->-                               $logInfo ("Using resolver: " <> resolverName (projectResolver project) <>+                               $logDebug ("Using resolver: " <> resolverName (projectResolver project) <>                                          " from implicit global project's config file: " <> T.pack dest')                            Just aresolver -> do                                let name =@@ -452,12 +485,19 @@                                             ARLatestLTS -> "lts"                                             ARLatestLTSMajor x -> T.pack $ "lts-" ++ show x                                             ARGlobal -> "global"-                               $logInfo ("Using resolver: " <> name <>+                               $logDebug ("Using resolver: " <> name <>                                          " specified on command line")                    return (project, dest)                else do-                   r <- runReaderT getLatestResolver miniConfig-                   $logInfo ("Using latest snapshot resolver: " <> resolverName r)+                   r <- case mresolver of+                       Just aresolver -> do+                           r' <- runReaderT (makeConcreteResolver aresolver) miniConfig+                           $logInfo ("Using resolver: " <> resolverName r' <> " specified on command line")+                           return r'+                       Nothing -> do+                           r'' <- runReaderT getLatestResolver miniConfig+                           $logInfo ("Using latest snapshot resolver: " <> resolverName r'')+                           return r''                    $logInfo ("Writing implicit global project config file to: " <> T.pack dest')                    $logInfo "Note: You can change the snapshot via the resolver field there."                    let p = Project@@ -515,11 +555,27 @@         , bcGHCVariant = getGHCVariant miniConfig         } +-- | Get packages from EnvConfig, downloading and cloning as necessary.+-- If the packages have already been downloaded, this uses a cached value (+getLocalPackages+    :: (StackMiniM env m, HasEnvConfig env)+    => m (Map.Map (Path Abs Dir) TreatLikeExtraDep)+getLocalPackages = do+    cacheRef <- asks (envConfigPackagesRef . getEnvConfig)+    mcached <- liftIO $ readIORef cacheRef+    case mcached of+        Just cached -> return cached+        Nothing -> do+            menv <- getMinimalEnvOverride+            bconfig <- asks getBuildConfig+            liftM (Map.fromList . concat) $ mapM+                (resolvePackageEntry menv (bcRoot bconfig))+                (bcPackageEntries bconfig)+ -- | Resolve a PackageEntry into a list of paths, downloading and cloning as -- necessary. resolvePackageEntry-    :: (MonadIO m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m-       ,MonadBaseControl IO m, HasConfig env)+    :: (StackMiniM env m, HasConfig env)     => EnvOverride     -> Path Abs Dir -- ^ project root     -> PackageEntry@@ -530,28 +586,43 @@         case peSubdirs pe of             [] -> return [entryRoot]             subs -> mapM (resolveDir entryRoot) subs-    return $ map (, peExtraDep pe) paths+    extraDep <-+        case peExtraDepMaybe pe of+            Just e -> return e+            Nothing ->+                case peLocation pe of+                    PLFilePath _ ->+                        -- we don't give a warning on missing explicit+                        -- value here, user intent is almost always+                        -- the default for a local directory+                        return False+                    PLRemote url _ -> do+                        $logWarn $ mconcat+                            [ "No extra-dep setting found for package at URL:\n\n"+                            , url+                            , "\n\n"+                            , "This is usually a mistake, external packages "+                            , "should typically\nbe treated as extra-deps to avoid "+                            , "spurious test case failures."+                            ]+                        return False+    return $ map (, extraDep) paths  -- | Resolve a PackageLocation into a path, downloading and cloning as -- necessary. resolvePackageLocation-    :: (MonadIO m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m-       ,MonadBaseControl IO m, HasConfig env)+    :: (StackMiniM env m, HasConfig env)     => EnvOverride     -> Path Abs Dir -- ^ project root     -> PackageLocation     -> m (Path Abs Dir) resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do-    -- NOTE: we used to include the commit in the package location. This-    -- allowed us to quickly check if the dir exists, and use it if it-    -- does. Now, we instead always do a reset. This is still pretty-    -- fast - a no-op git reset is around 0.01 seconds on my machine.     workDir <- getWorkDir     let nameBeforeHashing = case remotePackageType of             RPTHttp{} -> url-            RPTGit{} -> url-            RPTHg{} -> T.unwords [url, "hg"]+            RPTGit commit -> T.unwords [url, commit]+            RPTHg commit -> T.unwords [url, commit, "hg"]         -- TODO: dedupe with code for snapshot hash?         name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ SHA256.hash $ encodeUtf8 nameBeforeHashing         root = projRoot </> workDir </> $(mkRelDir "downloaded")@@ -566,46 +637,34 @@         dir = root </> dirRel      exists <- doesDirExist dir-    let cloneAndExtract commandName cloneArgs resetCommand commit = do-            ensureDir (parent dir)-            if exists-                then handleError (doReset True)-                else do-                    doClone-                    doReset False-            return dir-          where-            handleError = handle $ \case-                ReadProcessException{} -> do-                    $logInfo $ "Failed to reset to commit " <> commit <> ", deleting and re-cloning."-                    ignoringAbsence (removeDirRecur dir)-                    doClone-                    doReset False-                err -> throwM err-            doClone =+    unless exists $ do+        ignoringAbsence (removeDirRecur dir)++        let cloneAndExtract commandName cloneArgs resetCommand commit = do+                ensureDir root                 callProcessInheritStderrStdout Cmd-                    { cmdDirectoryToRunIn = Just (parent dir)+                    { cmdDirectoryToRunIn = Just root                     , cmdCommandToRun = commandName                     , cmdEnvOverride = menv                     , cmdCommandLineArguments =-                        ("clone" :+                        "clone" :                         cloneArgs ++                         [ T.unpack url                         , toFilePathNoTrailingSep dir-                        ])+                        ]                     }-            doReset firstTry =+                created <- doesDirExist dir+                unless created $ throwM $ FailedToCloneRepo commandName                 readProcessNull (Just dir) menv commandName                     (resetCommand ++ [T.unpack commit, "--"])                     `catch` \case-                        ex@ReadProcessException{} -> do-                            unless firstTry $ $logInfo $-                                "Please ensure that commit " <> commit <> " exists within " <> url+                        ex@ProcessFailed{} -> do+                            $logInfo $ "Please ensure that commit " <> commit <> " exists within " <> url                             throwM ex                         ex -> throwM ex-    case remotePackageType of-        RPTHttp -> do-            unless exists $ do++        case remotePackageType of+            RPTHttp -> do                 let dirTmp = root </> dirRelTmp                 ignoringAbsence (removeDirRecur dirTmp) @@ -633,6 +692,15 @@                  tryTar `catchAllLog` tryZip `catchAllLog` err                 renameDir dirTmp dir++            -- Passes in --git-dir to git and --repository to hg, in order+            -- to avoid the update commands being applied to the user's+            -- repo.  See https://github.com/commercialhaskell/stack/issues/2748+            RPTGit commit -> cloneAndExtract "git" ["--recursive"] ["--git-dir=.git", "reset", "--hard"] commit+            RPTHg  commit -> cloneAndExtract "hg"  []              ["--repository", ".", "update", "-C"] commit++    case remotePackageType of+        RPTHttp -> do             x <- listDir dir             case x of                 ([dir'], []) -> return dir'@@ -640,9 +708,8 @@                     ignoringAbsence (removeFile file)                     ignoringAbsence (removeDirRecur dir)                     throwM $ UnexpectedArchiveContents dirs files+        _ -> return dir -        RPTGit commit -> cloneAndExtract "git" ["--recursive"] ["reset", "--hard"] commit-        RPTHg  commit -> cloneAndExtract "hg"  []              ["update", "-C"]    commit  -- | Get the stack root, e.g. @~/.stack@, and determine whether the user owns it. --@@ -727,6 +794,10 @@ getInContainer :: (MonadIO m) => m Bool getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar) +-- | 'True' if we are currently running inside a Nix.+getInNixShell :: (MonadIO m) => m Bool+getInNixShell = liftIO (isJust <$> lookupEnv inNixShellEnvVar)+ -- | Determine the extra config file locations which exist. -- -- Returns most local first@@ -850,13 +921,26 @@         (defaultUserConfigPathDeprecated stackRoot)     unless exists $ do         ensureDir (parent path)-        liftIO $ S.writeFile (toFilePath path) $ S.concat-            [ "# This file contains default non-project-specific settings for 'stack', used\n"-            , "# in all projects.  For more information about stack's configuration, see\n"-            , "# http://docs.haskellstack.org/en/stable/yaml_configuration/\n"-            , "#\n"-            , Yaml.encode (mempty :: Object) ]+        liftIO $ S.writeFile (toFilePath path) defaultConfigYaml     return path  packagesParser :: Parser [String] packagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))++defaultConfigYaml :: S.ByteString+defaultConfigYaml = S.intercalate "\n"+     [ "# This file contains default non-project-specific settings for 'stack', used"+     , "# in all projects.  For more information about stack's configuration, see"+     , "# http://docs.haskellstack.org/en/stable/yaml_configuration/"+     , ""+     , "# The following parameters are used by \"stack new\" to automatically fill fields"+     , "# in the cabal config. We recommend uncommenting them and filling them out if"+     , "# you intend to use 'stack new'."+     , "# See https://docs.haskellstack.org/en/stable/yaml_configuration/#templates"+     , "templates:"+     , "  params:"+     , "#    author-name:"+     , "#    author-email:"+     , "#    copyright:"+     , "#    github-username:"+     ]
src/Stack/Config/Build.hs view
@@ -23,6 +23,9 @@           (boptsOpenHaddocks defaultBuildOpts)           buildMonoidOpenHaddocks     , boptsHaddockDeps = getFirst buildMonoidHaddockDeps+    , boptsHaddockInternal = fromFirst+          (boptsHaddockInternal defaultBuildOpts)+          buildMonoidHaddockInternal     , boptsInstallExes = fromFirst           (boptsInstallExes defaultBuildOpts)           buildMonoidInstallExes
src/Stack/Config/Docker.hs view
@@ -3,19 +3,20 @@ -- | Docker configuration module Stack.Config.Docker where -import Control.Exception.Lifted-import Control.Monad.Catch (MonadThrow)-import Data.List (find)-import Data.Maybe-import Data.Monoid.Extra+import           Control.Exception.Lifted+import           Control.Monad.Catch (MonadThrow)+import           Data.List (find)+import           Data.Maybe+import           Data.Monoid.Extra import qualified Data.Text as T-import Data.Typeable (Typeable)-import Distribution.Version (simplifyVersionRange)-import Path-import Stack.Types.BuildPlan-import Stack.Types.Version-import Stack.Types.Config-import Stack.Types.Docker+import           Data.Typeable (Typeable)+import           Distribution.Version (simplifyVersionRange)+import           Path+import           Stack.Types.BuildPlan+import           Stack.Types.Version+import           Stack.Types.Config+import           Stack.Types.Docker+import           Stack.Types.Resolver  -- | Interprets DockerOptsMonoid options. dockerOptsFromMonoid@@ -102,5 +103,4 @@             , "\nUse an LTS resolver, or set the '"             , T.unpack dockerImageArgName             , "' explicitly, in your configuration file."]-    show (InvalidDatabasePathException ex) =-        concat ["Invalid database path: ", show ex]+    show (InvalidDatabasePathException ex) = "Invalid database path: " ++ show ex
src/Stack/Config/Nix.hs view
@@ -36,6 +36,7 @@         nixInitFile = getFirst nixMonoidInitFile         nixShellOptions = fromFirst [] nixMonoidShellOptions                           ++ prefixAll (T.pack "-I") (fromFirst [] nixMonoidPath)+        nixAddGCRoots   = fromFirst False nixMonoidAddGCRoots     when (not (null nixPackages) && isJust nixInitFile) $        throwM NixCannotUseShellFileAndPackagesException     return NixOpts{..}
src/Stack/Config/Urls.hs view
@@ -13,7 +13,7 @@         (fromFirst defaultNightlyBuildPlans $ urlsMonoidNightlyBuildPlans monoid)     where     defaultLatestSnapshot =-        "https://www.stackage.org/download/snapshots.json"+        "https://s3.amazonaws.com/haddock.stackage.org/snapshots.json"     defaultLtsBuildPlans =         "https://raw.githubusercontent.com/fpco/lts-haskell/master/"     defaultNightlyBuildPlans =
src/Stack/ConfigCmd.hs view
@@ -1,68 +1,154 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}---- | Make changes to the stack yaml file+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs #-} +-- | Make changes to project or global configuration. module Stack.ConfigCmd        (ConfigCmdSet(..)+       ,configCmdSetParser        ,cfgCmdSet        ,cfgCmdSetName        ,cfgCmdName) where -import           Control.Monad.Catch (MonadMask, throwM)+import           Control.Applicative+import           Control.Monad+import           Control.Monad.Catch (throwM) import           Control.Monad.IO.Class import           Control.Monad.Logger-import           Control.Monad.Reader (MonadReader, asks)-import           Control.Monad.Trans.Control (MonadBaseControl)+import           Control.Monad.Reader (asks) import qualified Data.ByteString as S import qualified Data.HashMap.Strict as HMap-import qualified Data.Yaml.Extra as Yaml-import           Network.HTTP.Client.Conduit (HasHttpManager)+import           Data.Monoid+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Yaml as Yaml+import qualified Options.Applicative as OA+import qualified Options.Applicative.Types as OA import           Path+import           Prelude -- Silence redundant import warnings import           Stack.BuildPlan-import           Stack.Config (makeConcreteResolver)-import           Stack.Types.BuildPlan+import           Stack.Config (makeConcreteResolver, getStackYaml) import           Stack.Types.Config+import           Stack.Types.Resolver -data ConfigCmdSet = ConfigCmdSetResolver AbstractResolver+data ConfigCmdSet+    = ConfigCmdSetResolver AbstractResolver+    | ConfigCmdSetSystemGhc CommandScope+                            Bool+    | ConfigCmdSetInstallGhc CommandScope+                             Bool -cfgCmdSet :: ( MonadIO m-             , MonadBaseControl IO m-             , MonadMask m-             , MonadReader env m-             , HasBuildConfig env-             , HasHttpManager env-             , HasGHCVariant env-             , MonadLogger m)-             => ConfigCmdSet -> m ()-cfgCmdSet (ConfigCmdSetResolver newResolver) = do-    stackYaml <- fmap bcStackYaml (asks getBuildConfig)-    let stackYamlFp =-            toFilePath stackYaml+data CommandScope+    = CommandScopeGlobal+      -- ^ Apply changes to the global configuration,+      --   typically at @~/.stack/config.yaml@.+    | CommandScopeProject+      -- ^ Apply changes to the project @stack.yaml@.++configCmdSetScope :: ConfigCmdSet -> CommandScope+configCmdSetScope (ConfigCmdSetResolver _) = CommandScopeProject+configCmdSetScope (ConfigCmdSetSystemGhc scope _) = scope+configCmdSetScope (ConfigCmdSetInstallGhc scope _) = scope++cfgCmdSet+    :: (StackMiniM env m, HasConfig env, HasGHCVariant env)+    => ConfigCmdSet -> m ()+cfgCmdSet cmd = do+    configFilePath <-+        liftM+            toFilePath+            (case configCmdSetScope cmd of+                 CommandScopeProject -> getStackYaml+                 CommandScopeGlobal -> asks (configUserConfigPath . getConfig))     -- We don't need to worry about checking for a valid yaml here-    (projectYamlConfig :: Yaml.Object) <--        liftIO (Yaml.decodeFileEither stackYamlFp) >>=-        either throwM return-    -- TODO: custom snapshot support?-    newResolverText <- fmap resolverName (makeConcreteResolver newResolver)-    -- We checking here that the snapshot actually exists-    snap <- parseSnapName newResolverText-    _ <- loadMiniBuildPlan snap+    (config :: Yaml.Object) <-+        liftIO (Yaml.decodeFileEither configFilePath) >>= either throwM return+    newValue <- cfgCmdSetValue cmd+    let cmdKey = cfgCmdSetOptionName cmd+        config' = HMap.insert cmdKey newValue config+    if config' == config+        then $logInfo+                 (T.pack configFilePath <>+                  " already contained the intended configuration and remains unchanged.")+        else do+            liftIO (S.writeFile configFilePath (Yaml.encode config'))+            $logInfo (T.pack configFilePath <> " has been updated.") -    let projectYamlConfig' =-            HMap.insert-                "resolver"-                (Yaml.String newResolverText)-                projectYamlConfig-    liftIO-        (S.writeFile-             stackYamlFp-             (Yaml.encode projectYamlConfig'))-    return ()+cfgCmdSetValue+    :: (StackMiniM env m, HasConfig env, HasGHCVariant env)+    => ConfigCmdSet -> m Yaml.Value+cfgCmdSetValue (ConfigCmdSetResolver newResolver) = do+    concreteResolver <- makeConcreteResolver newResolver+    case concreteResolver of+        -- Check that the snapshot actually exists+        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"+    return (Yaml.String (resolverName concreteResolver))+cfgCmdSetValue (ConfigCmdSetSystemGhc _ bool) =+    return (Yaml.Bool bool)+cfgCmdSetValue (ConfigCmdSetInstallGhc _ bool) =+    return (Yaml.Bool bool) +cfgCmdSetOptionName :: ConfigCmdSet -> Text+cfgCmdSetOptionName (ConfigCmdSetResolver _) = "resolver"+cfgCmdSetOptionName (ConfigCmdSetSystemGhc _ _) = configMonoidSystemGHCName+cfgCmdSetOptionName (ConfigCmdSetInstallGhc _ _) = configMonoidInstallGHCName+ cfgCmdName :: String cfgCmdName = "config"  cfgCmdSetName :: String cfgCmdSetName = "set"++configCmdSetParser :: OA.Parser ConfigCmdSet+configCmdSetParser =+    OA.hsubparser $+    mconcat+        [ OA.command+              "resolver"+              (OA.info+                   (ConfigCmdSetResolver <$>+                    OA.argument+                        readAbstractResolver+                        (OA.metavar "RESOLVER" <>+                         OA.help "E.g. \"nightly\" or \"lts-7.2\""))+                   (OA.progDesc+                        "Change the resolver of the current project. See https://docs.haskellstack.org/en/stable/yaml_configuration/#resolver for more info."))+        , OA.command+              (T.unpack configMonoidSystemGHCName)+              (OA.info+                   (ConfigCmdSetSystemGhc <$> scopeFlag <*> boolArgument)+                   (OA.progDesc+                        "Configure whether stack should use a system GHC installation or not."))+        , OA.command+              (T.unpack configMonoidInstallGHCName)+              (OA.info+                   (ConfigCmdSetInstallGhc <$> scopeFlag <*> boolArgument)+                   (OA.progDesc+                        "Configure whether stack should automatically install GHC when necessary."))+        ]++scopeFlag :: OA.Parser CommandScope+scopeFlag =+    OA.flag+        CommandScopeProject+        CommandScopeGlobal+        (OA.long "global" <>+         OA.help+             "Modify the global configuration (typically at \"~/.stack/config.yaml\") instead of the project stack.yaml.")++readBool :: OA.ReadM Bool+readBool = do+    s <- OA.readerAsk+    case s of+        "true" -> return True+        "false" -> return False+        _ -> OA.readerError ("Invalid value " ++ show s ++ ": Expected \"true\" or \"false\"")++boolArgument :: OA.Parser Bool+boolArgument = OA.argument readBool (OA.metavar "true/false")
src/Stack/Constants.hs view
@@ -16,6 +16,7 @@     ,stackRootOptionName     ,deprecatedStackRootOptionName     ,inContainerEnvVar+    ,inNixShellEnvVar     ,configCacheFile     ,configCabalMod     ,buildCacheFile@@ -37,6 +38,7 @@     ,defaultGlobalConfigPathDeprecated     ,defaultGlobalConfigPath     ,platformVariantEnvVar+    ,compilerOptionsCabalFlag     )     where @@ -220,6 +222,12 @@ inContainerEnvVar :: String inContainerEnvVar = stackProgNameUpper ++ "_IN_CONTAINER" +-- | Environment variable used to indicate stack is running in container.+-- although we already have STACK_IN_NIX_EXTRA_ARGS that is set in the same conditions,+-- it can happen that STACK_IN_NIX_EXTRA_ARGS is set to empty.+inNixShellEnvVar :: String+inNixShellEnvVar = map toUpper stackProgName ++ "_IN_NIXSHELL"+ -- See https://downloads.haskell.org/~ghc/7.10.1/docs/html/libraries/ghc/src/Module.html#integerPackageKey wiredInPackages :: HashSet PackageName wiredInPackages =@@ -334,3 +342,9 @@ -- names.  Used to ensure incompatible binaries aren't shared between Docker builds and host platformVariantEnvVar :: String platformVariantEnvVar = stackProgNameUpper ++ "_PLATFORM_VARIANT"++-- | Provides --ghc-options for 'Ghc', and similarly, --ghcjs-options+-- for 'Ghcjs'.+compilerOptionsCabalFlag :: WhichCompiler -> String+compilerOptionsCabalFlag Ghc = "--ghc-options"+compilerOptionsCabalFlag Ghcjs = "--ghcjs-options"
src/Stack/Coverage.hs view
@@ -16,14 +16,12 @@     , generateHpcMarkupIndex     ) where -import           Control.Applicative-import           Control.Exception.Enclosed (handleIO)+import           Control.Exception.Safe (handleIO) import           Control.Exception.Lifted import           Control.Monad (liftM, when, unless, void, (<=<))-import           Control.Monad.Catch (MonadMask) import           Control.Monad.IO.Class import           Control.Monad.Logger-import           Control.Monad.Reader (MonadReader, asks)+import           Control.Monad.Reader (asks) import           Control.Monad.Trans.Resource import qualified Data.ByteString.Char8 as S8 import           Data.Foldable (forM_, asum, toList)@@ -33,6 +31,7 @@ import           Data.Maybe import           Data.Maybe.Extra (mapMaybeM) import           Data.Monoid ((<>))+import           Data.String import           Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -45,21 +44,25 @@ import           Prelude hiding (FilePath, writeFile) import           Stack.Build.Source (parseTargetsFromBuildOpts) import           Stack.Build.Target+import           Stack.Config (getLocalPackages) import           Stack.Constants import           Stack.Package+import           Stack.PrettyPrint+import           Stack.Types.Compiler+import           Stack.Types.Config+import           Stack.Types.Package import           Stack.Types.PackageIdentifier import           Stack.Types.PackageName+import           Stack.Types.StackT (StackM) import           Stack.Types.Version-import           Stack.Types.Config-import           Stack.Types.Package-import           Stack.Types.Compiler import           System.FilePath (isPathSeparator) import           System.Process.Read import           Text.Hastache (htmlEscape) import           Trace.Hpc.Tix+import           Web.Browser (openBrowser)  -- | Invoked at the beginning of running with "--coverage"-deleteHpcReports :: (MonadIO m, MonadMask m, MonadReader env m, HasEnvConfig env)+deleteHpcReports :: (StackM env m, HasEnvConfig env)                  => m () deleteHpcReports = do     hpcDir <- hpcReportDir@@ -67,8 +70,8 @@  -- | Move a tix file into a sub-directory of the hpc report directory. Deletes the old one if one is -- present.-updateTixFile :: (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env)-            => PackageName -> Path Abs File -> String -> m ()+updateTixFile :: (StackM env m, HasEnvConfig env)+              => PackageName -> Path Abs File -> String -> m () updateTixFile pkgName tixSrc testName = do     exists <- doesFileExist tixSrc     when exists $ do@@ -89,7 +92,7 @@                 ignoringAbsence (removeFile tixSrc)  -- | Get the directory used for hpc reports for the given pkgId.-hpcPkgPath :: (MonadIO m,MonadReader env m,MonadMask m,HasEnvConfig env)+hpcPkgPath :: (StackM env m, HasEnvConfig env)             => PackageName -> m (Path Abs Dir) hpcPkgPath pkgName = do     outputDir <- hpcReportDir@@ -98,7 +101,7 @@  -- | Get the tix file location, given the name of the file (without extension), and the package -- identifier string.-tixFilePath :: (MonadIO m,MonadReader env m,MonadMask m,HasEnvConfig env)+tixFilePath :: (StackM env m, HasEnvConfig env)             => PackageName -> String ->  m (Path Abs File) tixFilePath pkgName testName = do     pkgPath <- hpcPkgPath pkgName@@ -106,7 +109,7 @@     return (pkgPath </> tixRel)  -- | Generates the HTML coverage report and shows a textual coverage summary for a package.-generateHpcReport :: (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env)+generateHpcReport :: (StackM env m, HasEnvConfig env)                   => Path Abs Dir -> Package -> [Text] -> m () generateHpcReport pkgDir package tests = do     compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig)@@ -144,30 +147,34 @@                 let extraArgs = case mincludeName of                         Just includeName -> ["--include", includeName ++ ":"]                         Nothing -> []-                generateHpcReportInternal tixSrc reportDir report extraArgs extraArgs+                mreportPath <- generateHpcReportInternal tixSrc reportDir report extraArgs extraArgs+                forM_ mreportPath (displayReportPath report) -generateHpcReportInternal :: (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env)-                          => Path Abs File -> Path Abs Dir -> Text -> [String] -> [String] -> m ()+generateHpcReportInternal :: (StackM env m, HasEnvConfig env)+                          => Path Abs File -> Path Abs Dir -> Text -> [String] -> [String] -> m (Maybe (Path Abs File)) generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArgs = do     -- If a .tix file exists, move it to the HPC output directory and generate a report for it.     tixFileExists <- doesFileExist tixSrc     if not tixFileExists-        then $logError $ T.concat-            [ "Didn't find .tix for "-            , report-            , " - expected to find it at "-            , T.pack (toFilePath tixSrc)-            , "."-            ]+        then do+            $logError $ T.concat+                 [ "Didn't find .tix for "+                 , report+                 , " - expected to find it at "+                 , T.pack (toFilePath tixSrc)+                 , "."+                 ]+            return Nothing         else (`catch` \err -> do                  let msg = show (err :: ReadProcessException)                  $logError (T.pack msg)-                 generateHpcErrorReport reportDir $ sanitize msg) $+                 generateHpcErrorReport reportDir $ sanitize msg+                 return Nothing) $              (`onException` $logError ("Error occurred while producing " <> report)) $ do             -- Directories for .mix files.             hpcRelDir <- hpcRelativeDir             -- Compute arguments used for both "hpc markup" and "hpc report".-            pkgDirs <- Map.keys . envConfigPackages <$> asks getEnvConfig+            pkgDirs <- liftM Map.keys getLocalPackages             let args =                     -- Use index files from all packages (allows cross-package coverage results).                     concatMap (\x -> ["--srcdir", toFilePathNoTrailingSep x]) pkgDirs ++@@ -197,12 +204,11 @@                             ]                     $logError (msg False)                     generateHpcErrorReport reportDir (msg True)+                    return Nothing                 else do+                    let reportPath = reportDir </> $(mkRelFile "hpc_index.html")                     -- Print output, stripping @\r@ characters because Windows.                     forM_ outputLines ($logInfo . T.decodeUtf8)-                    $logInfo-                        ("The " <> report <> " is available at " <>-                         T.pack (toFilePath (reportDir </> $(mkRelFile "hpc_index.html"))))                     -- Generate the markup.                     void $ readProcessStdout Nothing menv "hpc"                         ( "markup"@@ -210,21 +216,22 @@                         : ("--destdir=" ++ toFilePathNoTrailingSep reportDir)                         : (args ++ extraMarkupArgs)                         )-+                    return (Just reportPath)  data HpcReportOpts = HpcReportOpts     { hroptsInputs :: [Text]     , hroptsAll :: Bool     , hroptsDestDir :: Maybe String+    , hroptsOpenBrowser :: Bool     } deriving (Show) -generateHpcReportForTargets :: (MonadIO m, MonadReader env m, MonadBaseControl IO m, MonadMask m, MonadLogger m, HasEnvConfig env)+generateHpcReportForTargets :: (StackM env m, HasEnvConfig env)                             => HpcReportOpts -> m () generateHpcReportForTargets opts = do     let (tixFiles, targetNames) = partition (".tix" `T.isSuffixOf`) (hroptsInputs opts)     targetTixFiles <--         -- When there aren't any package component arguments, then-         -- don't default to all package components.+         -- When there aren't any package component arguments, and --all+         -- isn't passed, default to not considering any targets.          if not (hroptsAll opts) && null targetNames          then return []          else do@@ -247,7 +254,7 @@                          forM (toList comps) $ \nc ->                              case nc of                                  CTest testName ->-                                     liftM (pkgPath </>) $ parseRelFile (T.unpack testName ++ ".tix")+                                     liftM (pkgPath </>) $ parseRelFile (T.unpack testName ++ "/" ++ T.unpack testName ++ ".tix")                                  _ -> fail $                                      "Can't specify anything except test-suites as hpc report targets (" ++                                      packageNameString name ++@@ -257,32 +264,44 @@                          exists <- doesDirExist pkgPath                          if exists                              then do-                                 (_, files) <- listDir pkgPath-                                 return (filter ((".tix" `isSuffixOf`) . toFilePath) files)+                                 (dirs, _) <- listDir pkgPath+                                 liftM concat $ forM dirs $ \dir -> do+                                     (_, files) <- listDir dir+                                     return (filter ((".tix" `isSuffixOf`) . toFilePath) files)                              else return []-    tixPaths <- liftM (++ targetTixFiles) $ mapM (resolveFile' . T.unpack) tixFiles+    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."+    outputDir <- hpcReportDir     reportDir <- case hroptsDestDir opts of-        Nothing -> liftM (</> $(mkRelDir "combined/custom")) hpcReportDir+        Nothing -> return (outputDir </> $(mkRelDir "combined/custom"))         Just destDir -> do             dest <- resolveDir' destDir             ensureDir dest             return dest-    generateUnionReport "combined report" reportDir tixPaths+    let report = "combined report"+    mreportPath <- generateUnionReport report reportDir tixPaths+    forM_ mreportPath $ \reportPath ->+        if hroptsOpenBrowser opts+            then do+                $prettyInfo $ "Opening" <+> display reportPath <+> "in the browser."+                void $ liftIO $ openBrowser (toFilePath reportPath)+            else displayReportPath report reportPath -generateHpcUnifiedReport :: (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env)+generateHpcUnifiedReport :: (StackM env m, HasEnvConfig env)                          => m () generateHpcUnifiedReport = do     outputDir <- hpcReportDir     ensureDir outputDir     (dirs, _) <- listDir outputDir-    tixFiles <- liftM (concat . concat) $ forM (filter (("combined" /=) . dirnameString) dirs) $ \dir -> do+    tixFiles0 <- liftM (concat . concat) $ forM (filter (("combined" /=) . dirnameString) dirs) $ \dir -> do         (dirs', _) <- listDir dir         forM dirs' $ \dir' -> do             (_, files) <- listDir dir'             return (filter ((".tix" `isSuffixOf`) . toFilePath) files)-    let reportDir = outputDir </> $(mkRelDir "combined/all")+    extraTixFiles <- findExtraTixFiles+    let tixFiles = tixFiles0  ++ extraTixFiles+        reportDir = outputDir </> $(mkRelDir "combined/all")     if length tixFiles < 2         then $logInfo $ T.concat             [ if null tixFiles then "No tix files" else "Only one tix file"@@ -290,10 +309,13 @@             , T.pack (toFilePath outputDir)             , ", so not generating a unified coverage report."             ]-        else generateUnionReport "unified report" reportDir tixFiles+        else do+            let report = "unified report"+            mreportPath <- generateUnionReport report reportDir tixFiles+            forM_ mreportPath (displayReportPath report) -generateUnionReport :: (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env)-                    => Text -> Path Abs Dir -> [Path Abs File] -> m ()+generateUnionReport :: (StackM env m, HasEnvConfig env)+                    => Text -> Path Abs Dir -> [Path Abs File] -> m (Maybe (Path Abs File)) generateUnionReport report reportDir tixFiles = do     (errs, tix) <- fmap (unionTixes . map removeExeModules) (mapMaybeM readTixOrLog tixFiles)     $logDebug $ "Using the following tix files: " <> T.pack (show tixFiles)@@ -329,7 +351,7 @@         | hash1 == hash2 && len1 == len2 = Right (TixModule k hash1 len1 (zipWith (+) tix1 tix2))     merge _ _ = Left () -generateHpcMarkupIndex :: (MonadIO m,MonadReader env m,MonadLogger m,MonadMask m,HasEnvConfig env)+generateHpcMarkupIndex :: (StackM env m, HasEnvConfig env)                        => m () generateHpcMarkupIndex = do     outputDir <- hpcReportDir@@ -404,7 +426,9 @@ dirnameString :: Path r Dir -> String dirnameString = dropWhileEnd isPathSeparator . toFilePath . dirname -findPackageFieldForBuiltPackage :: (MonadIO m,MonadBaseControl IO m,MonadReader env m,MonadThrow m,MonadLogger m,HasEnvConfig env) => Path Abs Dir -> PackageIdentifier -> Text -> m (Either Text Text)+findPackageFieldForBuiltPackage+    :: (StackM env m, HasEnvConfig env)+    => Path Abs Dir -> PackageIdentifier -> Text -> m (Either Text Text) findPackageFieldForBuiltPackage pkgDir pkgId field = do     distDir <- distDirFromDir pkgDir     let inplaceDir = distDir </> $(mkRelDir "package.conf.inplace")@@ -433,3 +457,19 @@                 [path] -> extractField path                 _ -> return $ Left $ "Multiple files matching " <> T.pack (pkgIdStr ++ "-*.conf") <> " found in " <>                     T.pack (toFilePath inplaceDir) <> ". Maybe try 'stack clean' on this package?"++displayReportPath :: (StackM env m, HasAnsiAnn (Ann a), Display a)+                  => Text -> a -> m ()+displayReportPath report reportPath =+     $prettyInfo $ "The" <+> fromString (T.unpack report) <+> "is available at" <+> display reportPath++findExtraTixFiles :: (StackM env m , HasEnvConfig env) => m [Path Abs File]+findExtraTixFiles = do+    outputDir <- hpcReportDir+    let dir = outputDir </> $(mkRelDir "extra-tix-files")+    dirExists <- doesDirExist dir+    if dirExists+        then do+            (_, files) <- listDir dir+            return $ filter ((".tix" `isSuffixOf`) . toFilePath) files+        else return []
src/Stack/Docker.hs view
@@ -24,12 +24,11 @@ import           Control.Concurrent.MVar.Lifted (MVar,modifyMVar_,newMVar) import           Control.Exception.Lifted import           Control.Monad-import           Control.Monad.Catch (MonadThrow,throwM,MonadCatch,MonadMask)+import           Control.Monad.Catch (MonadThrow,throwM,MonadCatch) import           Control.Monad.IO.Class (MonadIO,liftIO) import           Control.Monad.Logger (MonadLogger,logError,logInfo,logWarn) import           Control.Monad.Reader (MonadReader,asks,runReaderT) import           Control.Monad.Writer (execWriter,runWriter,tell)-import           Control.Monad.Trans.Control (MonadBaseControl) import qualified "cryptohash" Crypto.Hash as Hash import           Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode) import           Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString)@@ -50,7 +49,6 @@ import           Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..)) import           Data.Version (showVersion) import           GHC.Exts (sortWith)-import           Network.HTTP.Client.Conduit (HasHttpManager) import           Path import           Path.Extra (toFilePathNoTrailingSep) import           Path.IO hiding (canonicalizePath)@@ -64,25 +62,28 @@ import           Stack.Types.Config import           Stack.Types.Docker import           Stack.Types.Internal+import           Stack.Types.StackT import           Stack.Setup (ensureDockerStackExe) import           System.Directory (canonicalizePath,getHomeDirectory) import           System.Environment (getEnv,getEnvironment,getProgName,getArgs,getExecutablePath)-import           System.Exit (exitSuccess, exitWith)+import           System.Exit (exitSuccess, exitWith, ExitCode(..)) import qualified System.FilePath as FP-import           System.IO (stderr,stdin,stdout,hIsTerminalDevice)+import           System.IO (stderr,stdin,stdout,hIsTerminalDevice, hClose) import           System.IO.Error (isDoesNotExistError) import           System.IO.Unsafe (unsafePerformIO) import qualified System.PosixCompat.User as User import qualified System.PosixCompat.Files as Files+import           System.Process (CreateProcess(..), StdStream(..), waitForProcess) import           System.Process.PagerEditor (editByteString) import           System.Process.Read import           System.Process.Run-import           System.Process (CreateProcess(delegate_ctlc)) import           Text.Printf (printf) -#ifndef WINDOWS+#ifdef WINDOWS+import           Control.Monad.Trans.Control (MonadBaseControl)+#else import           Control.Concurrent (threadDelay)-import           Control.Monad.Trans.Control (liftBaseWith)+import           Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith) import           System.Posix.Signals import qualified System.Posix.User as PosixUser #endif@@ -95,7 +96,7 @@ -- for this is releasing a lock.  After launching reexecution, the host process becomes -- nothing but an manager for the call into docker and thus may not hold the lock. reexecWithOptionalContainer-    :: M env m+    :: (StackM env m, HasConfig env)     => Maybe (Path Abs Dir)     -> Maybe (m ())     -> IO ()@@ -197,7 +198,7 @@ -- -- This takes an optional release action just like `reexecWithOptionalContainer`. execWithOptionalContainer-    :: M env m+    :: (StackM env m, HasConfig env)     => Maybe (Path Abs Dir)     -> GetCmdArgs env m     -> Maybe (m ())@@ -239,7 +240,7 @@         else inner  -- | Run a command in a new Docker container, then exit the process.-runContainerAndExit :: M env m+runContainerAndExit :: (StackM env m, HasConfig env)   => GetCmdArgs env m   -> Maybe (Path Abs Dir) -- ^ Project root (maybe)   -> m ()              -- ^ Action to run before@@ -306,7 +307,7 @@      pwd <- getCurrentDir      liftIO        (do updateDockerImageLastUsed config iiId (toFilePath projectRoot)-           mapM_ (ensureDir) [sandboxHomeDir, stackRoot])+           mapM_ ensureDir [sandboxHomeDir, stackRoot])      -- Since $HOME is now mounted in the same place in the container we can      -- just symlink $HOME/.ssh to the right place for the stack docker user      let sshDir = homeDir </> sshRelDir@@ -322,6 +323,7 @@                  (toFilePathNoTrailingSep (sandboxHomeDir </> sshRelDir))))      containerID <- (trim . decodeUtf8) <$> readDockerProcess        envOverride+       (Just projectRoot)        (concat          [["create"           ,"--net=host"@@ -413,14 +415,14 @@     sshRelDir = $(mkRelDir ".ssh/")  -- | Clean-up old docker images and containers.-cleanup :: M env m+cleanup :: (StackM env m, HasConfig env)         => CleanupOpts -> m () cleanup opts =   do config <- asks getConfig      let docker = configDocker config      envOverride <- getEnvOverride (configPlatform config)      checkDockerVersion envOverride docker-     let runDocker = readDockerProcess envOverride+     let runDocker = readDockerProcess envOverride Nothing      imagesOut <- runDocker ["images","--no-trunc","-f","dangling=false"]      danglingImagesOut <- runDocker ["images","--no-trunc","-f","dangling=true"]      runningContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=running"]@@ -479,9 +481,9 @@                             do $logInfo (concatT ["Removing container: '",v,"'"])                                return ["rm","-f",v]                         | otherwise -> throwM (InvalidCleanupCommandException line)-             e <- try (readDockerProcess envOverride args)+             e <- try (readDockerProcess envOverride Nothing args)              case e of-               Left ex@ReadProcessException{} ->+               Left ex@ProcessFailed{} ->                  $logError (concatT ["Could not remove: '",v,"': ", show ex])                Left e' -> throwM e'                Right _ -> return ()@@ -655,19 +657,19 @@ inspects _ [] = return Map.empty inspects envOverride images =   do maybeInspectOut <--       try (readDockerProcess envOverride ("inspect" : images))+       try (readDockerProcess envOverride Nothing ("inspect" : images))      case maybeInspectOut of        Right inspectOut ->          -- filtering with 'isAscii' to workaround @docker inspect@ output containing invalid UTF-8          case eitherDecode (LBS.pack (filter isAscii (decodeUtf8 inspectOut))) of            Left msg -> throwM (InvalidInspectOutputException msg)            Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results))-       Left (ReadProcessException _ _ _ err)+       Left (ProcessFailed _ _ _ err)          | "Error: No such image" `LBS.isPrefixOf` err -> return Map.empty        Left e -> throwM e  -- | Pull latest version of configured Docker image from registry.-pull :: M env m => m ()+pull :: (StackM env m, HasConfig env) => m () pull =   do config <- asks getConfig      let docker = configDocker config@@ -676,7 +678,7 @@      pullImage envOverride docker (dockerImage docker)  -- | Pull Docker image from registry.-pullImage :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m)+pullImage :: (MonadLogger m,MonadIO m,MonadThrow m)           => EnvOverride -> DockerOpts -> String -> m () pullImage envOverride docker image =   do $logInfo (concatT ["Pulling image from registry: '",image,"'"])@@ -691,10 +693,21 @@                    ,maybe [] (\n -> ["--username=" ++ n]) (dockerRegistryUsername docker)                    ,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker)                    ,[takeWhile (/= '/') image]]))-     e <- try (callProcess (Cmd Nothing "docker" envOverride ["pull",image]))-     case e of-       Left (ProcessExitedUnsuccessfully _ _) -> throwM (PullFailedException image)-       Right () -> return ()+     -- We redirect the stdout of the process to stderr so that the output+     -- of @docker pull@ will not interfere with the output of other+     -- commands when using --auto-docker-pull. See issue #2733.+     let stdoutToStderr cp = cp+           { std_out = UseHandle stderr+           , std_err = UseHandle stderr+           , std_in = CreatePipe+           }+     (Just hin, _, _, ph) <- createProcess' "pullImage" stdoutToStderr $+       Cmd Nothing "docker" envOverride ["pull",image]+     liftIO (hClose hin)+     ec <- liftIO (waitForProcess ph)+     case ec of+       ExitSuccess -> return ()+       ExitFailure _ -> throwM (PullFailedException image)  -- | Check docker version (throws exception if incorrect) checkDockerVersion@@ -703,7 +716,7 @@ checkDockerVersion envOverride docker =   do dockerExists <- doesExecutableExist envOverride "docker"      unless dockerExists (throwM DockerNotInstalledException)-     dockerVersionOut <- readDockerProcess envOverride ["--version"]+     dockerVersionOut <- readDockerProcess envOverride Nothing ["--version"]      case words (decodeUtf8 dockerVersionOut) of        (_:_:v:_) ->          case parseVersionFromString (stripVersion v) of@@ -720,7 +733,7 @@        _ -> throwM InvalidVersionOutputException   where minimumDockerVersion = $(mkVersion "1.6.0")         prohibitedDockerVersions = []-        stripVersion v = fst $ break (== '-') $ dropWhileEnd (not . isDigit) v+        stripVersion v = takeWhile (/= '-') (dropWhileEnd (not . isDigit) v)  -- | Remove the project's Docker sandbox. reset :: (MonadIO m, MonadReader env m, HasConfig env)@@ -854,8 +867,8 @@ -- process fails.  Logs process's stderr using @$logError@. readDockerProcess     :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)-    => EnvOverride -> [String] -> m BS.ByteString-readDockerProcess envOverride = readProcessStdout Nothing envOverride "docker"+    => EnvOverride -> Maybe (Path Abs Dir) -> [String] -> m BS.ByteString+readDockerProcess envOverride mpwd = readProcessStdout mpwd envOverride "docker"  -- | Name of home directory within docker sandbox. homeDirName :: Path Rel Dir@@ -931,12 +944,9 @@  -- | Function to get command and arguments to run in Docker container type GetCmdArgs env m-   = M env m+   = (StackM env m, HasConfig env)   => DockerOpts   -> EnvOverride   -> Inspect   -> Bool   -> m (FilePath,[String],[(String,String)],[Mount])--type M env m = (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadCatch m-               ,HasConfig env,HasTerminal env,HasReExec env,HasHttpManager env,MonadMask m)
src/Stack/Dot.hs view
@@ -1,9 +1,13 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+ module Stack.Dot (dot                  ,listDependencies                  ,DotOpts(..)+                 ,DotPayload(..)+                 ,ListDepsOpts(..)                  ,resolveDependencies                  ,printGraph                  ,pruneGraph@@ -12,15 +16,13 @@ import           Control.Applicative import           Control.Arrow ((&&&)) import           Control.Monad (liftM, void)-import           Control.Monad.Catch (MonadCatch,MonadMask) import           Control.Monad.IO.Class-import           Control.Monad.Logger (MonadLogger)-import           Control.Monad.Reader (MonadReader) import           Control.Monad.Trans.Unlift (MonadBaseUnlift) import qualified Data.Foldable as F import qualified Data.HashSet as HashSet import           Data.Map (Map) import qualified Data.Map as Map+import           Data.Maybe import           Data.Monoid ((<>)) import           Data.Set (Set) import qualified Data.Set as Set@@ -28,7 +30,7 @@ import qualified Data.Text as Text import qualified Data.Text.IO as Text import qualified Data.Traversable as T-import           Network.HTTP.Client.Conduit (HasHttpManager)+import           Distribution.License (License) import           Prelude -- Fix redundant import warnings import           Stack.Build (withLoadPackage) import           Stack.Build.Installed (getInstalled, GetInstalledOpts(..))@@ -36,65 +38,88 @@ import           Stack.Build.Target import           Stack.Constants import           Stack.Package+import           Stack.Types.Build+import           Stack.Types.Config import           Stack.Types.FlagName+import           Stack.Types.Package import           Stack.Types.PackageName+import           Stack.Types.StackT import           Stack.Types.Version-import           Stack.Types.Config-import           Stack.Types.Build-import           Stack.Types.Package-import           Stack.Types.Internal (HasLogLevel)  -- | Options record for @stack dot@ data DotOpts = DotOpts-    { dotIncludeExternal :: Bool+    { dotIncludeExternal :: !Bool     -- ^ Include external dependencies-    , dotIncludeBase :: Bool+    , dotIncludeBase :: !Bool     -- ^ Include dependencies on base-    , dotDependencyDepth :: Maybe Int+    , dotDependencyDepth :: !(Maybe Int)     -- ^ Limit the depth of dependency resolution to (Just n) or continue until fixpoint-    , dotPrune :: Set String+    , dotPrune :: !(Set String)     -- ^ Package names to prune from the graph+    , dotTargets :: [Text]+    -- ^ stack TARGETs to trace dependencies for+    , dotFlags :: !(Map (Maybe PackageName) (Map FlagName Bool))+    -- ^ Flags to apply when calculating dependencies+    , dotTestTargets :: Bool+    -- ^ Like the "--test" flag for build, affects the meaning of 'dotTargets'.+    , dotBenchTargets :: Bool+    -- ^ Like the "--bench" flag for build, affects the meaning of 'dotTargets'.     } +data ListDepsOpts = ListDepsOpts+    { listDepsDotOpts :: !DotOpts+    -- ^ The normal dot options.+    , listDepsSep :: !Text+    -- ^ Separator between the package name and details.+    , listDepsLicense :: !Bool+    -- ^ Print dependency licenses instead of versions.+    }+ -- | Visualize the project's dependencies as a graphviz graph-dot :: (HasEnvConfig env-       ,HasHttpManager env-       ,HasLogLevel env-       ,MonadBaseUnlift IO m-       ,MonadCatch m-       ,MonadLogger m-       ,MonadIO m-       ,MonadMask m-       ,MonadReader env m-       )+dot :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)     => DotOpts     -> m () dot dotOpts = do-    localNames <- liftM Map.keysSet getLocalPackageViews-    resultGraph <- createDependencyGraph dotOpts-    let pkgsToPrune = if dotIncludeBase dotOpts-                         then dotPrune dotOpts-                         else Set.insert "base" (dotPrune dotOpts)-        prunedGraph = pruneGraph localNames pkgsToPrune resultGraph-    printGraph dotOpts localNames prunedGraph+  (localNames, prunedGraph) <- createPrunedDependencyGraph dotOpts+  printGraph dotOpts localNames prunedGraph +-- | Information about a package in the dependency graph, when available.+data DotPayload = DotPayload+  { payloadVersion :: Maybe Version+  -- ^ The package version.+  , payloadLicense :: Maybe License+  -- ^ The license the package was released under.+  } deriving (Eq, Show)++-- | Create the dependency graph and also prune it as specified in the dot+-- options. Returns a set of local names and and a map from package names to+-- dependencies.+createPrunedDependencyGraph :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)+                            => DotOpts+                            -> m (Set PackageName,+                                  Map PackageName (Set PackageName, DotPayload))+createPrunedDependencyGraph dotOpts = do+  localNames <- liftM Map.keysSet getLocalPackageViews+  resultGraph <- createDependencyGraph dotOpts+  let pkgsToPrune = if dotIncludeBase dotOpts+                       then dotPrune dotOpts+                       else Set.insert "base" (dotPrune dotOpts)+      prunedGraph = pruneGraph localNames pkgsToPrune resultGraph+  return (localNames, prunedGraph)+ -- | Create the dependency graph, the result is a map from a package--- name to a tuple of dependencies and a version if available.  This+-- name to a tuple of dependencies and payload if available. This -- function mainly gathers the required arguments for -- @resolveDependencies@.-createDependencyGraph :: (HasEnvConfig env-                         ,HasHttpManager env-                         ,HasLogLevel env-                         ,MonadLogger m-                         ,MonadBaseUnlift IO m-                         ,MonadIO m-                         ,MonadMask m-                         ,MonadReader env m)+createDependencyGraph :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)                        => DotOpts-                       -> m (Map PackageName (Set PackageName, Maybe Version))+                       -> m (Map PackageName (Set PackageName, DotPayload)) createDependencyGraph dotOpts = do-  (_,_,locals,_,sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI-  let graph = Map.fromList (localDependencies dotOpts locals)+  (locals,sourceMap) <- loadSourceMap 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                                                    (GetInstalledOpts False False)@@ -103,7 +128,7 @@     let depLoader =           createDepLoader sourceMap                           installedMap-                          (fmap4 (packageAllDeps &&& (Just . packageVersion)) loader)+                          (fmap4 (packageAllDeps &&& makePayload) loader)     liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader)   where -- fmap a function over the result of a function with 3 arguments         fmap4 :: Functor f => (r -> r') -> (a -> b -> c -> d -> f r) -> a -> b -> c -> d -> f r'@@ -112,25 +137,22 @@         fst4 :: (a,b,c,d) -> a         fst4 (x,_,_,_) = x -listDependencies :: (HasEnvConfig env-                    ,HasHttpManager env-                    ,HasLogLevel env-                    ,MonadBaseUnlift IO m-                    ,MonadLogger m-                    ,MonadMask m-                    ,MonadIO m-                    ,MonadReader env m-                    )-                  => Text+        makePayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg)++listDependencies :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)+                  => ListDepsOpts                   -> m ()-listDependencies sep = do-  let dotOpts = DotOpts True True Nothing Set.empty-  resultGraph <- createDependencyGraph dotOpts+listDependencies opts = do+  let dotOpts = listDepsDotOpts opts+  (_, resultGraph) <- createPrunedDependencyGraph dotOpts   void (Map.traverseWithKey go (snd <$> resultGraph))-    where go name v = liftIO (Text.putStrLn $-                                Text.pack (packageNameString name) <>-                                sep <>-                                maybe "<unknown>" (Text.pack . show) v)+    where go name payload =+            let payloadText =+                    if listDepsLicense opts+                      then maybe "<unknown>" (Text.pack . show) (payloadLicense payload)+                      else maybe "<unknown>" (Text.pack . show) (payloadVersion payload)+                line = packageNameText name <> listDepsSep opts <> payloadText+            in  liftIO $ Text.putStrLn line  -- | @pruneGraph dontPrune toPrune graph@ prunes all packages in -- @graph@ with a name in @toPrune@ and removes resulting orphans@@ -165,9 +187,9 @@ -- | Resolve the dependency graph up to (Just depth) or until fixpoint is reached resolveDependencies :: (Applicative m, Monad m)                     => Maybe Int-                    -> Map PackageName (Set PackageName,Maybe Version)-                    -> (PackageName -> m (Set PackageName, Maybe Version))-                    -> m (Map PackageName (Set PackageName,Maybe Version))+                    -> Map PackageName (Set PackageName, DotPayload)+                    -> (PackageName -> m (Set PackageName, DotPayload))+                    -> m (Map PackageName (Set PackageName, DotPayload)) resolveDependencies (Just 0) graph _ = return graph resolveDependencies limit graph loadPackageDeps = do   let values = Set.unions (fst <$> Map.elems graph)@@ -186,31 +208,38 @@ createDepLoader :: Applicative m                 => Map PackageName PackageSource                 -> Map PackageName Installed-                -> (PackageName -> Version -> Map FlagName Bool -> [Text] -> m (Set PackageName,Maybe Version))+                -> (PackageName -> Version -> Map FlagName Bool -> [Text] -> m (Set PackageName, DotPayload))                 -> PackageName-                -> m (Set PackageName, Maybe Version)+                -> m (Set PackageName, DotPayload) createDepLoader sourceMap installed loadPackageDeps pkgName =   case Map.lookup pkgName sourceMap of-    Just (PSLocal lp) -> pure ((packageAllDeps &&& (Just . packageVersion)) (lpPackage lp))+    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, fmap installedVersion (Map.lookup pkgName installed))+    Nothing -> pure (Set.empty, payloadFromInstalled (Map.lookup pkgName installed))+  where+    payloadFromLocal pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg)+    payloadFromInstalled maybePkg = DotPayload (fmap installedVersion maybePkg) Nothing  -- | Resolve the direct (depth 0) external dependencies of the given local packages-localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName,(Set PackageName,Maybe Version))]+localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))] localDependencies dotOpts locals =-    map (\lp -> (packageName (lpPackage lp), (deps lp,Just (lpVersion lp)))) locals-  where deps lp = if dotIncludeExternal dotOpts-                then Set.delete (lpName lp) (packageAllDeps (lpPackage lp))-                else Set.intersection localNames (packageAllDeps (lpPackage lp))-        lpName lp = packageName (lpPackage lp)+    map (\lp -> let pkg = localPackageToPackage lp+                 in (packageName pkg, (deps pkg, lpPayload pkg)))+        locals+  where deps pkg =+          if dotIncludeExternal dotOpts+            then Set.delete (packageName pkg) (packageAllDeps pkg)+            else Set.intersection localNames (packageAllDeps pkg)         localNames = Set.fromList $ map (packageName . lpPackage) locals-        lpVersion lp = packageVersion (lpPackage lp)+        lpPayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg)  -- | Print a graphviz graph of the edges in the Map and highlight the given local packages printGraph :: (Applicative m, MonadIO m)            => DotOpts            -> Set PackageName -- ^ all locals-           -> Map PackageName (Set PackageName, Maybe Version)+           -> Map PackageName (Set PackageName, DotPayload)            -> m () printGraph dotOpts locals graph = do   liftIO $ Text.putStrLn "strict digraph deps {"@@ -236,7 +265,7 @@  -- | Print nodes without dependencies printLeaves :: MonadIO m-            => Map PackageName (Set PackageName,Maybe Version)+            => Map PackageName (Set PackageName, DotPayload)             -> m () printLeaves = F.mapM_ printLeaf . Map.keysSet . Map.filter Set.null . fmap fst @@ -250,7 +279,7 @@  -- | Convert a package name to a graph node name. nodeName :: PackageName -> Text-nodeName name = "\"" <> Text.pack (packageNameString name) <> "\""+nodeName name = "\"" <> packageNameText name <> "\""  -- | Print a node with no dependencies printLeaf :: MonadIO m => PackageName -> m ()@@ -262,3 +291,7 @@ -- | Check if the package is wired in (shipped with) ghc isWiredIn :: PackageName -> Bool isWiredIn = (`HashSet.member` wiredInPackages)++localPackageToPackage :: LocalPackage -> Package+localPackageToPackage lp =+  fromMaybe (lpPackage lp) (lpTestBench lp)
src/Stack/Exec.hs view
@@ -21,11 +21,12 @@ 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) #else-import           System.Posix.Process (executeFile)+import qualified System.Process.PID1 as PID1 import           System.Process.Read (EnvOverride, envHelper, preProcess) #endif @@ -61,9 +62,10 @@ exec = execSpawn #else exec menv cmd0 args = do+    setNoBuffering     cmd <- preProcess Nothing menv cmd0     $withProcessTimeLog cmd args $-        liftIO $ executeFile cmd True args (envHelper menv)+        liftIO $ PID1.run cmd args (envHelper menv) #endif  -- | Like 'exec', but does not use 'execv' on non-windows. This way, there@@ -73,6 +75,7 @@ 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@@ -87,3 +90,9 @@     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
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DeriveDataTypeable    #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -24,72 +25,66 @@     , withCabalLoader     ) where -import qualified Codec.Archive.Tar              as Tar-import qualified Codec.Archive.Tar.Check        as Tar-import qualified Codec.Archive.Tar.Entry        as Tar-import           Codec.Compression.GZip         (decompress)-import           Control.Applicative-import           Control.Concurrent.Async       (Concurrently (..))-import           Control.Concurrent.MVar.Lifted (modifyMVar, newMVar)-import           Control.Concurrent.STM         (TVar, atomically, modifyTVar,-                                                 newTVarIO, readTVar,-                                                 readTVarIO, writeTVar)-import           Control.Exception              (assert)-import           Control.Exception.Enclosed     (tryIO)-import           Control.Monad                  (join, liftM, unless, void,-                                                 when)-import           Control.Monad.Catch-import           Control.Monad.IO.Class-import           Control.Monad.Logger-import           Control.Monad.Reader           (asks, runReaderT)-import           Control.Monad.Trans.Control-import           Control.Monad.Trans.Unlift     (MonadBaseUnlift, askRunBase)-import "cryptohash" Crypto.Hash                 (SHA512 (..))-import           Data.ByteString                (ByteString)-import qualified Data.ByteString                as S-import qualified Data.ByteString.Lazy           as L-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           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.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.Typeable                  (Typeable)-import           Data.Word                      (Word64)-import           Network.HTTP.Download-import           Path-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.PackageIdentifier-import           Stack.Types.PackageIndex-import           Stack.Types.PackageName-import           Stack.Types.Version-import           Stack.Types.Config-import           System.FilePath                ((<.>))-import qualified System.FilePath                as FP-import           System.IO                      (IOMode (ReadMode),-                                                 SeekMode (AbsoluteSeek), hSeek,-                                                 withBinaryFile, openBinaryFile,-                                                 hClose)-import           System.PosixCompat             (setFileMode)-import           Text.EditDistance              as ED+import qualified    Codec.Archive.Tar as Tar+import qualified    Codec.Archive.Tar.Check as Tar+import qualified    Codec.Archive.Tar.Entry as Tar+import              Codec.Compression.GZip (decompress)+import              Control.Applicative+import              Control.Concurrent.Async (Concurrently (..))+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+import              Control.Monad.Logger+import              Control.Monad.Reader (ask, asks, runReaderT)+import              Control.Monad.Trans.Control+import              Control.Monad.Trans.Unlift (MonadBaseUnlift, askRunBase)+import "cryptohash" Crypto.Hash (SHA512 (..))+import              Data.ByteString (ByteString)+import qualified    Data.ByteString as S+import qualified    Data.ByteString.Lazy as L+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              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.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.Metrics+import              Data.Typeable (Typeable)+import              Data.Word (Word64)+import              Network.HTTP.Download+import              Path+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+import              Stack.Types.PackageIdentifier+import              Stack.Types.PackageIndex+import              Stack.Types.PackageName+import              Stack.Types.Version+import              System.FilePath ((<.>))+import qualified    System.FilePath as FP+import              System.IO+import              System.PosixCompat (setFileMode)  type PackageCaches = Map PackageIdentifier (PackageIndex, PackageCache) @@ -131,7 +126,7 @@         (if null suggestions then "" else "\n" ++ suggestions)  -- | Fetch packages into the cache without unpacking-fetchPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadMask m, MonadLogger m)+fetchPackages :: (StackMiniM env m, HasConfig env)               => EnvOverride               -> Set PackageIdentifier               -> m ()@@ -147,7 +142,7 @@     idents = Map.fromList $ map (, Nothing) $ Set.toList idents'  -- | Intended to work for the command line command.-unpackPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadMask m, MonadLogger m)+unpackPackages :: (StackMiniM env m, HasConfig env)                => EnvOverride                -> FilePath -- ^ destination                -> [String] -- ^ names or identifiers@@ -183,7 +178,7 @@ -- | 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-    :: (MonadBaseControl IO m, MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadMask m, MonadLogger m)+    :: (StackMiniM env m, HasConfig env)     => EnvOverride     -> Path Abs Dir -- ^ unpack directory     -> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157@@ -202,7 +197,7 @@     }  -- | Resolve a set of package names and identifiers into @FetchPackage@ values.-resolvePackages :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)+resolvePackages :: (StackMiniM env m, HasConfig env)                 => EnvOverride                 -> Map PackageIdentifier (Maybe GitSHA1)                 -> Set PackageName@@ -222,7 +217,7 @@       | otherwise                    = Right idents  resolvePackagesAllowMissing-    :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)+    :: (StackMiniM env m, HasConfig env)     => Map PackageIdentifier (Maybe GitSHA1)     -> Set PackageName     -> m (Set PackageName, Set PackageIdentifier, Map PackageIdentifier ResolvedPackage)@@ -264,7 +259,7 @@  -- | Add the cabal files to a list of idents with their caches. withCabalFiles-    :: (MonadMask m, MonadIO m, MonadLogger m, MonadReader env m, HasConfig env)+    :: (StackMiniM env m, HasConfig env)     => IndexName     -> [(PackageIdentifier, PackageCache, Maybe GitSHA1, a)]     -> (PackageIdentifier -> a -> ByteString -> IO b)@@ -308,7 +303,7 @@ -- | Provide a function which will load up a cabal @ByteString@ from the -- package indices. withCabalLoader-    :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, HasHttpManager env, MonadBaseUnlift IO m, MonadMask m)+    :: (StackMiniM env m, HasConfig env, MonadBaseUnlift IO m)     => EnvOverride     -> ((PackageIdentifier -> IO ByteString) -> m a)     -> m a@@ -344,7 +339,7 @@                                   Just cs -> "Perhaps you meant " <>                                     orSeparated cs <> "?"                             Just cs -> "Possible candidates: " <>-                              commaSeparated (NE.map packageIdentifierString cs)+                              commaSeparated (NE.map packageIdentifierText cs)                               <> "."                     join $ modifyMVar updateRef $ \toUpdate ->                         if toUpdate then do@@ -361,11 +356,11 @@                             return (False, doLookup ident)                         else return (toUpdate,                                      throwM $ UnknownPackageIdentifiers-                                       (Set.singleton ident) suggestions)+                                       (Set.singleton ident) (T.unpack suggestions))     inner doLookup  lookupPackageIdentifierExact-  :: (MonadMask m, MonadIO m, MonadLogger m, HasConfig env)+  :: (StackMiniM env m, HasConfig env)   => PackageIdentifier   -> env   -> PackageCaches@@ -400,9 +395,9 @@ typoCorrectionCandidates   :: PackageIdentifier   -> PackageCaches-  -> Maybe (NonEmpty String)+  -> Maybe (NonEmpty T.Text) typoCorrectionCandidates ident =-  let getName = packageNameString . packageIdentifierName+  let getName = packageNameText . packageIdentifierName       name    = getName ident   in  NE.nonEmpty     . Map.keys@@ -410,7 +405,7 @@     . Map.mapKeys getName  -- | Figure out where to fetch from.-getToFetch :: (MonadMask m, MonadLogger m, MonadIO m, MonadReader env m, HasConfig env)+getToFetch :: (StackMiniM env m, HasConfig env)            => Maybe (Path Abs Dir) -- ^ directory to unpack into, @Nothing@ means no unpack            -> Map PackageIdentifier ResolvedPackage            -> m ToFetchResult@@ -468,7 +463,7 @@ -- @ -- -- Since 0.1.0.0-fetchPackages' :: (MonadIO m,MonadReader env m,HasHttpManager env,HasConfig env,MonadLogger m,MonadThrow m,MonadBaseControl IO m)+fetchPackages' :: (StackMiniM env m, HasConfig env)                => Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157                -> Map PackageIdentifier ToFetch                -> m (Map PackageIdentifier (Path Abs Dir))@@ -484,7 +479,7 @@      liftIO $ readTVarIO outputVar   where-    go :: (MonadIO m,MonadThrow m,MonadLogger m,MonadReader env m,HasHttpManager env)+    go :: (MonadIO m,MonadThrow m,MonadLogger m)        => TVar (Map PackageIdentifier (Path Abs Dir))        -> (m () -> IO ())        -> (PackageIdentifier, ToFetch)@@ -627,14 +622,11 @@         workers i = Concurrently worker *> workers (i - 1)     liftIO $ runConcurrently $ workers cnt -damerauLevenshtein :: String -> String -> Int-damerauLevenshtein = ED.restrictedDamerauLevenshteinDistance ED.defaultEditCosts--orSeparated :: NonEmpty String -> String+orSeparated :: NonEmpty T.Text -> T.Text orSeparated xs   | NE.length xs == 1 = NE.head xs   | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs-  | otherwise = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs+  | otherwise = T.intercalate ", " (NE.init xs) <> ", or " <> NE.last xs -commaSeparated :: NonEmpty String -> String+commaSeparated :: NonEmpty T.Text -> T.Text commaSeparated = F.fold . NE.intersperse ", "
src/Stack/FileWatch.hs view
@@ -11,7 +11,7 @@ import Control.Concurrent.Async (race_) import Control.Concurrent.STM import Control.Exception (Exception, fromException)-import Control.Exception.Enclosed (tryAny)+import Control.Exception.Safe (tryAny) import Control.Monad (forever, unless, when) import qualified Data.ByteString.Lazy as L import qualified Data.Map.Strict as Map
src/Stack/GhcPkg.hs view
@@ -33,6 +33,7 @@ import           Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T+import           Data.Text.Extra (stripCR) import           Path (Path, Abs, Dir, toFilePath, parent) import           Path.Extra (toFilePathNoTrailingSep) import           Path.IO@@ -127,8 +128,6 @@             Left{} -> Nothing             Right lbs ->                 fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines lbs-  where-    stripCR t = fromMaybe t (T.stripSuffix "\r" t)  -- | Get the version of the package findGhcPkgVersion :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
src/Stack/Ghci.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}  -- | Run a GHCi configured with the user's package(s). @@ -12,7 +13,6 @@     ( GhciOpts(..)     , GhciPkgInfo(..)     , GhciException(..)-    , ghciSetup     , ghci      -- TODO: Address what should and should not be exported.@@ -21,13 +21,14 @@     ) where  import           Control.Applicative-import           Control.Exception.Enclosed (tryAny)+import           Control.Arrow (second)+import           Control.Exception.Safe (tryAny) import           Control.Monad hiding (forM) import           Control.Monad.Catch import           Control.Monad.IO.Class import           Control.Monad.Logger+import           Control.Monad.Reader (asks) import           Control.Monad.State.Strict (State, execState, get, modify)-import           Control.Monad.Reader (MonadReader, asks) import           Control.Monad.Trans.Unlift (MonadBaseUnlift) import qualified Data.ByteString.Char8 as S8 import           Data.Either@@ -41,13 +42,13 @@ import           Data.Monoid import           Data.Set (Set) import qualified Data.Set as S-import           Data.Traversable (forM)+import           Data.String import           Data.Text (Text) import qualified Data.Text as T+import           Data.Traversable (forM) import           Data.Typeable (Typeable)-import           Distribution.PackageDescription (updatePackageDescription)-import           Distribution.Text (display)-import           Network.HTTP.Client.Conduit+import qualified Distribution.PackageDescription as C+import qualified Distribution.Text as C import           Path import           Path.Extra (toFilePathNoTrailingSep) import           Path.IO@@ -56,17 +57,19 @@ import           Stack.Build.Installed import           Stack.Build.Source import           Stack.Build.Target+import           Stack.Config (getLocalPackages) import           Stack.Constants import           Stack.Exec import           Stack.Ghci.Script import           Stack.Package-import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageName-import           Stack.Types.Config+import           Stack.PrettyPrint import           Stack.Types.Build-import           Stack.Types.Package import           Stack.Types.Compiler-import           Stack.Types.Internal+import           Stack.Types.Config+import           Stack.Types.Package+import           Stack.Types.PackageIdentifier+import           Stack.Types.PackageName+import           Stack.Types.StackT import           Text.Read (readMaybe)  #ifndef WINDOWS@@ -75,7 +78,7 @@  -- | Command-line options for GHC. data GhciOpts = GhciOpts-    { ghciNoBuild            :: !Bool+    { ghciTargets            :: ![Text]     , ghciArgs               :: ![String]     , ghciGhcCommand         :: !(Maybe FilePath)     , ghciNoLoadModules      :: !Bool@@ -84,7 +87,7 @@     , ghciLoadLocalDeps      :: !Bool     , ghciSkipIntermediate   :: !Bool     , ghciHidePackages       :: !Bool-    , ghciBuildOptsCLI       :: !BuildOptsCLI+    , ghciNoBuild            :: !Bool     } deriving Show  -- | Necessary information to load a package or its components.@@ -96,12 +99,16 @@     , ghciPkgModFiles :: !(Set (Path Abs File)) -- ^ Module file paths.     , ghciPkgCFiles :: !(Set (Path Abs File)) -- ^ C files.     , ghciPkgMainIs :: !(Map NamedComponent (Set (Path Abs File)))+    , ghciPkgTargetFiles :: !(Maybe (Set (Path Abs File)))     , ghciPkgPackage :: !Package     } deriving Show  data GhciException     = InvalidPackageOption String     | LoadingDuplicateModules+    | MissingFileTarget String+    | Can'tSpecifyFilesAndTargets+    | Can'tSpecifyFilesAndMainIs     deriving (Typeable)  instance Exception GhciException@@ -113,16 +120,207 @@         [ "Not attempting to start ghci due to these duplicate modules."         , "Use --no-load to try to start it anyway, without loading any modules (but these are still likely to cause errors)"         ]+    show (MissingFileTarget name) =+        "Cannot find file target " ++ name+    show Can'tSpecifyFilesAndTargets =+        "Cannot use 'stack ghci' with both file targets and build targets"+    show Can'tSpecifyFilesAndMainIs =+        "Cannot use 'stack ghci' with both file targets and --main-is flag"  -- | Launch a GHCi session for the given local package targets with the -- given options and configure it with the load paths and extensions -- of those targets.-ghci-    :: (HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadLoggerIO m, MonadBaseUnlift IO m)-    => GhciOpts -> m ()+ghci :: (StackM r m, HasEnvConfig r, MonadBaseUnlift IO m) => GhciOpts -> m () ghci opts@GhciOpts{..} = do-    bopts <- asks (configBuild . getConfig)-    (targets,mainIsTargets,pkgs) <- ghciSetup opts+    -- Load source map, without explicit targets, to collect all info.+    (locals, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI+        { boptsCLITargets = [] }+    -- Parse --main-is argument.+    mainIsTargets <- parseMainIsTargets ghciMainIs+    -- Parse to either file targets or build targets+    etargets <- preprocessTargets ghciTargets+    (inputTargets, mfileTargets) <- case etargets of+        Left rawFileTargets -> do+            case mainIsTargets of+                Nothing -> return ()+                Just _ -> throwM Can'tSpecifyFilesAndMainIs+            -- Figure out targets based on filepath targets+            (targetMap, fileInfo, extraFiles) <- findFileTargets locals rawFileTargets+            return (targetMap, Just (fileInfo, extraFiles))+        Right rawTargets -> do+            (_,_,normalTargets) <- parseTargetsFromBuildOpts AllowNoTargets defaultBuildOptsCLI+                { boptsCLITargets = rawTargets }+            return (normalTargets, Nothing)+    -- Make sure the targets are known.+    checkTargets inputTargets+    -- Get a list of all the local target packages.+    localTargets <- getAllLocalTargets opts inputTargets mainIsTargets sourceMap+    -- Check if additional package arguments are sensible.+    addPkgs <- checkAdditionalPackages ghciAdditionalPackages+    -- Build required dependencies and setup local packages.+    buildDepsAndInitialSteps opts (map (packageNameText . fst) localTargets)+    -- Load the list of modules _after_ building, to catch changes in unlisted dependencies (#1180)+    pkgs <- getGhciPkgInfos sourceMap addPkgs (fmap fst mfileTargets) localTargets+    checkForIssues pkgs+    -- Finally, do the invocation of ghci+    runGhci opts localTargets mainIsTargets pkgs++preprocessTargets :: (StackM r m) => [Text] -> m (Either [Path Abs File] [Text])+preprocessTargets rawTargets = do+    let (fileTargetsRaw, normalTargets) =+            partition (\t -> ".hs" `T.isSuffixOf` t || ".lhs" `T.isSuffixOf` t)+                      rawTargets+    fileTargets <- forM fileTargetsRaw $ \fp0 -> do+        let fp = T.unpack fp0+        mpath <- forgivingAbsence (resolveFile' fp)+        case mpath of+            Nothing -> throwM (MissingFileTarget fp)+            Just path -> return path+    case (null fileTargets, null normalTargets) of+        (False, False) -> throwM Can'tSpecifyFilesAndTargets+        (False, _) -> return (Left fileTargets)+        _ -> return (Right normalTargets)++parseMainIsTargets :: (StackM r m, HasEnvConfig r) => Maybe Text -> m (Maybe (Map PackageName SimpleTarget))+parseMainIsTargets mtarget = forM mtarget $ \target -> do+     (_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets defaultBuildOptsCLI+         { boptsCLITargets = [target] }+     return targets++findFileTargets+    :: (StackM r m, HasEnvConfig r)+    => [LocalPackage]+    -> [Path Abs File]+    -> m (Map PackageName SimpleTarget, Map PackageName (Set (Path Abs File)), [Path Abs File])+findFileTargets locals fileTargets = do+    filePackages <- forM locals $ \lp -> do+        (_,compFiles,_,_) <- getPackageFiles (packageFiles (lpPackage lp)) (lpCabalFile lp)+        return (lp, M.map (S.map dotCabalGetPath) compFiles)+    let foundFileTargetComponents :: [(Path Abs File, [(PackageName, NamedComponent)])]+        foundFileTargetComponents =+            map (\fp -> (fp, ) $ sort $+                        concatMap (\(lp, files) -> map ((packageName (lpPackage lp), ) . fst)+                                                       (filter (S.member fp . snd) (M.toList files))+                                  ) filePackages+                ) fileTargets+    results <- forM foundFileTargetComponents $ \(fp, xs) ->+        case xs of+            [] -> do+                $prettyWarn $+                    "Couldn't find a component for file target" <+>+                    display fp <>+                    ". Attempting to load anyway."+                return $ Left fp+            [x] -> do+                $prettyInfo $+                    "Using configuration for" <+> display x <+>+                    "to load" <+> display fp+                return $ Right (fp, x)+            (x:_) -> do+                $prettyWarn $+                    "Multiple components contain file target" <+>+                    display fp <> ":" <+>+                    mconcat (intersperse ", " (map display xs)) <> line <>+                    "Guessing the first one," <+> display x <> "."+                return $ Right (fp, x)+    let (extraFiles, associatedFiles) = partitionEithers results+        targetMap =+            foldl unionSimpleTargets M.empty $+            map (\(_, (name, comp)) -> M.singleton name (STLocalComps (S.singleton comp)))+                associatedFiles+        infoMap =+            foldl (M.unionWith S.union) M.empty $+            map (\(fp, (name, _)) -> M.singleton name (S.singleton fp))+                associatedFiles+    return (targetMap, infoMap, extraFiles)++checkTargets+    :: (StackM r m, HasEnvConfig r)+    => Map PackageName SimpleTarget+    -> m ()+checkTargets mp = do+    let filtered = M.filter (== STUnknown) mp+    unless (M.null filtered) $ do+        bconfig <- asks getBuildConfig+        throwM $ UnknownTargets (M.keysSet filtered) M.empty (bcStackYaml bconfig)++getAllLocalTargets+    :: (StackM r m, HasEnvConfig r)+    => GhciOpts+    -> Map PackageName SimpleTarget+    -> Maybe (Map PackageName SimpleTarget)+    -> SourceMap+    -> m [(PackageName, (Path Abs File, SimpleTarget))]+getAllLocalTargets GhciOpts{..} targets0 mainIsTargets sourceMap = do+    -- Use the 'mainIsTargets' as normal targets, for CLI concision. See+    -- #1845. This is a little subtle - we need to do the target parsing+    -- independently in order to handle the case where no targets are+    -- specified.+    let targets = maybe targets0 (unionSimpleTargets targets0) mainIsTargets+    packages <- getLocalPackages+    -- Find all of the packages that are directly demanded by the+    -- targets.+    directlyWanted <-+        forMaybeM (M.toList packages) $+        \(dir,treatLikeExtraDep) ->+             do cabalfp <- findOrGenerateCabalFile dir+                name <- parsePackageNameFromFilePath cabalfp+                if treatLikeExtraDep+                    then return Nothing+                    else case M.lookup name targets of+                             Just simpleTargets ->+                                 return (Just (name, (cabalfp, simpleTargets)))+                             Nothing -> return Nothing+    -- Figure out+    let extraLoadDeps = getExtraLoadDeps ghciLoadLocalDeps sourceMap directlyWanted+    if (ghciSkipIntermediate && not ghciLoadLocalDeps) || null extraLoadDeps+        then return directlyWanted+        else do+            let extraList = T.intercalate ", " (map (packageNameText . fst) extraLoadDeps)+            if ghciLoadLocalDeps+                then $logInfo $ T.concat+                    [ "The following libraries will also be loaded into GHCi because "+                    , "they are local dependencies of your targets, and you specified --load-local-deps:\n    "+                    , extraList+                    ]+                else $logInfo $ T.concat+                    [ "The following libraries will also be loaded into GHCi because "+                    , "they are intermediate dependencies of your targets:\n    "+                    , extraList+                    , "\n(Use --skip-intermediate-deps to omit these)"+                    ]+            return (directlyWanted ++ extraLoadDeps)++buildDepsAndInitialSteps :: (StackM r m, HasEnvConfig r, MonadBaseUnlift IO m) => GhciOpts -> [Text] -> m ()+buildDepsAndInitialSteps GhciOpts{..} targets0 = do+    let targets = targets0 ++ map T.pack ghciAdditionalPackages+    -- If necessary, do the build, for local packagee targets, only do+    -- 'initialBuildSteps'.+    when (not ghciNoBuild && not (null targets)) $ do+        eres <- tryAny $ build (const (return ())) Nothing defaultBuildOptsCLI+            { boptsCLITargets = targets+            , boptsCLIInitialBuildSteps = True+            }+        case eres of+            Right () -> return ()+            Left err -> do+                $prettyError $ fromString (show err)+                $prettyWarn "Build failed, but optimistically launching GHCi anyway"++checkAdditionalPackages :: MonadThrow m => [String] -> m [PackageName]+checkAdditionalPackages pkgs = forM pkgs $ \name -> do+    let mres = (packageIdentifierName <$> parsePackageIdentifierFromString name)+            <|> parsePackageNameFromString name+    maybe (throwM $ InvalidPackageOption name) return mres++runGhci+    :: (StackM r m, HasEnvConfig r)+    => GhciOpts+    -> [(PackageName, (Path Abs File, SimpleTarget))]+    -> Maybe (Map PackageName SimpleTarget)+    -> [GhciPkgInfo]+    -> m ()+runGhci GhciOpts{..} targets mainIsTargets pkgs = do     config <- asks getConfig     bconfig <- asks getBuildConfig     wc <- getWhichCompiler@@ -144,7 +342,6 @@         $logWarn             ("The following GHC options are incompatible with GHCi and have not been passed to it: " <>              T.unwords (map T.pack (nubOrd omittedOpts)))-    mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs     oiDir <- objectInterfaceDir bconfig     let odir =             [ "-odir=" <> toFilePathNoTrailingSep oiDir@@ -167,21 +364,21 @@             if "Intero" `isPrefixOf` output                 then return renderScriptIntero                 else return renderScriptGhci-     withSystemTempDir "ghci" $ \tmpDirectory -> do-      macrosOptions <- writeMacrosFile tmpDirectory pkgs-      if ghciNoLoadModules-          then execGhci macrosOptions-          else do-              checkForDuplicateModules pkgs-              renderFn <- interrogateExeForRenderFunction-              scriptPath <- writeGhciScript tmpDirectory (renderFn pkgs mainFile)-              execGhci (macrosOptions ++ ["-ghci-script=" <> toFilePath scriptPath])+        macrosOptions <- writeMacrosFile tmpDirectory pkgs+        if ghciNoLoadModules+            then execGhci macrosOptions+            else do+                checkForDuplicateModules pkgs+                renderFn <- interrogateExeForRenderFunction+                bopts <- asks (configBuild . getConfig)+                mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs+                scriptPath <- writeGhciScript tmpDirectory (renderFn pkgs mainFile)+                execGhci (macrosOptions ++ ["-ghci-script=" <> toFilePath scriptPath])  writeMacrosFile :: (MonadIO m) => Path Abs Dir -> [GhciPkgInfo] -> m [String] writeMacrosFile tmpDirectory packages = do-  macrosOptions <- preprocessCabalMacros packages macrosFile-  return macrosOptions+  preprocessCabalMacros packages macrosFile   where     macrosFile = tmpDirectory </> $(mkRelFile "cabal_macros.h") @@ -205,7 +402,9 @@                       Just path -> cmdAddFile path                       Nothing   -> mempty       modulePhase = cmdModule $ foldl' S.union S.empty (fmap ghciPkgModules pkgs)-   in addPhase <> mainPhase <> modulePhase+   in case getFileTargets pkgs of+          [] -> addPhase <> mainPhase <> modulePhase+          fileTargets -> mconcat $ map cmdAddFile fileTargets   where     renderPkg pkg = cmdAdd (ghciPkgModules pkg) @@ -219,22 +418,29 @@                           Nothing      -> cmdAddFile path                       Nothing   -> mempty       modulePhase = cmdModule $ foldl' S.union S.empty (fmap ghciPkgModules pkgs)-   in addPhase <> mainPhase <> modulePhase+   in case getFileTargets pkgs of+          [] -> addPhase <> mainPhase <> modulePhase+          fileTargets -> mconcat $ map cmdAddFile fileTargets   where     renderPkg pkg = cmdCdGhc (ghciPkgDir pkg)                  <> cmdAdd (ghciPkgModules pkg) +-- Hacky check if module / main phase should be omitted. This should be+-- improved if / when we have a better per-component load.+getFileTargets :: [GhciPkgInfo] -> [Path Abs File]+getFileTargets = concatMap (concatMap S.toList . maybeToList . ghciPkgTargetFiles)+ -- | Figure out the main-is file to load based on the targets. Sometimes there -- is none, sometimes it's unambiguous, sometimes it's -- ambiguous. Warns and returns nothing if it's ambiguous. figureOutMainFile-    :: (MonadLogger m, MonadIO m)+    :: (StackM r m)     => BuildOpts     -> Maybe (Map PackageName SimpleTarget)-    -> Map PackageName SimpleTarget+    -> [(PackageName, (Path Abs File, SimpleTarget))]     -> [GhciPkgInfo]     -> m (Maybe (Path Abs File))-figureOutMainFile bopts mainIsTargets targets0 packages =+figureOutMainFile bopts mainIsTargets targets0 packages = do     case candidates of         [] -> return Nothing         [c@(_,_,fp)] -> do $logInfo ("Using main module: " <> renderCandidate c)@@ -256,7 +462,8 @@                 T.pack (show $ length candidates) <> "]")           liftIO userOption   where-    targets = fromMaybe targets0 mainIsTargets+    targets = fromMaybe (M.fromList $ map (\(k, (_, x)) -> (k, x)) targets0)+                        mainIsTargets     candidates = do         pkg <- packages         case M.lookup (ghciPkgName pkg) targets of@@ -311,36 +518,14 @@     sampleMainIsArg (pkg,comp,_) =         "--main-is " <> packageNameText pkg <> ":" <> renderComp comp --- | Create a list of infos for each target containing necessary--- information to load that package/components.-ghciSetup-    :: (HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadLoggerIO m, MonadBaseUnlift IO m)-    => GhciOpts-    -> m (Map PackageName SimpleTarget, Maybe (Map PackageName SimpleTarget), [GhciPkgInfo])-ghciSetup GhciOpts{..} = do-    (_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets ghciBuildOptsCLI-    mainIsTargets <--        case ghciMainIs of-            Nothing -> return Nothing-            Just target -> do-                (_,_,targets') <- parseTargetsFromBuildOpts AllowNoTargets ghciBuildOptsCLI { boptsCLITargets = [target] }-                return (Just targets')-    addPkgs <- forM ghciAdditionalPackages $ \name -> do-        let mres = (packageIdentifierName <$> parsePackageIdentifierFromString name)-                <|> parsePackageNameFromString name-        maybe (throwM $ InvalidPackageOption name) return mres-    let boptsCli = ghciBuildOptsCLI-            { boptsCLITargets = boptsCLITargets ghciBuildOptsCLI ++ map T.pack ghciAdditionalPackages-            }-    (realTargets,_,_,_,sourceMap) <- loadSourceMap AllowNoTargets boptsCli-    -- Try to build, but optimistically launch GHCi anyway if it fails (#1065)-    when (not ghciNoBuild && not (M.null realTargets)) $ do-        eres <- tryAny $ build (const (return ())) Nothing boptsCli-        case eres of-            Right () -> return ()-            Left err -> do-                $logError $ T.pack (show err)-                $logWarn "Warning: build failed, but optimistically launching GHCi anyway"+getGhciPkgInfos+    :: (StackM r m, HasEnvConfig r)+    => SourceMap+    -> [PackageName]+    -> Maybe (Map PackageName (Set (Path Abs File)))+    -> [(PackageName, (Path Abs File, SimpleTarget))]+    -> m [GhciPkgInfo]+getGhciPkgInfos sourceMap addPkgs mfileTargets localTargets = do     menv <- getMinimalEnvOverride     (installedMap, _, _, _) <- getInstalled         menv@@ -349,65 +534,23 @@             , getInstalledHaddock   = False             }         sourceMap-    econfig <- asks getEnvConfig-    directlyWanted <--        forMaybeM (M.toList (envConfigPackages econfig)) $-        \(dir,treatLikeExtraDep) ->-             do cabalfp <- findOrGenerateCabalFile dir-                name <- parsePackageNameFromFilePath cabalfp-                if treatLikeExtraDep-                    then return Nothing-                    else case M.lookup name targets of-                             Just simpleTargets ->-                                 return (Just (name, (cabalfp, simpleTargets)))-                             Nothing -> return Nothing-    let extraLoadDeps = getExtraLoadDeps ghciLoadLocalDeps sourceMap directlyWanted-    wanted <--        if (ghciSkipIntermediate && not ghciLoadLocalDeps) || null extraLoadDeps-            then return directlyWanted-            else do-                let extraList = T.intercalate ", " (map (packageNameText . fst) extraLoadDeps)-                if ghciLoadLocalDeps-                    then $logInfo $ T.concat-                        [ "The following libraries will also be loaded into GHCi because "-                        , "they are local dependencies of your targets, and you specified --load-local-deps:\n    "-                        , extraList-                        ]-                    else $logInfo $ T.concat-                        [ "The following libraries will also be loaded into GHCi because "-                        , "they are intermediate dependencies of your targets:\n    "-                        , extraList-                        , "\n(Use --skip-intermediate-deps to omit these)"-                        ]-                return (directlyWanted ++ extraLoadDeps)-    -- Load the list of modules _after_ building, to catch changes in unlisted dependencies (#1180)-    let localLibs = [name | (name, (_, target)) <- wanted, hasLocalComp isCLib target]-    infos <--        forM wanted $-        \(name,(cabalfp,target)) ->-             makeGhciPkgInfo boptsCli sourceMap installedMap localLibs addPkgs name cabalfp target-    checkForIssues infos-    return (realTargets, mainIsTargets, infos)-  where-    hasLocalComp p t =-        case t of-            STLocalComps s -> any p (S.toList s)-            STLocalAll -> True-            _ -> False+    let localLibs = [name | (name, (_, target)) <- localTargets, hasLocalComp isCLib target]+    forM localTargets $ \(name, (cabalfp, target)) ->+        makeGhciPkgInfo sourceMap installedMap localLibs addPkgs mfileTargets name cabalfp target  -- | Make information necessary to load the given package in GHCi. makeGhciPkgInfo-    :: (MonadReader r m, HasEnvConfig r, MonadLogger m, MonadIO m, MonadCatch m)-    => BuildOptsCLI-    -> SourceMap+    :: (StackM r m, HasEnvConfig r)+    => SourceMap     -> InstalledMap     -> [PackageName]     -> [PackageName]+    -> Maybe (Map PackageName (Set (Path Abs File)))     -> PackageName     -> Path Abs File     -> SimpleTarget     -> m GhciPkgInfo-makeGhciPkgInfo boptsCli sourceMap installedMap locals addPkgs name cabalfp target = do+makeGhciPkgInfo sourceMap installedMap locals addPkgs mfileTargets name cabalfp target = do     bopts <- asks (configBuild . getConfig)     econfig <- asks getEnvConfig     bconfig <- asks getBuildConfig@@ -415,8 +558,8 @@             PackageConfig             { packageConfigEnableTests = True             , packageConfigEnableBenchmarks = True-            , packageConfigFlags = getLocalFlags bconfig boptsCli name-            , packageConfigGhcOptions = getGhcOptions bconfig boptsCli name True True+            , packageConfigFlags = getLocalFlags bconfig defaultBuildOptsCLI name+            , packageConfigGhcOptions = getGhcOptions bconfig defaultBuildOptsCLI name True True             , packageConfigCompilerVersion = envConfigCompilerVersion econfig             , packageConfigPlatform = configPlatform (getConfig bconfig)             }@@ -432,7 +575,7 @@     mbuildinfo <- forM mbuildinfofp readDotBuildinfo     let pkg =             packageFromPackageDescription config gpkgdesc $-            maybe id (updatePackageDescription) mbuildinfo $+            maybe id C.updatePackageDescription mbuildinfo $             resolvePackageDescription config gpkgdesc      mapM_ (printCabalFileWarning cabalfp) warnings@@ -450,6 +593,7 @@         , ghciPkgModFiles = mconcat (M.elems (filterWanted (M.map (setMapMaybe dotCabalModulePath) files)))         , ghciPkgMainIs = M.map (setMapMaybe dotCabalMainPath) files         , ghciPkgCFiles = mconcat (M.elems (filterWanted (M.map (setMapMaybe dotCabalCFilePath) files)))+        , ghciPkgTargetFiles = mfileTargets >>= M.lookup name         , ghciPkgPackage = pkg         } @@ -550,7 +694,7 @@     duplicates = filter (not . null . tail . snd) allModules     allModules =         M.toList $ M.fromListWith (++) $-        concatMap (\pkg -> map (, [ghciPkgName pkg]) (map display (S.toList (ghciPkgModules pkg)))) pkgs+        concatMap (\pkg -> map ((, [ghciPkgName pkg]) . C.display) (S.toList (ghciPkgModules pkg))) pkgs  -- Adds in intermediate dependencies between ghci targets. Note that it -- will return a Lib component for these intermediate dependencies even@@ -569,7 +713,7 @@     (\mp -> foldl' (flip M.delete) mp (map fst targets)) $     M.mapMaybe id $     execState (mapM_ (mapM_ go . getDeps . fst) targets)-              (M.fromList (map (\(k, x) -> (k, Just x)) targets))+              (M.fromList (map (second Just) targets))   where     getDeps :: PackageName -> [PackageName]     getDeps name =@@ -617,6 +761,24 @@         ] #endif +unionSimpleTargets :: Ord k => Map k SimpleTarget -> Map k SimpleTarget -> Map k SimpleTarget+unionSimpleTargets = M.unionWith $ \l r ->+    case (l, r) of+        (STUnknown, _) -> r+        (STNonLocal, _) -> r+        (STLocalComps sl, STLocalComps sr) -> STLocalComps (S.union sl sr)+        (STLocalComps _, STLocalAll) -> STLocalAll+        (STLocalComps _, _) -> l+        (STLocalAll, _) -> STLocalAll++hasLocalComp :: (NamedComponent -> Bool) -> SimpleTarget -> Bool+hasLocalComp p t =+    case t of+        STLocalComps s -> any p (S.toList s)+        STLocalAll -> True+        _ -> False++ {- Copied from Stack.Ide, may be useful in the future  -- | Get options and target files for the given package info.@@ -639,6 +801,7 @@             maybe [] (\cabalMacros -> ["-optP-include", "-optP" <> toFilePath cabalMacros]) (bioCabalMacros bio)     return         ( ("--dist-dir=" <> toFilePathNoTrailingSep dist) :+          -- FIXME: use compilerOptionsCabalFlag           map ("--ghc-option=" ++) (concatMap (ghcOptions . snd) (ghciPkgOpts pkg))         , mapMaybe               (fmap toFilePath . stripDir pwd)
src/Stack/Ghci/Script.hs view
@@ -14,7 +14,7 @@   , scriptToFile   ) where -import           Control.Exception+import           Control.Applicative import           Data.ByteString.Lazy (ByteString) import           Data.ByteString.Builder import           Data.Monoid@@ -24,6 +24,7 @@ import           Data.Text (Text) import           Data.Text.Encoding (encodeUtf8Builder) import           Path+import           Prelude -- Fix redundant imports warnings import           System.IO  import           Distribution.ModuleName hiding (toFilePath)@@ -63,7 +64,7 @@  scriptToFile :: Path Abs File -> GhciScript -> IO () scriptToFile path script =-  bracket (openFile filepath WriteMode) hClose+  withFile filepath WriteMode     $ \hdl -> do hSetBuffering hdl (BlockBuffering Nothing)                  hSetBinaryMode hdl True                  hPutBuilder hdl (scriptToBuilder script)@@ -81,9 +82,8 @@   | S.null modules = mempty   | otherwise      =        fromText ":add "-    <> (mconcat $ intersperse (fromText " ")-        $ fmap (stringUtf8 . quoteFileName . mconcat . intersperse "." . components)-        $ S.toAscList modules)+    <> mconcat (intersperse (fromText " ")+        $ (stringUtf8 . quoteFileName . mconcat . intersperse "." . components) <$> S.toAscList modules)     <> fromText "\n"  commandToBuilder (AddFile path) =@@ -96,14 +96,10 @@   | S.null modules = fromText ":module +\n"   | otherwise      =        fromText ":module + "-    <> (mconcat $ intersperse (fromText " ")-        $ fmap (stringUtf8 . quoteFileName . mconcat . intersperse "." . components)-        $ S.toAscList modules)+    <> mconcat (intersperse (fromText " ")+        $ (stringUtf8 . quoteFileName . mconcat . intersperse "." . components) <$> S.toAscList modules)     <> fromText "\n"  -- | Make sure that a filename with spaces in it gets the proper quotes. quoteFileName :: String -> String-quoteFileName x =-    if any (==' ') x-        then show x-        else x+quoteFileName x = if ' ' `elem` x then show x else x
src/Stack/Hoogle.hs view
@@ -150,12 +150,12 @@         dbpath <- hoogleDatabasePath         let databaseArg = ["--database=" ++ toFilePath dbpath]         runCmd-            (Cmd+            Cmd              { cmdDirectoryToRunIn = Nothing              , cmdCommandToRun = "hoogle"              , cmdEnvOverride = menv              , cmdCommandLineArguments = hoogleArgs ++ databaseArg-             })+             }             Nothing     bail :: StackT EnvConfig IO ()     bail = liftIO (exitWith (ExitFailure (-1)))
src/Stack/IDE.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}@@ -8,7 +10,6 @@     , listTargets     ) where -import           Control.Monad.Catch import           Control.Monad.Logger import           Control.Monad.Reader import qualified Data.Map as Map@@ -16,29 +17,27 @@ import qualified Data.Text as T import           Stack.Build.Source (getLocalPackageViews) import           Stack.Build.Target (LocalPackageView(..))+import           Stack.Config (getLocalPackages) import           Stack.Package (findOrGenerateCabalFile) import           Stack.Types.Config import           Stack.Types.Package import           Stack.Types.PackageName+import           Stack.Types.StackT  -- | List the packages inside the current project.-listPackages-    :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m, MonadLogger m)-    => m ()+listPackages :: (StackM env m, HasEnvConfig env) => m () listPackages = do     -- TODO: Instead of setting up an entire EnvConfig only to look up the package directories,     -- make do with a Config (and the Project inside) and use resolvePackageEntry to get     -- the directory.-    packageDirs <- asks (Map.keys . envConfigPackages . getEnvConfig)+    packageDirs <- liftM Map.keys getLocalPackages     forM_ packageDirs $ \dir -> do         cabalfp <- findOrGenerateCabalFile dir         pkgName <- parsePackageNameFromFilePath cabalfp         ($logInfo . packageNameText) pkgName  -- | List the targets in the current project.-listTargets-    :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m, MonadLogger m)-    => m ()+listTargets :: (StackM env m, HasEnvConfig env) => m () listTargets =     do rawLocals <- getLocalPackageViews        $logInfo
src/Stack/Image.hs view
@@ -15,9 +15,7 @@ import           Control.Monad import           Control.Monad.Catch hiding (bracket) import           Control.Monad.IO.Class-import           Control.Monad.Logger import           Control.Monad.Reader-import           Control.Monad.Trans.Control import           Data.Char (toLower) import qualified Data.Map.Strict as Map import           Data.Maybe@@ -30,17 +28,13 @@ import           Stack.Constants import           Stack.Types.Config import           Stack.Types.Image-import           Stack.Types.Internal+import           Stack.Types.StackT import           System.Process.Run -type Build e m = (HasBuildConfig e, HasConfig e, HasEnvConfig e, HasTerminal e, MonadBaseControl IO m, MonadCatch m, MonadIO m, MonadLogger m, MonadReader e m)--type Assemble e m = (HasConfig e, HasTerminal e, MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m, MonadReader e m)- -- | Stages the executables & additional content in a staging -- directory under '.stack-work' stageContainerImageArtifacts-    :: Build e m+    :: (StackM env m, HasEnvConfig env)     => Maybe (Path Abs Dir) -> [Text] -> m () stageContainerImageArtifacts mProjectRoot imageNames = do     config <- asks getConfig@@ -63,7 +57,7 @@ -- extended with an ENTRYPOINT specified for each `entrypoint` listed -- in the config file. createContainerImageFromStage-    :: Assemble e m+    :: (StackM env m, HasConfig env)     => Maybe (Path Abs Dir) -> [Text] -> m () createContainerImageFromStage mProjectRoot imageNames = do     config <- asks getConfig@@ -89,7 +83,7 @@ -- | Stage all the Package executables in the usr/local/bin -- subdirectory of a temp directory. stageExesInDir-    :: Build e m+    :: (StackM env m, HasEnvConfig env)     => ImageDockerOpts -> Path Abs Dir -> m () stageExesInDir opts dir = do     srcBinPath <- fmap (</> $(mkRelDir "bin")) installationRootLocal@@ -108,7 +102,7 @@ -- | Add any additional files into the temp directory, respecting the -- (Source, Destination) mapping. syncAddContentToDir-    :: Build e m+    :: (StackM env m, HasEnvConfig env)     => ImageDockerOpts -> Path Abs Dir -> m () syncAddContentToDir opts dir = do     bconfig <- asks getBuildConfig@@ -129,7 +123,7 @@ -- | Create a general purpose docker image from the temporary -- directory of executables & static content. createDockerImage-    :: Assemble e m+    :: (StackM env m, HasConfig env)     => ImageDockerOpts -> Path Abs Dir -> m () createDockerImage dockerConfig dir = do     menv <- getMinimalEnvOverride@@ -151,7 +145,7 @@  -- | Extend the general purpose docker image with entrypoints (if specified). extendDockerImageWithEntrypoint-    :: Assemble e m+    :: (StackM env m, HasConfig env)     => ImageDockerOpts -> Path Abs Dir -> m () extendDockerImageWithEntrypoint dockerConfig dir = do     menv <- getMinimalEnvOverride
src/Stack/Init.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-}@@ -7,59 +8,54 @@     , InitOpts (..)     ) where -import           Control.Exception               (assert)-import           Control.Exception.Enclosed      (catchAny)+import           Control.Exception (assert)+import           Control.Exception.Safe (catchAny) import           Control.Monad-import           Control.Monad.Catch             (MonadMask, throwM)+import           Control.Monad.Catch (throwM) import           Control.Monad.IO.Class import           Control.Monad.Logger-import           Control.Monad.Reader            (MonadReader, asks)-import           Control.Monad.Trans.Control     (MonadBaseControl)-import qualified Data.ByteString.Builder         as B-import qualified Data.ByteString.Char8           as BC-import qualified Data.ByteString.Lazy            as L-import qualified Data.Foldable                   as F-import           Data.Function                   (on)-import qualified Data.HashMap.Strict             as HM-import qualified Data.IntMap                     as IntMap+import           Control.Monad.Reader (asks)+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as L+import qualified Data.Foldable as F+import           Data.Function (on)+import qualified Data.HashMap.Strict as HM+import qualified Data.IntMap as IntMap import           Data.List                       ( intercalate, intersect                                                  , maximumBy)-import           Data.List.NonEmpty              (NonEmpty(..))-import qualified Data.List.NonEmpty              as NonEmpty-import           Data.Map                        (Map)-import qualified Data.Map                        as Map+import           Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import           Data.Map (Map)+import qualified Data.Map as Map import           Data.Maybe import           Data.Monoid-import qualified Data.Text                       as T-import qualified Data.Yaml                       as Yaml+import qualified Data.Text as T+import qualified Data.Yaml as Yaml import qualified Distribution.PackageDescription as C-import qualified Distribution.Text               as C-import qualified Distribution.Version            as C-import           Network.HTTP.Client.Conduit     (HasHttpManager)+import qualified Distribution.Text as C+import qualified Distribution.Version as C import           Path import           Path.IO-import qualified Paths_stack                     as Meta+import qualified Paths_stack as Meta import           Stack.BuildPlan import           Stack.Config                    (getSnapshots,                                                   makeConcreteResolver) import           Stack.Constants import           Stack.Solver+import           Stack.Types.Build import           Stack.Types.BuildPlan+import           Stack.Types.Config import           Stack.Types.FlagName import           Stack.Types.PackageName+import           Stack.Types.Resolver+import           Stack.Types.StackT (StackM) import           Stack.Types.Version-import           Stack.Types.Config-import           Stack.Types.Build-import           Stack.Types.Internal            (HasLogLevel, HasReExec,-                                                  HasTerminal)-import qualified System.FilePath                 as FP+import qualified System.FilePath as FP  -- | Generate stack.yaml initProject-    :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m-       , MonadReader env m, HasConfig env , HasGHCVariant env-       , HasHttpManager env , HasLogLevel env , HasReExec env-       , HasTerminal env)+    :: (StackM env m, HasConfig env, HasGHCVariant env)     => WhichSolverCmd     -> Path Abs Dir     -> InitOpts@@ -90,21 +86,21 @@      let ignored = Map.difference bundle rbundle         dupPkgMsg-            | (dupPkgs /= []) =+            | dupPkgs /= [] =                 "Warning (added by new or init): Some packages were found to \                 \have names conflicting with others and have been commented \                 \out in the packages section.\n"             | otherwise = ""          missingPkgMsg-            | (Map.size ignored > 0) =+            | Map.size ignored > 0 =                 "Warning (added by new or init): Some packages were found to \                 \be incompatible with the resolver and have been left commented \                 \out in the packages section.\n"             | otherwise = ""          extraDepMsg-            | (Map.size extraDeps > 0) =+            | Map.size extraDeps > 0 =                 "Warning (added by new or init): Specified resolver could not \                 \satisfy all dependencies. Some external packages have been \                 \added as dependencies.\n"@@ -141,7 +137,7 @@          pkgs = map toPkg $ Map.elems (fmap (parent . fst) rbundle)         toPkg dir = PackageEntry-            { peExtraDep = False+            { peExtraDepMaybe = Nothing             , peLocation = PLFilePath $ makeRelDir dir             , peSubdirs = []             }@@ -149,24 +145,24 @@      $logInfo $ "Initialising configuration using resolver: " <> resolverName r     $logInfo $ "Total number of user packages considered: "-               <> (T.pack $ show $ (Map.size bundle + length dupPkgs))+               <> T.pack (show (Map.size bundle + length dupPkgs))      when (dupPkgs /= []) $ do         $logWarn $ "Warning! Ignoring "-                   <> (T.pack $ show $ length dupPkgs)+                   <> T.pack (show $ length dupPkgs)                    <> " duplicate packages:"         rels <- mapM makeRel dupPkgs         $logWarn $ indent $ showItems rels      when (Map.size ignored > 0) $ do         $logWarn $ "Warning! Ignoring "-                   <> (T.pack $ show $ Map.size ignored)+                   <> T.pack (show $ Map.size ignored)                    <> " packages due to dependency conflicts:"         rels <- mapM makeRel (Map.elems (fmap fst ignored))-        $logWarn $ indent $ showItems $ rels+        $logWarn $ indent $ showItems rels      when (Map.size extraDeps > 0) $ do-        $logWarn $ "Warning! " <> (T.pack $ show $ Map.size extraDeps)+        $logWarn $ "Warning! " <> T.pack (show $ Map.size extraDeps)                    <> " external dependencies were added."     $logInfo $         (if exists then "Overwriting existing configuration file: "@@ -201,7 +197,7 @@                 B.byteString comment <>                 B.byteString "\n" <>                 B.byteString (Yaml.encode $ Yaml.object [(name, v)]) <>-                if (name == "packages") then commentedPackages else "" <>+                if name == "packages" then commentedPackages else "" <>                 B.byteString "\n"      commentLine l | null l = "#"@@ -224,8 +220,8 @@         | pkgs /= [] =                B.byteString comment             <> B.byteString "\n"-            <> (B.byteString $ BC.pack $ concat-                 $ (map (\x -> "#- " ++ x ++ "\n") pkgs) ++ ["\n"])+            <> B.byteString (BC.pack $ concat+                 $ map (\x -> "#- " ++ x ++ "\n") pkgs ++ ["\n"])         | otherwise = ""      goOthers o@@ -313,7 +309,7 @@         , "compiler-check: newer-minor"         ] -getSnapshots' :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)+getSnapshots' :: (StackM env m, HasConfig env)               => m Snapshots getSnapshots' =     getSnapshots `catchAny` \e -> do@@ -335,10 +331,7 @@  -- | Get the default resolver value getDefaultResolver-    :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m-       , MonadReader env m, HasConfig env , HasGHCVariant env-       , HasHttpManager env , HasLogLevel env , HasReExec env-       , HasTerminal env)+    :: (StackM env m, HasConfig env, HasGHCVariant env)     => WhichSolverCmd     -> Path Abs File   -- ^ stack.yaml     -> InitOpts@@ -368,10 +361,7 @@                 _ -> return $ ResolverSnapshot s  getWorkingResolverPlan-    :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m-       , MonadReader env m, HasConfig env , HasGHCVariant env-       , HasHttpManager env , HasLogLevel env , HasReExec env-       , HasTerminal env)+    :: (StackM env m, HasConfig env, HasGHCVariant env)     => WhichSolverCmd     -> Path Abs File   -- ^ stack.yaml     -> InitOpts@@ -402,7 +392,7 @@                                  \config anyway."                         return (resolver, Map.empty, Map.empty, Map.empty)                     | otherwise -> do-                        when ((Map.size available) == (Map.size info)) $+                        when (Map.size available == Map.size info) $                             error "Bug: No packages to ignore"                          if length ignored > 1 then do@@ -410,19 +400,16 @@                           $logWarn $ indent $ showItems ignored                         else                           $logWarn $ "*** Ignoring package: "-                                 <> (T.pack $ packageNameString (head ignored))+                                 <> T.pack (packageNameString (head ignored))                          go available                     where                       indent t   = T.unlines $ fmap ("    " <>) (T.lines t)-                      isAvailable k _ = not (k `elem` ignored)+                      isAvailable k _ = k `notElem` ignored                       available       = Map.filterWithKey isAvailable info  checkBundleResolver-    :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m-       , MonadReader env m, HasConfig env , HasGHCVariant env-       , HasHttpManager env , HasLogLevel env , HasReExec env-       , HasTerminal env)+    :: (StackM env m, HasConfig env, HasGHCVariant env)     => WhichSolverCmd     -> Path Abs File   -- ^ stack.yaml     -> InitOpts@@ -475,7 +462,7 @@                       pkg <- findOneIndependent srcpkgs flags                       return $ Left [pkg]                   | otherwise -> throwM (SolverGiveUp giveUpMsg)-                  where srcpkgs = intersect (Map.keys bundle) packages+                  where srcpkgs = Map.keys bundle `intersect` packages        -- among a list of packages find one on which none among the rest of the       -- packages depend. This package is a good candidate to be removed from@@ -488,8 +475,8 @@               getFlags pkg = fromJust (Map.lookup pkg flags)               deps pkg = gpdPackageDeps (getGpd pkg) compiler platform                                         (getFlags pkg)-              allDeps = concat $ map (Map.keys . deps) packages-              isIndependent pkg = not $ pkg `elem` allDeps+              allDeps = concatMap (Map.keys . deps) packages+              isIndependent pkg = pkg `notElem` allDeps                -- prefer to reject packages in deeper directories               path pkg = fst (fromJust (Map.lookup pkg bundle))@@ -507,11 +494,11 @@           , "    - Update external packages with 'stack update' and try again.\n"           ] -      needSolver _ (InitOpts {useSolver = True}) = True+      needSolver _ InitOpts {useSolver = True} = True       needSolver (ResolverCompiler _)  _ = True       needSolver _ _ = False -getRecommendedSnapshots :: Snapshots -> (NonEmpty SnapName)+getRecommendedSnapshots :: Snapshots -> NonEmpty SnapName getRecommendedSnapshots snapshots =     -- in order - Latest LTS, Latest Nightly, all LTS most recent first     case NonEmpty.nonEmpty ltss of
src/Stack/New.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}@@ -26,7 +27,6 @@ import           Data.Aeson import           Data.Aeson.Types import qualified Data.ByteString.Lazy as LB-import qualified Data.ByteString.Lazy.Char8 as L8 import           Data.Conduit import           Data.Foldable (asum) import qualified Data.HashMap.Strict as HM@@ -47,15 +47,15 @@ import           Data.Time.Clock import           Data.Typeable import qualified Data.Yaml as Yaml-import           Network.HTTP.Client.Conduit hiding (path) import           Network.HTTP.Download-import           Network.HTTP.Types.Status+import           Network.HTTP.Simple import           Path import           Path.IO import           Prelude import           Stack.Constants-import           Stack.Types.PackageName import           Stack.Types.Config+import           Stack.Types.PackageName+import           Stack.Types.StackT import           Stack.Types.TemplateName import           System.Process.Run import           Text.Hastache@@ -80,7 +80,7 @@  -- | Create a new project with the given options. new-    :: (HasConfig r, MonadReader r m, MonadLogger m, MonadCatch m, MonadIO m, HasHttpManager r)+    :: (StackM env m, HasConfig env)     => NewOpts -> Bool -> m (Path Abs Dir) new opts forceOverwrite = do     pwd <- getCurrentDir@@ -129,16 +129,15 @@  -- | Download and read in a template's text content. loadTemplate-    :: forall m r.-       (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadCatch m, MonadLogger m)+    :: forall env m. (StackM env m, HasConfig env)     => TemplateName -> (TemplateFrom -> m ()) -> m Text loadTemplate name logIt = do     templateDir <- asks (templatesDir . getConfig)     case templatePath name of         AbsPath absFile -> logIt LocalTemp >> loadLocalFile absFile         UrlPath s -> do-            let req = parseRequest_ s-                rel = fromMaybe backupUrlRelPath (parseRelFile s)+            req <- parseRequest s+            let rel = fromMaybe backupUrlRelPath (parseRelFile s)             downloadTemplate req (templateDir </> rel)         RelPath relFile ->             catch@@ -174,7 +173,7 @@  -- | Apply and unpack a template into a directory. applyTemplate-    :: (MonadIO m, MonadCatch m, MonadReader r m, HasConfig r, MonadLogger m)+    :: (StackM env m, HasConfig env)     => PackageName     -> TemplateName     -> Map Text Text@@ -189,7 +188,11 @@       return $ T.pack . show $ year     let context = M.union (M.union nonceParams extraParams) configParams           where+            nameAsVarId = T.replace "-" "_" $ packageNameText project+            nameAsModule = T.filter (/= '-') $ T.toTitle $ packageNameText project             extraParams = M.fromList [ ("name", packageNameText project)+                                     , ("name-as-varid", nameAsVarId)+                                     , ("name-as-module", nameAsModule)                                      , ("year", currentYear) ]             configParams = configTemplateParams config     (applied,missingKeys) <-@@ -256,7 +259,7 @@  -- | Run any initialization functions, such as Git. runTemplateInits-    :: (MonadIO m, MonadReader r m, HasConfig r, MonadLogger m, MonadCatch m)+    :: (StackM env m, HasConfig env)     => Path Abs Dir -> m () runTemplateInits dir = do     menv <- getMinimalEnvOverride@@ -269,9 +272,7 @@                          $logInfo "git init failed to run, ignoring ...")  -- | Display the set of templates accompanied with description if available.-listTemplates-    :: (MonadIO m, MonadReader r m, HasHttpManager r, MonadCatch m)-    => m ()+listTemplates :: StackM env m => m () listTemplates = do     templates <- getTemplates     templateInfo <- getTemplateInfo@@ -288,49 +289,37 @@       else mapM_ (liftIO . T.putStrLn . templateName) (S.toList templates)  -- | Get the set of templates.-getTemplates-    :: (MonadIO m, MonadReader r m, HasHttpManager r, MonadCatch m)-    => m (Set TemplateName)+getTemplates :: StackM env m => m (Set TemplateName) getTemplates = do-    req <- liftM addHeaders (parseUrlThrow defaultTemplatesList)-    resp <- catch (httpLbs req) (throwM . FailedToDownloadTemplates)-    case statusCode (responseStatus resp) of-        200 ->-            case eitherDecode (responseBody resp) >>=-                 parseEither parseTemplateSet of-                Left err -> throwM (BadTemplatesJSON err (responseBody resp))-                Right value -> return value+    req <- liftM setGithubHeaders (parseUrlThrow defaultTemplatesList)+    resp <- catch (httpJSON req) (throwM . FailedToDownloadTemplates)+    case getResponseStatusCode resp of+        200 -> return $ unTemplateSet $ getResponseBody resp         code -> throwM (BadTemplatesResponse code) -getTemplateInfo-    :: (MonadIO m, MonadReader r m, HasHttpManager r, MonadCatch m)-    => m (Map Text TemplateInfo)+getTemplateInfo :: StackM env m => m (Map Text TemplateInfo) getTemplateInfo = do-  req <- liftM addHeaders (parseUrlThrow defaultTemplateInfoUrl)+  req <- liftM setGithubHeaders (parseUrlThrow defaultTemplateInfoUrl)   resp <- catch (liftM Right $ httpLbs req) (\(ex :: HttpException) -> return . Left $ "Failed to download template info. The HTTP error was: " <> show ex)   case resp >>= is200 of     Left err -> do       liftIO . putStrLn $ err       return M.empty     Right resp' ->-      case Yaml.decodeEither (LB.toStrict $ responseBody resp') :: Either String Object of+      case Yaml.decodeEither (LB.toStrict $ getResponseBody resp') :: Either String Object of         Left err ->           throwM $ BadTemplateInfo err         Right o ->           return (M.mapMaybe (Yaml.parseMaybe Yaml.parseJSON) (M.fromList . HM.toList $ o) :: Map Text TemplateInfo)   where     is200 resp =-      if statusCode (responseStatus resp) == 200-        then return resp-        else Left $ "Unexpected status code while retrieving templates info: " <> show (statusCode $ responseStatus resp)+      case getResponseStatusCode resp of+        200 -> return resp+        code -> Left $ "Unexpected status code while retrieving templates info: " <> show code -addHeaders :: Request -> Request-addHeaders req =-  req-    { requestHeaders = [ ("User-Agent", "The Haskell Stack")-                       , ("Accept", "application/vnd.github.v3+json")] <>-      requestHeaders req-    }+newtype TemplateSet = TemplateSet { unTemplateSet :: Set TemplateName }+instance FromJSON TemplateSet where+  parseJSON = fmap TemplateSet . parseTemplateSet  -- | Parser the set of templates from the JSON. parseTemplateSet :: Value -> Parser (Set TemplateName)@@ -381,7 +370,6 @@                                !DownloadException     | FailedToDownloadTemplates !HttpException     | BadTemplatesResponse !Int-    | BadTemplatesJSON !String !LB.ByteString     | AlreadyExists !(Path Abs Dir)     | MissingParameters !PackageName !TemplateName !(Set String) !(Path Abs File)     | InvalidTemplate !TemplateName !String@@ -399,25 +387,19 @@         " from " <>         path     show (FailedToDownloadTemplate name (RedownloadFailed _ _ resp)) =-        case statusCode (responseStatus resp) of+        case getResponseStatusCode resp of             404 ->                 "That template doesn't exist. Run `stack templates' to see a list of available templates."             code ->                 "Failed to download template " <> T.unpack (templateName name) <>                 ": unknown reason, status code was: " <>                 show code-    show (FailedToDownloadTemplate name _) =-        "Failed to download template " <> T.unpack (templateName name) <>-        ", reason unknown."     show (AlreadyExists path) =         "Directory " <> toFilePath path <> " already exists. Aborting."     show (FailedToDownloadTemplates ex) =         "Failed to download templates. The HTTP error was: " <> show ex     show (BadTemplatesResponse code) =         "Unexpected status code while retrieving templates list: " <> show code-    show (BadTemplatesJSON err bytes) =-        "Github returned some JSON that couldn't be parsed: " <> err <> "\n\n" <>-        L8.unpack bytes     show (MissingParameters name template missingKeys userConfigPath) =         intercalate             "\n"
src/Stack/Nix.hs view
@@ -11,65 +11,64 @@   ,nixHelpOptName   ) where -import           Control.Applicative import           Control.Arrow ((***)) import           Control.Exception (Exception,throw) import           Control.Monad hiding (mapM)-import           Control.Monad.Catch (MonadMask)-import           Control.Monad.IO.Class (MonadIO,liftIO)-import           Control.Monad.Logger (MonadLogger,logDebug)-import           Control.Monad.Reader (MonadReader,asks)-import           Control.Monad.Trans.Control (MonadBaseControl)-import           Data.Char (toUpper)-import           Data.List (intercalate)+import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.Logger (logDebug)+import           Control.Monad.Reader (asks) import           Data.Maybe import           Data.Monoid import qualified Data.Text as T import           Data.Traversable import           Data.Typeable (Typeable) import           Data.Version (showVersion)-import           Network.HTTP.Client.Conduit (HasHttpManager) import           Path import           Path.IO import qualified Paths_stack as Meta import           Prelude hiding (mapM) -- Fix redundant import warnings+import           Stack.Config (getInNixShell, getInContainer) import           Stack.Config.Nix (nixCompiler)-import           Stack.Constants (stackProgName,platformVariantEnvVar)+import           Stack.Constants (platformVariantEnvVar,inNixShellEnvVar,inContainerEnvVar) import           Stack.Exec (exec) import           Stack.Types.Config import           Stack.Types.Docker import           Stack.Types.Nix import           Stack.Types.Compiler import           Stack.Types.Internal-import           System.Environment (lookupEnv,getArgs,getExecutablePath)+import           Stack.Types.StackT+import           System.Environment (getArgs,getExecutablePath,lookupEnv)+import qualified System.FilePath  as F import           System.Process.Read (getEnvOverride)  -- | If Nix is enabled, re-runs the currently running OS command in a Nix container. -- Otherwise, runs the inner action. reexecWithOptionalShell-    :: M env m+    :: (StackM env m, HasConfig env)     => Maybe (Path Abs Dir)     -> IO CompilerVersion     -> IO ()     -> m () reexecWithOptionalShell mprojectRoot getCompilerVersion inner =   do config <- asks getConfig-     inShell <- getInShell+     inShell <- getInNixShell+     inContainer <- getInContainer      isReExec <- asks getReExec-     if nixEnable (configNix config) && not inShell && not isReExec-       then runShellAndExit mprojectRoot getCompilerVersion getCmdArgs-       else liftIO inner-  where-    getCmdArgs = do-        args <--            fmap-                (("--" ++ reExecArgName ++ "=" ++ showVersion Meta.version) :)-                (liftIO getArgs)-        exePath <- liftIO getExecutablePath-        return (exePath, args)+     let getCmdArgs = do+           origArgs <- liftIO getArgs+           let args | inContainer = origArgs  -- internal-re-exec version already passed+                      -- first stack when restarting in the container+                    | otherwise =+                        ("--" ++ reExecArgName ++ "=" ++ showVersion Meta.version) : origArgs+           exePath <- liftIO getExecutablePath+           return (exePath, args)+     if nixEnable (configNix config) && not inShell && (not isReExec || inContainer)+        then runShellAndExit mprojectRoot getCompilerVersion getCmdArgs+        else liftIO inner + runShellAndExit-    :: M env m+    :: (StackM env m, HasConfig env)     => Maybe (Path Abs Dir)     -> IO CompilerVersion     -> m (String, [String])@@ -82,11 +81,13 @@          traverse (resolveFile (fromMaybeProjectRoot mprojectRoot)) $          nixInitFile (configNix config)      compilerVersion <- liftIO getCompilerVersion+     inContainer <- getInContainer      let pkgsInConfig = nixPackages (configNix config)          ghc = nixCompiler compilerVersion          pkgs = pkgsInConfig ++ [ghc]          pkgsStr = "[" <> T.intercalate " " pkgs <> "]"          pureShell = nixPureShell (configNix config)+         addGCRoots = nixAddGCRoots (configNix config)          nixopts = case mshellFile of            Just fp -> [toFilePath fp, "--arg", "ghc"                       ,"with (import <nixpkgs> {}); " ++ T.unpack ghc]@@ -94,32 +95,40 @@                               ["with (import <nixpkgs> {}); "                               ,"let inputs = ",pkgsStr,"; "                               ,    "libPath = lib.makeLibraryPath inputs; "-                              ,    "stackExtraArgs = lib.concatStrings ("-                              ,      "lib.foldl' (acc: p: acc ++ [\" --extra-lib-dirs \" p]) [] "-                              ,        "(lib.splitString '':'' libPath) ++ "-                              ,      "lib.foldl' (acc: p: acc ++ [\" --extra-include-dirs \" p]) [] "-                              ,        "(lib.splitString '':'' (lib.makeSearchPathOutput ''dev'' ''include'' inputs))"-                              ,    "); in "+                              ,    "stackExtraArgs = lib.concatMap (pkg: "+                              ,    "[ ''--extra-lib-dirs=${lib.getLib pkg}/lib'' "+                              ,    "  ''--extra-include-dirs=${lib.getDev pkg}/include'' ]"+                              ,    ") inputs; in "                               ,"runCommand ''myEnv'' { "                               ,"buildInputs = lib.optional stdenv.isLinux glibcLocales ++ inputs; "                               ,T.pack platformVariantEnvVar <> "=''nix''; "-                              ,T.pack inShellEnvVar <> "=1; "+                              ,T.pack inNixShellEnvVar <> "=1; "+                              ,if inContainer+                                  -- If shell is pure, this env var would not+                                  -- be seen by stack inside nix+                                  then T.pack inContainerEnvVar <> "=1; "+                                  else ""                               ,"LD_LIBRARY_PATH = libPath;"  -- LD_LIBRARY_PATH is set because for now it's                                -- needed by builds using Template Haskell                               ,"STACK_IN_NIX_EXTRA_ARGS = stackExtraArgs; "                               ,"} \"\""]]                     -- glibcLocales is necessary on Linux to avoid warnings about GHC being incapable to set the locale.-         fullArgs = concat [if pureShell then ["--pure"] else [],-                            map T.unpack (nixShellOptions (configNix config))+         fullArgs = concat [if pureShell then ["--pure"] else []+                           ,if addGCRoots then ["--indirect", "--add-root"+                                               ,toFilePath (configWorkDir config)+                                                F.</> "nix-gc-symlinks" F.</> "gc-root"] else []+                           ,map T.unpack (nixShellOptions (configNix config))                            ,nixopts-                           ,["--run", intercalate " " (cmnd:"$STACK_IN_NIX_EXTRA_ARGS":args)]+                           ,["--run", unwords (cmnd:"$STACK_IN_NIX_EXTRA_ARGS":args)]                            ]                            -- Using --run instead of --command so we cannot                            -- end up in the nix-shell if stack build is Ctrl-C'd+     pathVar <- liftIO $ lookupEnv "PATH"+     $logDebug $ "PATH is: " <> T.pack (show pathVar)      $logDebug $-         "Using a nix-shell environment " <> (case mshellFile of-            Just path -> "from file: " <> (T.pack (toFilePath path))-            Nothing -> "with nix packages: " <> (T.intercalate ", " pkgs))+       "Using a nix-shell environment " <> (case mshellFile of+            Just path -> "from file: " <> T.pack (toFilePath path)+            Nothing -> "with nix packages: " <> T.intercalate ", " pkgs)      exec envOverride "nix-shell" fullArgs  -- | Shell-escape quotes inside the string and enclose it in quotes.@@ -133,16 +142,6 @@ fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRoot) --- | 'True' if we are currently running inside a Nix.-getInShell :: (MonadIO m) => m Bool-getInShell = liftIO (isJust <$> lookupEnv inShellEnvVar)---- | Environment variable used to indicate stack is running in container.--- although we already have STACK_IN_NIX_EXTRA_ARGS that is set in the same conditions,--- it can happen that STACK_IN_NIX_EXTRA_ARGS is set to empty.-inShellEnvVar :: String-inShellEnvVar = concat [map toUpper stackProgName,"_IN_NIXSHELL"]- -- | Command-line argument for "nix" nixCmdName :: String nixCmdName = "nix"@@ -161,15 +160,3 @@ instance Show StackNixException where   show CannotDetermineProjectRoot =     "Cannot determine project root directory."--type M env m =-  (MonadIO m-  ,MonadReader env m-  ,MonadLogger m-  ,MonadBaseControl IO m-  ,MonadMask m-  ,HasConfig env-  ,HasTerminal env-  ,HasReExec env-  ,HasHttpManager env-  )
− src/Stack/Options.hs 
@@ -1,988 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}--module Stack.Options-    (BuildCommand(..)-    ,GlobalOptsContext(..)-    ,benchOptsParser-    ,buildOptsParser-    ,cleanOptsParser-    ,configCmdSetParser-    ,configOptsParser-    ,dockerOptsParser-    ,dockerCleanupOptsParser-    ,dotOptsParser-    ,execOptsParser-    ,evalOptsParser-    ,globalOptsParser-    ,initOptsParser-    ,newOptsParser-    ,nixOptsParser-    ,logLevelOptsParser-    ,ghciOptsParser-    ,solverOptsParser-    ,testOptsParser-    ,haddockOptsParser-    ,hpcReportOptsParser-    ,pvpBoundsOption-    ,globalOptsFromMonoid-    ,splitObjsWarning-    ) where--import           Control.Monad.Logger              (LogLevel (..))-import           Data.Char                         (isSpace, toLower, toUpper)-import           Data.List                         (intercalate)-import           Data.List.Split                   (splitOn)-import qualified Data.Map                          as Map-import           Data.Map.Strict                   (Map)-import qualified Data.Map.Strict                   as M-import           Data.Maybe-import           Data.Monoid.Extra-import qualified Data.Set                          as Set-import qualified Data.Text                         as T-import           Data.Text.Read                    (decimal)-import           Data.Version                      (showVersion)-import           Distribution.Version              (anyVersion)-import           Options.Applicative-import           Options.Applicative.Args-import           Options.Applicative.Builder.Extra-import           Options.Applicative.Types         (fromM, oneM, readerAsk)-import           Paths_stack                       as Meta-import           Stack.Build                       (splitObjsWarning)-import           Stack.Clean                       (CleanOpts (..))-import           Stack.Config                      (packagesParser)-import           Stack.ConfigCmd-import           Stack.Constants-import           Stack.Coverage                    (HpcReportOpts (..))-import           Stack.Docker-import qualified Stack.Docker                      as Docker-import           Stack.Dot-import           Stack.Ghci                        (GhciOpts (..))-import           Stack.Init-import           Stack.New-import           Stack.Nix-import           Stack.Types.FlagName-import           Stack.Types.PackageName-import           Stack.Types.Version-import           Stack.Types.Config-import           Stack.Types.Docker-import           Stack.Types.Nix-import           Stack.Types.Compiler-import           Stack.Types.TemplateName---- | Allows adjust global options depending on their context--- Note: This was being used to remove ambibuity between the local and global--- implementation of stack init --resolver option. Now that stack init has no--- local --resolver this is not being used anymore but the code is kept for any--- similar future use cases.-data GlobalOptsContext-    = OuterGlobalOpts -- ^ Global options before subcommand name-    | OtherCmdGlobalOpts -- ^ Global options following any other subcommand-    | BuildCmdGlobalOpts-    deriving (Show, Eq)---- | Parser for bench arguments.--- FIXME hiding options-benchOptsParser :: Bool -> Parser BenchmarkOptsMonoid-benchOptsParser hide0 = BenchmarkOptsMonoid-        <$> optionalFirst (strOption (long "benchmark-arguments" <>-                                 metavar "BENCH_ARGS" <>-                                 help ("Forward BENCH_ARGS to the benchmark suite. " <>-                                       "Supports templates from `cabal bench`") <>-                                 hide))-        <*> optionalFirst (switch (long "no-run-benchmarks" <>-                          help "Disable running of benchmarks. (Benchmarks will still be built.)" <>-                             hide))-   where hide = hideMods hide0---- | Parser for CLI-only build arguments-buildOptsParser :: BuildCommand-                -> Parser BuildOptsCLI-buildOptsParser cmd =-    BuildOptsCLI <$>-    many-        (textArgument-             (metavar "TARGET" <>-              help ("If none specified, use all packages. " <>-                    "See https://docs.haskellstack.org/en/v" <>-                    showVersion Meta.version <>-                    "/build_command/#target-syntax for details."))) <*>-    switch-        (long "dry-run" <>-         help "Don't build anything, just prepare to") <*>-    ((\x y z ->-           concat [x, y, z]) <$>-     flag-         []-         ["-Wall", "-Werror"]-         (long "pedantic" <>-          help "Turn on -Wall and -Werror") <*>-     flag-         []-         ["-O0"]-         (long "fast" <>-          help "Turn off optimizations (-O0)") <*>-     many-         (textOption-              (long "ghc-options" <>-               metavar "OPTION" <>-               help "Additional options passed to GHC"))) <*>-    (Map.unionsWith Map.union <$>-     many-         (option-              readFlag-              (long "flag" <>-               metavar "PACKAGE:[-]FLAG" <>-               help-                   ("Override flags set in stack.yaml " <>-                    "(applies to local packages and extra-deps)")))) <*>-    (flag'-         BSOnlyDependencies-         (long "dependencies-only" <>-          help "A synonym for --only-dependencies") <|>-     flag'-         BSOnlySnapshot-         (long "only-snapshot" <>-          help-              "Only build packages for the snapshot database, not the local database") <|>-     flag'-         BSOnlyDependencies-         (long "only-dependencies" <>-          help-              "Only build packages that are dependencies of targets on the command line") <|>-     pure BSAll) <*>-    (flag'-         FileWatch-         (long "file-watch" <>-          help-              "Watch for changes in local files and automatically rebuild. Ignores files in VCS boring/ignore file") <|>-     flag'-         FileWatchPoll-         (long "file-watch-poll" <>-          help-              "Like --file-watch, but polling the filesystem instead of using events") <|>-     pure NoFileWatch) <*>-    many (cmdOption-             (long "exec" <>-              metavar "CMD [ARGS]" <>-              help "Command and arguments to run after a successful build")) <*>-    switch-        (long "only-configure" <>-         help-             "Only perform the configure step, not any builds. Intended for tool usage, may break when used on multiple packages at once!") <*>-    pure cmd---- | Parser for package:[-]flag-readFlag :: ReadM (Map (Maybe PackageName) (Map FlagName Bool))-readFlag = do-    s <- readerAsk-    case break (== ':') s of-        (pn, ':':mflag) -> do-            pn' <--                case parsePackageNameFromString pn of-                    Nothing-                        | pn == "*" -> return Nothing-                        | otherwise -> readerError $ "Invalid package name: " ++ pn-                    Just x -> return $ Just x-            let (b, flagS) =-                    case mflag of-                        '-':x -> (False, x)-                        _ -> (True, mflag)-            flagN <--                case parseFlagNameFromString flagS of-                    Nothing -> readerError $ "Invalid flag name: " ++ flagS-                    Just x -> return x-            return $ Map.singleton pn' $ Map.singleton flagN b-        _ -> readerError "Must have a colon"---- | Command-line parser for the clean command.-cleanOptsParser :: Parser CleanOpts-cleanOptsParser = CleanShallow <$> packages <|> doFullClean-  where-    packages =-        many-            (packageNameArgument-                 (metavar "PACKAGE" <>-                  help "If none specified, clean all local packages"))-    doFullClean =-        flag'-            CleanFull-            (long "full" <>-             help "Delete all work directories (.stack-work by default) in the project")---- | Command-line arguments parser for configuration.-configOptsParser :: GlobalOptsContext -> Parser ConfigMonoid-configOptsParser hide0 =-    (\stackRoot workDir buildOpts dockerOpts nixOpts systemGHC installGHC arch ghcVariant jobs includes libs overrideGccPath skipGHCCheck skipMsys localBin modifyCodePage allowDifferentUser -> mempty-        { configMonoidStackRoot = stackRoot-        , configMonoidWorkDir = workDir-        , configMonoidBuildOpts = buildOpts-        , configMonoidDockerOpts = dockerOpts-        , configMonoidNixOpts = nixOpts-        , configMonoidSystemGHC = systemGHC-        , configMonoidInstallGHC = installGHC-        , configMonoidSkipGHCCheck = skipGHCCheck-        , configMonoidArch = arch-        , configMonoidGHCVariant = ghcVariant-        , configMonoidJobs = jobs-        , configMonoidExtraIncludeDirs = includes-        , configMonoidExtraLibDirs = libs-        , configMonoidOverrideGccPath = overrideGccPath-        , configMonoidSkipMsys = skipMsys-        , configMonoidLocalBinPath = localBin-        , configMonoidModifyCodePage = modifyCodePage-        , configMonoidAllowDifferentUser = allowDifferentUser-        })-    <$> optionalFirst (absDirOption-            ( long stackRootOptionName-            <> metavar (map toUpper stackRootOptionName)-            <> help ("Absolute path to the global stack root directory " ++-                     "(Overrides any STACK_ROOT environment variable)")-            <> hide-            ))-    <*> optionalFirst (relDirOption-            ( long "work-dir"-            <> metavar "WORK-DIR"-            <> help "Override work directory (default: .stack-work)"-            <> hide-            ))-    <*> buildOptsMonoidParser (hide0 /= BuildCmdGlobalOpts)-    <*> dockerOptsParser True-    <*> nixOptsParser True-    <*> firstBoolFlags-            "system-ghc"-            "using the system installed GHC (on the PATH) if available and a matching version"-            hide-    <*> firstBoolFlags-            "install-ghc"-            "downloading and installing GHC if necessary (can be done manually with stack setup)"-            hide-    <*> optionalFirst (strOption-            ( long "arch"-           <> metavar "ARCH"-           <> help "System architecture, e.g. i386, x86_64"-           <> hide-            ))-    <*> optionalFirst (ghcVariantParser (hide0 /= OuterGlobalOpts))-    <*> optionalFirst (option auto-            ( long "jobs"-           <> short 'j'-           <> metavar "JOBS"-           <> help "Number of concurrent jobs to run"-           <> hide-            ))-    <*> fmap Set.fromList (many (absDirOption-            ( long "extra-include-dirs"-           <> metavar "DIR"-           <> help "Extra directories to check for C header files"-           <> hide-            )))-    <*> fmap Set.fromList (many (absDirOption-            ( long "extra-lib-dirs"-           <> metavar "DIR"-           <> help "Extra directories to check for libraries"-           <> hide-            )))-    <*> optionalFirst (absFileOption-             ( long "with-gcc"-            <> metavar "PATH-TO-GCC"-            <> help "Use gcc found at PATH-TO-GCC"-            <> hide-             ))-    <*> firstBoolFlags-            "skip-ghc-check"-            "skipping the GHC version and architecture check"-            hide-    <*> firstBoolFlags-            "skip-msys"-            "skipping the local MSYS installation (Windows only)"-            hide-    <*> optionalFirst (strOption-             ( long "local-bin-path"-            <> metavar "DIR"-            <> help "Install binaries to DIR"-            <> hide-             ))-    <*> firstBoolFlags-            "modify-code-page"-            "setting the codepage to support UTF-8 (Windows only)"-            hide-    <*> firstBoolFlags-            "allow-different-user"-            ("permission for users other than the owner of the stack root " ++-                "directory to use a stack installation (POSIX only)")-            hide-  where hide = hideMods (hide0 /= OuterGlobalOpts)--buildOptsMonoidParser :: Bool -> Parser BuildOptsMonoid-buildOptsMonoidParser hide0 =-    transform <$> trace <*> profile <*> options-  where-    hide =-        hideMods hide0-    transform tracing profiling =-        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-                }-              }-          | 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" <>-            hide)--    trace =-        flag-            False-            True-            (long "trace" <>-             help-                 "Enable profiling in libraries, executables, etc. \-                    \for all expressions and generate a backtrace on \-                    \exception" <>-            hide)-    options =-        BuildOptsMonoid <$> libProfiling <*> exeProfiling <*> haddock <*>-        haddockOptsParser hide0 <*> openHaddocks <*>-        haddockDeps <*> copyBins <*> preFetch <*> keepGoing <*> forceDirty <*>-        tests <*> testOptsParser hide0 <*> benches <*> benchOptsParser hide0 <*> reconfigure <*>-        cabalVerbose <*> splitObjs-    libProfiling =-        firstBoolFlags-            "library-profiling"-            "library profiling for TARGETs and all its dependencies"-            hide-    exeProfiling =-        firstBoolFlags-            "executable-profiling"-            "executable profiling for TARGETs and all its dependencies"-            hide-    haddock =-        firstBoolFlags-            "haddock"-            "generating Haddocks the package(s) in this directory/configuration"-            hide-    openHaddocks =-        firstBoolFlags-            "open"-            "opening the local Haddock documentation in the browser"-            hide-    haddockDeps =-        firstBoolFlags "haddock-deps" "building Haddocks for dependencies" hide-    copyBins =-        firstBoolFlags-            "copy-bins"-            "copying binaries to the local-bin-path (see 'stack path')"-            hide-    keepGoing =-        firstBoolFlags-            "keep-going"-            "continue running after a step fails (default: false for build, true for test/bench)"-            hide-    preFetch =-        firstBoolFlags-            "prefetch"-             "Fetch packages necessary for the build immediately, useful with --dry-run"-             hide-    forceDirty =-        firstBoolFlags-            "force-dirty"-            "Force treating all local packages as having dirty files (useful for cases where stack can't detect a file change"-            hide-    tests =-        firstBoolFlags-            "test"-            "testing the package(s) in this directory/configuration"-            hide-    benches =-        firstBoolFlags-            "bench"-            "benchmarking the package(s) in this directory/configuration"-            hide-    reconfigure =-        firstBoolFlags-             "reconfigure"-             "Perform the configure step even if unnecessary. Useful in some corner cases with custom Setup.hs files"-            hide-    cabalVerbose =-        firstBoolFlags-            "cabal-verbose"-            "Ask Cabal to be verbose in its output"-            hide-    splitObjs =-        firstBoolFlags-            "split-objs"-            ("Enable split-objs, to reduce output size (at the cost of build time). " ++ splitObjsWarning)-            hide--nixOptsParser :: Bool -> Parser NixOptsMonoid-nixOptsParser hide0 = overrideActivation <$>-  (NixOptsMonoid-  <$> pure (Any False)-  <*> firstBoolFlags nixCmdName-                     "use of a Nix-shell"-                     hide-  <*> firstBoolFlags "nix-pure"-                     "use of a pure Nix-shell"-                     hide-  <*> optionalFirst-          (textArgsOption-              (long "nix-packages" <>-               metavar "NAMES" <>-               help "List of packages that should be available in the nix-shell (space separated)" <>-               hide))-  <*> optionalFirst-          (option-              str-              (long "nix-shell-file" <>-               metavar "FILEPATH" <>-               help "Nix file to be used to launch a nix-shell (for regular Nix users)" <>-               hide))-  <*> optionalFirst-          (textArgsOption-              (long "nix-shell-options" <>-               metavar "OPTIONS" <>-               help "Additional options passed to nix-shell" <>-               hide))-  <*> optionalFirst-          (textArgsOption-              (long "nix-path" <>-               metavar "PATH_OPTIONS" <>-               help "Additional options to override NIX_PATH parts (notably 'nixpkgs')" <>-               hide))-  )-  where-    hide = hideMods hide0-    overrideActivation m =-      if m /= mempty then m { nixMonoidEnable = (First . Just . fromFirst True) (nixMonoidEnable m) }-      else m-    textArgsOption = fmap (map T.pack) . argsOption---- | Options parser configuration for Docker.-dockerOptsParser :: Bool -> Parser DockerOptsMonoid-dockerOptsParser hide0 =-    DockerOptsMonoid-    <$> pure (Any False)-    <*> firstBoolFlags dockerCmdName-                       "using a Docker container"-                       hide-    <*> fmap First-           ((Just . DockerMonoidRepo) <$> option str (long (dockerOptName dockerRepoArgName) <>-                                                     hide <>-                                                     metavar "NAME" <>-                                                     help "Docker repository name") <|>-             (Just . DockerMonoidImage) <$> option str (long (dockerOptName dockerImageArgName) <>-                                                      hide <>-                                                      metavar "IMAGE" <>-                                                      help "Exact Docker image ID (overrides docker-repo)") <|>-         pure Nothing)-    <*> firstBoolFlags (dockerOptName dockerRegistryLoginArgName)-                       "registry requires login"-                       hide-    <*> firstStrOption (long (dockerOptName dockerRegistryUsernameArgName) <>-                        hide <>-                        metavar "USERNAME" <>-                        help "Docker registry username")-    <*> firstStrOption (long (dockerOptName dockerRegistryPasswordArgName) <>-                        hide <>-                        metavar "PASSWORD" <>-                        help "Docker registry password")-    <*> firstBoolFlags (dockerOptName dockerAutoPullArgName)-                       "automatic pulling latest version of image"-                       hide-    <*> firstBoolFlags (dockerOptName dockerDetachArgName)-                       "running a detached Docker container"-                       hide-    <*> firstBoolFlags (dockerOptName dockerPersistArgName)-                       "not deleting container after it exits"-                       hide-    <*> firstStrOption (long (dockerOptName dockerContainerNameArgName) <>-                        hide <>-                        metavar "NAME" <>-                        help "Docker container name")-    <*> argsOption (long (dockerOptName dockerRunArgsArgName) <>-                    hide <>-                    value [] <>-                    metavar "'ARG1 [ARG2 ...]'" <>-                    help "Additional options to pass to 'docker run'")-    <*> many (option auto (long (dockerOptName dockerMountArgName) <>-                           hide <>-                           metavar "(PATH | HOST-PATH:CONTAINER-PATH)" <>-                           help ("Mount volumes from host in container " ++-                                 "(may specify multiple times)")))-    <*> many (option str (long (dockerOptName dockerEnvArgName) <>-                                hide <>-                                metavar "NAME=VALUE" <>-                                help ("Set environment variable in container " ++-                                      "(may specify multiple times)")))-    <*> optionalFirst (absFileOption-            (long (dockerOptName dockerDatabasePathArgName) <>-             hide <>-             metavar "PATH" <>-             help "Location of image usage tracking database"))-    <*> optionalFirst (option (eitherReader' parseDockerStackExe)-            (long(dockerOptName dockerStackExeArgName) <>-             hide <>-             metavar (intercalate "|"-                          [ dockerStackExeDownloadVal-                          , dockerStackExeHostVal-                          , dockerStackExeImageVal-                          , "PATH" ]) <>-             help (concat [ "Location of "-                          , stackProgName-                          , " executable used in container" ])))-    <*> firstBoolFlags (dockerOptName dockerSetUserArgName)-                       "setting user in container to match host"-                       hide-    <*> pure (IntersectingVersionRange anyVersion)-  where-    dockerOptName optName = dockerCmdName ++ "-" ++ T.unpack optName-    firstStrOption = optionalFirst . option str-    hide = hideMods hide0---- | Parser for docker cleanup arguments.-dockerCleanupOptsParser :: Parser Docker.CleanupOpts-dockerCleanupOptsParser =-  Docker.CleanupOpts <$>-  (flag' Docker.CleanupInteractive-         (short 'i' <>-          long "interactive" <>-          help "Show cleanup plan in editor and allow changes (default)") <|>-   flag' Docker.CleanupImmediate-         (short 'y' <>-          long "immediate" <>-          help "Immediately execute cleanup plan") <|>-   flag' Docker.CleanupDryRun-         (short 'n' <>-          long "dry-run" <>-          help "Display cleanup plan but do not execute") <|>-   pure Docker.CleanupInteractive) <*>-  opt (Just 14) "known-images" "LAST-USED" <*>-  opt Nothing "unknown-images" "CREATED" <*>-  opt (Just 0) "dangling-images" "CREATED" <*>-  opt Nothing "stopped-containers" "CREATED" <*>-  opt Nothing "running-containers" "CREATED"-  where opt def' name mv =-          fmap Just-               (option auto-                       (long name <>-                        metavar (mv ++ "-DAYS-AGO") <>-                        help ("Remove " ++-                              toDescr name ++-                              " " ++-                              map toLower (toDescr mv) ++-                              " N days ago" ++-                              case def' of-                                Just n -> " (default " ++ show n ++ ")"-                                Nothing -> ""))) <|>-          flag' Nothing-                (long ("no-" ++ name) <>-                 help ("Do not remove " ++-                       toDescr name ++-                       case def' of-                         Just _ -> ""-                         Nothing -> " (default)")) <|>-          pure def'-        toDescr = map (\c -> if c == '-' then ' ' else c)---- | Parser for arguments to `stack dot`-dotOptsParser :: Parser DotOpts-dotOptsParser = DotOpts-            <$> includeExternal-            <*> includeBase-            <*> depthLimit-            <*> fmap (maybe Set.empty Set.fromList . fmap splitNames) prunedPkgs-  where includeExternal = boolFlags False-                                    "external"-                                    "inclusion of external dependencies"-                                    idm-        includeBase = boolFlags True-                                "include-base"-                                "inclusion of dependencies on base"-                                idm-        depthLimit =-            optional (option auto-                             (long "depth" <>-                              metavar "DEPTH" <>-                              help ("Limit the depth of dependency resolution " <>-                                    "(Default: No limit)")))-        prunedPkgs = optional (strOption-                                   (long "prune" <>-                                    metavar "PACKAGES" <>-                                    help ("Prune each package name " <>-                                          "from the comma separated list " <>-                                          "of package names PACKAGES")))--        splitNames :: String -> [String]-        splitNames = map (takeWhile (not . isSpace) . dropWhile isSpace) . splitOn ","--ghciOptsParser :: Parser GhciOpts-ghciOptsParser = GhciOpts-             <$> switch (long "no-build" <> help "Don't build before launching GHCi")-             <*> fmap concat (many (argsOption (long "ghci-options" <>-                                       metavar "OPTION" <>-                                       help "Additional options passed to GHCi")))-             <*> optional-                     (strOption (long "with-ghc" <>-                                 metavar "GHC" <>-                                 help "Use this GHC to run GHCi"))-             <*> (not <$> boolFlags True "load" "load modules on start-up" idm)-             <*> packagesParser-             <*> optional-                     (textOption-                           (long "main-is" <>-                            metavar "TARGET" <>-                            help "Specify which target should contain the main \-                                 \module to load, such as for an executable for \-                                 \test suite or benchmark."))-             <*> switch (long "load-local-deps" <> help "Load all local dependencies of your targets")-             <*> switch (long "skip-intermediate-deps" <> help "Skip loading intermediate target dependencies")-             <*> boolFlags True "package-hiding" "package hiding" idm-             <*> buildOptsParser Build---- | Parser for exec command-execOptsParser :: Maybe SpecialExecCmd -> Parser ExecOpts-execOptsParser mcmd =-    ExecOpts-        <$> maybe eoCmdParser pure mcmd-        <*> eoArgsParser-        <*> execOptsExtraParser-  where-    eoCmdParser = ExecCmd <$> strArgument (metavar "CMD")-    eoArgsParser = many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)"))--evalOptsParser :: String -- ^ metavar-               -> Parser EvalOpts-evalOptsParser meta =-    EvalOpts-        <$> eoArgsParser-        <*> execOptsExtraParser-  where-    eoArgsParser :: Parser String-    eoArgsParser = strArgument (metavar meta)---- | Parser for extra options to exec command-execOptsExtraParser :: Parser ExecOptsExtra-execOptsExtraParser = eoPlainParser <|>-                      ExecOptsEmbellished-                         <$> eoEnvSettingsParser-                         <*> eoPackagesParser-  where-    eoEnvSettingsParser :: Parser EnvSettings-    eoEnvSettingsParser = EnvSettings-        <$> pure True-        <*> boolFlags True-                "ghc-package-path"-                "setting the GHC_PACKAGE_PATH variable for the subprocess"-                idm-        <*> boolFlags True-                "stack-exe"-                "setting the STACK_EXE environment variable to the path for the stack executable"-                idm-        <*> pure False--    eoPackagesParser :: Parser [String]-    eoPackagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))--    eoPlainParser :: Parser ExecOptsExtra-    eoPlainParser = flag' ExecOptsPlain-                          (long "plain" <>-                           help "Use an unmodified environment (only useful with Docker)")---- | Parser for global command-line options.-globalOptsParser :: GlobalOptsContext -> Maybe LogLevel -> Parser GlobalOptsMonoid-globalOptsParser kind defLogLevel =-    GlobalOptsMonoid <$>-    optionalFirst (strOption (long Docker.reExecArgName <> hidden <> internal)) <*>-    optionalFirst (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*>-    (First <$> logLevelOptsParser hide0 defLogLevel) <*>-    configOptsParser kind <*>-    optionalFirst (abstractResolverOptsParser hide0) <*>-    optionalFirst (compilerOptsParser hide0) <*>-    firstBoolFlags-        "terminal"-        "overriding terminal detection in the case of running in a false terminal"-        hide <*>-    optionalFirst-        (strOption-            (long "stack-yaml" <>-             metavar "STACK-YAML" <>-             help ("Override project stack.yaml file " <>-                   "(overrides any STACK_YAML environment variable)") <>-             hide))-  where-    hide = hideMods hide0-    hide0 = kind /= OuterGlobalOpts---- | Create GlobalOpts from GlobalOptsMonoid.-globalOptsFromMonoid :: Bool -> GlobalOptsMonoid -> GlobalOpts-globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts-    { globalReExecVersion = getFirst globalMonoidReExecVersion-    , globalDockerEntrypoint = getFirst globalMonoidDockerEntrypoint-    , globalLogLevel = fromFirst defaultLogLevel globalMonoidLogLevel-    , globalConfigMonoid = globalMonoidConfigMonoid-    , globalResolver = getFirst globalMonoidResolver-    , globalCompiler = getFirst globalMonoidCompiler-    , globalTerminal = fromFirst defaultTerminal globalMonoidTerminal-    , globalStackYaml = getFirst globalMonoidStackYaml }--initOptsParser :: Parser InitOpts-initOptsParser =-    InitOpts <$> searchDirs-             <*> solver <*> omitPackages-             <*> overwrite <*> fmap not ignoreSubDirs-  where-    searchDirs =-      many (textArgument-              (metavar "DIRS" <>-               help "Directories to include, default is current directory."))-    ignoreSubDirs = switch (long "ignore-subdirs" <>-                           help "Do not search for .cabal files in sub directories")-    overwrite = switch (long "force" <>-                       help "Force overwriting an existing stack.yaml")-    omitPackages = switch (long "omit-packages" <>-                           help "Exclude conflicting or incompatible user packages")-    solver = switch (long "solver" <>-             help "Use a dependency solver to determine extra dependencies")---- | Parser for a logging level.-logLevelOptsParser :: Bool -> Maybe LogLevel -> Parser (Maybe LogLevel)-logLevelOptsParser hide defLogLevel =-  fmap (Just . parse)-       (strOption (long "verbosity" <>-                   metavar "VERBOSITY" <>-                   help "Verbosity: silent, error, warn, info, debug" <>-                   hideMods hide)) <|>-  flag' (Just verboseLevel)-       (short 'v' <> long "verbose" <>-        help ("Enable verbose mode: verbosity level \"" <> showLevel verboseLevel <> "\"") <>-        hideMods hide) <|>-  flag' (Just silentLevel)-       (long "silent" <>-        help ("Enable silent mode: verbosity level \"" <> showLevel silentLevel <> "\"") <>-        hideMods hide) <|>-  pure defLogLevel-  where verboseLevel = LevelDebug-        silentLevel = LevelOther "silent"-        showLevel l =-          case l of-            LevelDebug -> "debug"-            LevelInfo -> "info"-            LevelWarn -> "warn"-            LevelError -> "error"-            LevelOther x -> T.unpack x-        parse s =-          case s of-            "debug" -> LevelDebug-            "info" -> LevelInfo-            "warn" -> LevelWarn-            "error" -> LevelError-            _ -> LevelOther (T.pack s)---- | Parser for the resolver-abstractResolverOptsParser :: Bool -> Parser AbstractResolver-abstractResolverOptsParser hide =-    option readAbstractResolver-        (long "resolver" <>-         metavar "RESOLVER" <>-         help "Override resolver in project file" <>-         hideMods hide)--readAbstractResolver :: ReadM AbstractResolver-readAbstractResolver = do-    s <- readerAsk-    case s of-        "global" -> return ARGlobal-        "nightly" -> return ARLatestNightly-        "lts" -> return ARLatestLTS-        'l':'t':'s':'-':x | Right (x', "") <- decimal $ T.pack x ->-            return $ ARLatestLTSMajor x'-        _ ->-            case parseResolverText $ T.pack s of-                Left e -> readerError $ show e-                Right x -> return $ ARResolver x--compilerOptsParser :: Bool -> Parser CompilerVersion-compilerOptsParser hide =-    option readCompilerVersion-        (long "compiler" <>-         metavar "COMPILER" <>-         help "Use the specified compiler" <>-         hideMods hide)--readCompilerVersion :: ReadM CompilerVersion-readCompilerVersion = do-    s <- readerAsk-    case parseCompilerVersion (T.pack s) of-        Nothing -> readerError $ "Failed to parse compiler: " ++ s-        Just x -> return x---- | GHC variant parser-ghcVariantParser :: Bool -> Parser GHCVariant-ghcVariantParser hide =-    option-        readGHCVariant-        (long "ghc-variant" <> metavar "VARIANT" <>-         help-             "Specialized GHC variant, e.g. integersimple (implies --no-system-ghc)" <>-         hideMods hide-        )-  where-    readGHCVariant = do-        s <- readerAsk-        case parseGHCVariant s of-            Left e -> readerError (show e)-            Right v -> return v---- | Parser for @solverCmd@-solverOptsParser :: Parser Bool-solverOptsParser = boolFlags False-    "update-config"-    "Automatically update stack.yaml with the solver's recommendations"-    idm---- | Parser for haddock arguments.-haddockOptsParser :: Bool -> Parser HaddockOptsMonoid-haddockOptsParser hide0 =-  HaddockOptsMonoid <$> fmap (fromMaybe [])-                             (optional-                              (argsOption-                               (long "haddock-arguments" <>-                                metavar "HADDOCK_ARGS" <>-                                help "Arguments passed to the haddock program" <>-                                hide)))-  where hide = hideMods hide0---- | Parser for test arguments.--- FIXME hide args-testOptsParser :: Bool -> Parser TestOptsMonoid-testOptsParser hide0 =-    TestOptsMonoid-        <$> firstBoolFlags-                "rerun-tests"-                "running already successful tests"-                hide-        <*> fmap-                (fromMaybe [])-                (optional-                    (argsOption-                        (long "test-arguments" <>-                         metavar "TEST_ARGS" <>-                         help "Arguments passed in to the test suite program" <>-                         hide)))-        <*> optionalFirst-                (switch-                    (long "coverage" <>-                     help "Generate a code coverage report" <>-                     hide))-        <*> optionalFirst-                (switch-                    (long "no-run-tests" <>-                     help "Disable running of tests. (Tests will still be built.)" <>-                     hide))-   where hide = hideMods hide0---- | Parser for @stack new@.-newOptsParser :: Parser (NewOpts,InitOpts)-newOptsParser = (,) <$> newOpts <*> initOptsParser-  where-    newOpts =-        NewOpts <$>-        packageNameArgument-            (metavar "PACKAGE_NAME" <> help "A valid package name.") <*>-        switch-            (long "bare" <>-             help "Do not create a subdirectory for the project") <*>-        optional (templateNameArgument-            (metavar "TEMPLATE_NAME" <>-             help "Name of a template or a local template in a file or a URL.\-                  \ For example: foo or foo.hsfiles or ~/foo or\-                  \ https://example.com/foo.hsfiles")) <*>-        fmap-            M.fromList-            (many-                 (templateParamArgument-                      (short 'p' <> long "param" <> metavar "KEY:VALUE" <>-                       help-                           "Parameter for the template in the format key:value")))---- | Parser for @stack hpc report@.-hpcReportOptsParser :: Parser HpcReportOpts-hpcReportOptsParser = HpcReportOpts-    <$> many (textArgument $ metavar "TARGET_OR_TIX")-    <*> switch (long "all" <> help "Use results from all packages and components")-    <*> optional (strOption (long "destdir" <> help "Output directy for HTML report"))--pvpBoundsOption :: Parser PvpBounds-pvpBoundsOption =-    option-        readPvpBounds-        (long "pvp-bounds" <> metavar "PVP-BOUNDS" <>-         help-             "How PVP version bounds should be added to .cabal file: none, lower, upper, both")-  where-    readPvpBounds = do-        s <- readerAsk-        case parsePvpBounds $ T.pack s of-            Left e ->-                readerError e-            Right v ->-                return v--configCmdSetParser :: Parser ConfigCmdSet-configCmdSetParser =-    fromM-        (do field <--                oneM-                    (strArgument-                         (metavar "FIELD VALUE"))-            oneM (fieldToValParser field))-  where-    fieldToValParser :: String -> Parser ConfigCmdSet-    fieldToValParser s =-        case s of-            "resolver" ->-                ConfigCmdSetResolver <$>-                argument-                    readAbstractResolver-                    idm-            _ ->-                error "parse stack config set field: only set resolver is implemented"---- | If argument is True, hides the option from usage and help-hideMods :: Bool -> Mod f a-hideMods hide = if hide then internal <> hidden else idm
+ src/Stack/Options/BenchParser.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++module Stack.Options.BenchParser where++import           Data.Monoid.Extra+import           Options.Applicative+import           Options.Applicative.Builder.Extra+import           Stack.Options.Utils+import           Stack.Types.Config++-- | Parser for bench arguments.+-- FIXME hiding options+benchOptsParser :: Bool -> Parser BenchmarkOptsMonoid+benchOptsParser hide0 = BenchmarkOptsMonoid+        <$> optionalFirst (strOption (long "benchmark-arguments" <>+                                 metavar "BENCH_ARGS" <>+                                 help ("Forward BENCH_ARGS to the benchmark suite. " <>+                                       "Supports templates from `cabal bench`") <>+                                 hide))+        <*> optionalFirst (switch (long "no-run-benchmarks" <>+                          help "Disable running of benchmarks. (Benchmarks will still be built.)" <>+                             hide))+   where hide = hideMods hide0
+ src/Stack/Options/BuildMonoidParser.hs view
@@ -0,0 +1,156 @@+module Stack.Options.BuildMonoidParser where++import           Data.Maybe                        (catMaybes)+import           Data.Monoid.Extra+import           Options.Applicative+import           Options.Applicative.Builder.Extra+import           Stack.Build                       (splitObjsWarning)+import           Stack.Options.BenchParser+import           Stack.Options.TestParser+import           Stack.Options.HaddockParser+import           Stack.Options.Utils+import           Stack.Types.Config.Build++buildOptsMonoidParser :: GlobalOptsContext -> Parser BuildOptsMonoid+buildOptsMonoidParser hide0 =+    transform <$> trace <*> profile <*> options+  where+    hideBool = hide0 /= BuildCmdGlobalOpts+    hide =+        hideMods hideBool+    hideExceptGhci =+        hideMods (hide0 `notElem` [BuildCmdGlobalOpts, GhciCmdGlobalOpts])+    transform tracing profiling =+        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+                }+              }+          | 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 =+        flag+            False+            True+            (long "trace" <>+             help+                 "Enable profiling in libraries, executables, etc. \+                    \for all expressions and generate a backtrace on \+                    \exception" <>+            hideExceptGhci)+    options =+        BuildOptsMonoid <$> libProfiling <*> exeProfiling <*> haddock <*>+        haddockOptsParser hideBool <*> openHaddocks <*> haddockDeps <*>+        haddockInternal <*> copyBins <*> preFetch <*> keepGoing <*>+        forceDirty <*> tests <*> testOptsParser hideBool <*> benches <*>+        benchOptsParser hideBool <*> reconfigure <*>+        cabalVerbose <*> splitObjs+    libProfiling =+        firstBoolFlags+            "library-profiling"+            "library profiling for TARGETs and all its dependencies"+            hide+    exeProfiling =+        firstBoolFlags+            "executable-profiling"+            "executable profiling for TARGETs and all its dependencies"+            hide+    haddock =+        firstBoolFlags+            "haddock"+            "generating Haddocks the package(s) in this directory/configuration"+            hide+    openHaddocks =+        firstBoolFlags+            "open"+            "opening the local Haddock documentation in the browser"+            hide+    haddockDeps =+        firstBoolFlags "haddock-deps" "building Haddocks for dependencies" hide+    haddockInternal =+        firstBoolFlags+            "haddock-internal"+            "building Haddocks for internal modules (like cabal haddock --internal)"+            hide+    copyBins =+        firstBoolFlags+            "copy-bins"+            "copying binaries to the local-bin-path (see 'stack path')"+            hide+    keepGoing =+        firstBoolFlags+            "keep-going"+            "continue running after a step fails (default: false for build, true for test/bench)"+            hide+    preFetch =+        firstBoolFlags+            "prefetch"+             "Fetch packages necessary for the build immediately, useful with --dry-run"+             hide+    forceDirty =+        firstBoolFlags+            "force-dirty"+            "Force treating all local packages as having dirty files (useful for cases where stack can't detect a file change"+            hide+    tests =+        firstBoolFlags+            "test"+            "testing the package(s) in this directory/configuration"+            hideExceptGhci+    benches =+        firstBoolFlags+            "bench"+            "benchmarking the package(s) in this directory/configuration"+            hideExceptGhci+    reconfigure =+        firstBoolFlags+             "reconfigure"+             "Perform the configure step even if unnecessary. Useful in some corner cases with custom Setup.hs files"+            hide+    cabalVerbose =+        firstBoolFlags+            "cabal-verbose"+            "Ask Cabal to be verbose in its output"+            hide+    splitObjs =+        firstBoolFlags+            "split-objs"+            ("Enable split-objs, to reduce output size (at the cost of build time). " ++ splitObjsWarning)+            hide
+ src/Stack/Options/BuildParser.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}++module Stack.Options.BuildParser where++import qualified Data.Map as Map+import           Data.Monoid.Extra+import           Data.Text (Text)+import           Data.Version (showVersion)+import           Options.Applicative+import           Options.Applicative.Args+import           Options.Applicative.Builder.Extra+import           Paths_stack as Meta+import           Stack.Options.PackageParser (readFlag)+import           Stack.Types.Config+import           Stack.Types.FlagName+import           Stack.Types.PackageName++-- | Parser for CLI-only build arguments+buildOptsParser :: BuildCommand+                -> Parser BuildOptsCLI+buildOptsParser cmd =+    BuildOptsCLI <$>+    targetsParser <*>+    switch+        (long "dry-run" <>+         help "Don't build anything, just prepare to") <*>+    ((\x y z ->+           concat [x, y, z]) <$>+     flag+         []+         ["-Wall", "-Werror"]+         (long "pedantic" <>+          help "Turn on -Wall and -Werror") <*>+     flag+         []+         ["-O0"]+         (long "fast" <>+          help "Turn off optimizations (-O0)") <*>+     many+         (textOption+              (long "ghc-options" <>+               metavar "OPTION" <>+               help "Additional options passed to GHC"))) <*>+    flagsParser <*>+    (flag'+         BSOnlyDependencies+         (long "dependencies-only" <>+          help "A synonym for --only-dependencies") <|>+     flag'+         BSOnlySnapshot+         (long "only-snapshot" <>+          help+              "Only build packages for the snapshot database, not the local database") <|>+     flag'+         BSOnlyDependencies+         (long "only-dependencies" <>+          help+              "Only build packages that are dependencies of targets on the command line") <|>+     pure BSAll) <*>+    (flag'+         FileWatch+         (long "file-watch" <>+          help+              "Watch for changes in local files and automatically rebuild. Ignores files in VCS boring/ignore file") <|>+     flag'+         FileWatchPoll+         (long "file-watch-poll" <>+          help+              "Like --file-watch, but polling the filesystem instead of using events") <|>+     pure NoFileWatch) <*>+    many (cmdOption+             (long "exec" <>+              metavar "CMD [ARGS]" <>+              help "Command and arguments to run after a successful build")) <*>+    switch+        (long "only-configure" <>+         help+             "Only perform the configure step, not any builds. Intended for tool usage, may break when used on multiple packages at once!") <*>+    pure cmd <*>+    switch+        (long "initial-build-steps" <>+         help "For target packages, only run initial build steps needed for GHCi" <>+         internal)++targetsParser :: Parser [Text]+targetsParser =+    many+        (textArgument+             (metavar "TARGET" <>+              help ("If none specified, use all local packages. " <>+                    "See https://docs.haskellstack.org/en/v" <>+                    showVersion Meta.version <>+                    "/build_command/#target-syntax for details.")))++flagsParser :: Parser (Map.Map (Maybe PackageName) (Map.Map FlagName Bool))+flagsParser =+     Map.unionsWith Map.union <$>+     many+         (option+              readFlag+              (long "flag" <>+               metavar "PACKAGE:[-]FLAG" <>+               help+                   ("Override flags set in stack.yaml " <>+                    "(applies to local packages and extra-deps)")))
+ src/Stack/Options/CleanParser.hs view
@@ -0,0 +1,21 @@+module Stack.Options.CleanParser where++import           Data.Monoid.Extra+import           Options.Applicative+import           Stack.Clean                       (CleanOpts (..))+import           Stack.Types.PackageName++-- | Command-line parser for the clean command.+cleanOptsParser :: Parser CleanOpts+cleanOptsParser = CleanShallow <$> packages <|> doFullClean+  where+    packages =+        many+            (packageNameArgument+                 (metavar "PACKAGE" <>+                  help "If none specified, clean all local packages"))+    doFullClean =+        flag'+            CleanFull+            (long "full" <>+             help "Delete all work directories (.stack-work by default) in the project")
+ src/Stack/Options/ConfigParser.hs view
@@ -0,0 +1,131 @@+module Stack.Options.ConfigParser where++import           Data.Char+import           Data.Monoid.Extra+import qualified Data.Set                          as Set+import           Options.Applicative+import           Options.Applicative.Builder.Extra+import           Stack.Constants+import           Stack.Options.BuildMonoidParser+import           Stack.Options.DockerParser+import           Stack.Options.GhcBuildParser+import           Stack.Options.GhcVariantParser+import           Stack.Options.NixParser+import           Stack.Options.Utils+import           Stack.Types.Config++-- | Command-line arguments parser for configuration.+configOptsParser :: GlobalOptsContext -> Parser ConfigMonoid+configOptsParser 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+        , configMonoidBuildOpts = buildOpts+        , configMonoidDockerOpts = dockerOpts+        , configMonoidNixOpts = nixOpts+        , configMonoidSystemGHC = systemGHC+        , configMonoidInstallGHC = installGHC+        , configMonoidSkipGHCCheck = skipGHCCheck+        , configMonoidArch = arch+        , configMonoidGHCVariant = ghcVariant+        , configMonoidGHCBuild = ghcBuild+        , configMonoidJobs = jobs+        , configMonoidExtraIncludeDirs = includes+        , configMonoidExtraLibDirs = libs+        , configMonoidOverrideGccPath = overrideGccPath+        , configMonoidSkipMsys = skipMsys+        , configMonoidLocalBinPath = localBin+        , configMonoidModifyCodePage = modifyCodePage+        , configMonoidAllowDifferentUser = allowDifferentUser+        , configMonoidDumpLogs = dumpLogs+        })+    <$> optionalFirst (absDirOption+            ( long stackRootOptionName+            <> metavar (map toUpper stackRootOptionName)+            <> help ("Absolute path to the global stack root directory " +++                     "(Overrides any STACK_ROOT environment variable)")+            <> hide+            ))+    <*> optionalFirst (relDirOption+            ( long "work-dir"+            <> metavar "WORK-DIR"+            <> help "Override work directory (default: .stack-work)"+            <> hide+            ))+    <*> buildOptsMonoidParser hide0+    <*> dockerOptsParser True+    <*> nixOptsParser True+    <*> firstBoolFlags+            "system-ghc"+            "using the system installed GHC (on the PATH) if available and a matching version. Disabled by default."+            hide+    <*> firstBoolFlags+            "install-ghc"+            "downloading and installing GHC if necessary (can be done manually with stack setup)"+            hide+    <*> optionalFirst (strOption+            ( long "arch"+           <> metavar "ARCH"+           <> help "System architecture, e.g. i386, x86_64"+           <> hide+            ))+    <*> optionalFirst (ghcVariantParser (hide0 /= OuterGlobalOpts))+    <*> optionalFirst (ghcBuildParser (hide0 /= OuterGlobalOpts))+    <*> optionalFirst (option auto+            ( long "jobs"+           <> short 'j'+           <> metavar "JOBS"+           <> help "Number of concurrent jobs to run"+           <> hide+            ))+    <*> fmap Set.fromList (many (absDirOption+            ( long "extra-include-dirs"+           <> metavar "DIR"+           <> help "Extra directories to check for C header files"+           <> hide+            )))+    <*> fmap Set.fromList (many (absDirOption+            ( long "extra-lib-dirs"+           <> metavar "DIR"+           <> help "Extra directories to check for libraries"+           <> hide+            )))+    <*> optionalFirst (absFileOption+             ( long "with-gcc"+            <> metavar "PATH-TO-GCC"+            <> help "Use gcc found at PATH-TO-GCC"+            <> hide+             ))+    <*> firstBoolFlags+            "skip-ghc-check"+            "skipping the GHC version and architecture check"+            hide+    <*> firstBoolFlags+            "skip-msys"+            "skipping the local MSYS installation (Windows only)"+            hide+    <*> optionalFirst (strOption+             ( long "local-bin-path"+            <> metavar "DIR"+            <> help "Install binaries to DIR"+            <> hide+             ))+    <*> firstBoolFlags+            "modify-code-page"+            "setting the codepage to support UTF-8 (Windows only)"+            hide+    <*> firstBoolFlags+            "allow-different-user"+            ("permission for users other than the owner of the stack root " +++                "directory to use a stack installation (POSIX only)")+            hide+    <*> fmap toDumpLogs+            (firstBoolFlags+             "dump-logs"+             "dump the build output logs for local packages to the console"+             hide)+  where+    hide = hideMods (hide0 /= OuterGlobalOpts)+    toDumpLogs (First (Just True)) = First (Just DumpAllLogs)+    toDumpLogs (First (Just False)) = First (Just DumpNoLogs)+    toDumpLogs (First Nothing) = First Nothing
+ src/Stack/Options/DockerParser.hs view
@@ -0,0 +1,143 @@+module Stack.Options.DockerParser where++import           Data.Char+import           Data.List                         (intercalate)+import           Data.Monoid.Extra+import qualified Data.Text                         as T+import           Distribution.Version              (anyVersion)+import           Options.Applicative+import           Options.Applicative.Args+import           Options.Applicative.Builder.Extra+import           Stack.Constants+import           Stack.Docker+import qualified Stack.Docker                      as Docker+import           Stack.Options.Utils+import           Stack.Types.Version+import           Stack.Types.Docker++-- | Options parser configuration for Docker.+dockerOptsParser :: Bool -> Parser DockerOptsMonoid+dockerOptsParser hide0 =+    DockerOptsMonoid+    <$> pure (Any False)+    <*> firstBoolFlags dockerCmdName+                       "using a Docker container. Implies 'system-ghc: true'"+                       hide+    <*> fmap First+           ((Just . DockerMonoidRepo) <$> option str (long (dockerOptName dockerRepoArgName) <>+                                                     hide <>+                                                     metavar "NAME" <>+                                                     help "Docker repository name") <|>+             (Just . DockerMonoidImage) <$> option str (long (dockerOptName dockerImageArgName) <>+                                                      hide <>+                                                      metavar "IMAGE" <>+                                                      help "Exact Docker image ID (overrides docker-repo)") <|>+         pure Nothing)+    <*> firstBoolFlags (dockerOptName dockerRegistryLoginArgName)+                       "registry requires login"+                       hide+    <*> firstStrOption (long (dockerOptName dockerRegistryUsernameArgName) <>+                        hide <>+                        metavar "USERNAME" <>+                        help "Docker registry username")+    <*> firstStrOption (long (dockerOptName dockerRegistryPasswordArgName) <>+                        hide <>+                        metavar "PASSWORD" <>+                        help "Docker registry password")+    <*> firstBoolFlags (dockerOptName dockerAutoPullArgName)+                       "automatic pulling latest version of image"+                       hide+    <*> firstBoolFlags (dockerOptName dockerDetachArgName)+                       "running a detached Docker container"+                       hide+    <*> firstBoolFlags (dockerOptName dockerPersistArgName)+                       "not deleting container after it exits"+                       hide+    <*> firstStrOption (long (dockerOptName dockerContainerNameArgName) <>+                        hide <>+                        metavar "NAME" <>+                        help "Docker container name")+    <*> argsOption (long (dockerOptName dockerRunArgsArgName) <>+                    hide <>+                    value [] <>+                    metavar "'ARG1 [ARG2 ...]'" <>+                    help "Additional options to pass to 'docker run'")+    <*> many (option auto (long (dockerOptName dockerMountArgName) <>+                           hide <>+                           metavar "(PATH | HOST-PATH:CONTAINER-PATH)" <>+                           help ("Mount volumes from host in container " +++                                 "(may specify multiple times)")))+    <*> many (option str (long (dockerOptName dockerEnvArgName) <>+                                hide <>+                                metavar "NAME=VALUE" <>+                                help ("Set environment variable in container " +++                                      "(may specify multiple times)")))+    <*> optionalFirst (absFileOption+            (long (dockerOptName dockerDatabasePathArgName) <>+             hide <>+             metavar "PATH" <>+             help "Location of image usage tracking database"))+    <*> optionalFirst (option (eitherReader' parseDockerStackExe)+            (long(dockerOptName dockerStackExeArgName) <>+             hide <>+             metavar (intercalate "|"+                          [ dockerStackExeDownloadVal+                          , dockerStackExeHostVal+                          , dockerStackExeImageVal+                          , "PATH" ]) <>+             help (concat [ "Location of "+                          , stackProgName+                          , " executable used in container" ])))+    <*> firstBoolFlags (dockerOptName dockerSetUserArgName)+                       "setting user in container to match host"+                       hide+    <*> pure (IntersectingVersionRange anyVersion)+  where+    dockerOptName optName = dockerCmdName ++ "-" ++ T.unpack optName+    firstStrOption = optionalFirst . option str+    hide = hideMods hide0++-- | Parser for docker cleanup arguments.+dockerCleanupOptsParser :: Parser Docker.CleanupOpts+dockerCleanupOptsParser =+  Docker.CleanupOpts <$>+  (flag' Docker.CleanupInteractive+         (short 'i' <>+          long "interactive" <>+          help "Show cleanup plan in editor and allow changes (default)") <|>+   flag' Docker.CleanupImmediate+         (short 'y' <>+          long "immediate" <>+          help "Immediately execute cleanup plan") <|>+   flag' Docker.CleanupDryRun+         (short 'n' <>+          long "dry-run" <>+          help "Display cleanup plan but do not execute") <|>+   pure Docker.CleanupInteractive) <*>+  opt (Just 14) "known-images" "LAST-USED" <*>+  opt Nothing "unknown-images" "CREATED" <*>+  opt (Just 0) "dangling-images" "CREATED" <*>+  opt Nothing "stopped-containers" "CREATED" <*>+  opt Nothing "running-containers" "CREATED"+  where opt def' name mv =+          fmap Just+               (option auto+                       (long name <>+                        metavar (mv ++ "-DAYS-AGO") <>+                        help ("Remove " +++                              toDescr name +++                              " " +++                              map toLower (toDescr mv) +++                              " N days ago" +++                              case def' of+                                Just n -> " (default " ++ show n ++ ")"+                                Nothing -> ""))) <|>+          flag' Nothing+                (long ("no-" ++ name) <>+                 help ("Do not remove " +++                       toDescr name +++                       case def' of+                         Just _ -> ""+                         Nothing -> " (default)")) <|>+          pure def'+        toDescr = map (\c -> if c == '-' then ' ' else c)
+ src/Stack/Options/DotParser.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}++module Stack.Options.DotParser where++import           Data.Char (isSpace)+import           Data.List.Split (splitOn)+import           Data.Monoid.Extra+import qualified Data.Set as Set+import qualified Data.Text as T+import           Options.Applicative+import           Options.Applicative.Builder.Extra+import           Stack.Dot+import           Stack.Options.BuildParser++-- | Parser for arguments to `stack dot`+dotOptsParser :: Bool -> Parser DotOpts+dotOptsParser externalDefault =+  DotOpts <$> includeExternal+          <*> includeBase+          <*> depthLimit+          <*> fmap (maybe Set.empty Set.fromList . fmap splitNames) prunedPkgs+          <*> targetsParser+          <*> flagsParser+          <*> testTargets+          <*> benchTargets+  where includeExternal = boolFlags externalDefault+                                    "external"+                                    "inclusion of external dependencies"+                                    idm+        includeBase = boolFlags True+                                "include-base"+                                "inclusion of dependencies on base"+                                idm+        depthLimit =+            optional (option auto+                             (long "depth" <>+                              metavar "DEPTH" <>+                              help ("Limit the depth of dependency resolution " <>+                                    "(Default: No limit)")))+        prunedPkgs = optional (strOption+                                   (long "prune" <>+                                    metavar "PACKAGES" <>+                                    help ("Prune each package name " <>+                                          "from the comma separated list " <>+                                          "of package names PACKAGES")))+        testTargets = switch (long "test" <>+                              help "Consider dependencies of test components")+        benchTargets = switch (long "bench" <>+                               help "Consider dependencies of benchmark components")++        splitNames :: String -> [String]+        splitNames = map (takeWhile (not . isSpace) . dropWhile isSpace) . splitOn ","++-- | Parser for arguments to `stack list-dependencies`.+listDepsOptsParser :: Parser ListDepsOpts+listDepsOptsParser = ListDepsOpts+                 <$> dotOptsParser True -- Default for --external is True.+                 <*> fmap escapeSep+                     (textOption (long "separator" <>+                                  metavar "SEP" <>+                                  help ("Separator between package name " <>+                                        "and package version.") <>+                                  value " " <>+                                  showDefault))+                 <*> boolFlags False+                                "license"+                                "printing of dependency licenses instead of versions"+                                idm+  where escapeSep sep = T.replace "\\t" "\t" (T.replace "\\n" "\n" sep)
+ src/Stack/Options/ExecParser.hs view
@@ -0,0 +1,56 @@+module Stack.Options.ExecParser where++import           Data.Monoid.Extra+import           Options.Applicative+import           Options.Applicative.Builder.Extra+import           Stack.Types.Config++-- | Parser for exec command+execOptsParser :: Maybe SpecialExecCmd -> Parser ExecOpts+execOptsParser mcmd =+    ExecOpts+        <$> maybe eoCmdParser pure mcmd+        <*> eoArgsParser+        <*> execOptsExtraParser+  where+    eoCmdParser = ExecCmd <$> strArgument (metavar "CMD")+    eoArgsParser = many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)"))++evalOptsParser :: String -- ^ metavar+               -> Parser EvalOpts+evalOptsParser meta =+    EvalOpts+        <$> eoArgsParser+        <*> execOptsExtraParser+  where+    eoArgsParser :: Parser String+    eoArgsParser = strArgument (metavar meta)++-- | Parser for extra options to exec command+execOptsExtraParser :: Parser ExecOptsExtra+execOptsExtraParser = eoPlainParser <|>+                      ExecOptsEmbellished+                         <$> eoEnvSettingsParser+                         <*> eoPackagesParser+  where+    eoEnvSettingsParser :: Parser EnvSettings+    eoEnvSettingsParser = EnvSettings+        <$> pure True+        <*> boolFlags True+                "ghc-package-path"+                "setting the GHC_PACKAGE_PATH variable for the subprocess"+                idm+        <*> boolFlags True+                "stack-exe"+                "setting the STACK_EXE environment variable to the path for the stack executable"+                idm+        <*> pure False++    eoPackagesParser :: Parser [String]+    eoPackagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))++    eoPlainParser :: Parser ExecOptsExtra+    eoPlainParser = flag' ExecOptsPlain+                          (long "plain" <>+                           help "Use an unmodified environment (only useful with Docker)")+
+ src/Stack/Options/GhcBuildParser.hs view
@@ -0,0 +1,24 @@+module Stack.Options.GhcBuildParser where++import           Data.Monoid.Extra+import           Options.Applicative+import           Options.Applicative.Types+import           Stack.Options.Utils+import           Stack.Types.CompilerBuild++-- | GHC build parser+ghcBuildParser :: Bool -> Parser CompilerBuild+ghcBuildParser hide =+    option+        readGHCBuild+        (long "ghc-build" <> metavar "BUILD" <>+         help+             "Specialized GHC build, e.g. 'gmp4' or 'standard' (usually auto-detected)" <>+         hideMods hide+        )+  where+    readGHCBuild = do+        s <- readerAsk+        case parseCompilerBuild s of+            Left e -> readerError (show e)+            Right v -> return v
+ src/Stack/Options/GhcVariantParser.hs view
@@ -0,0 +1,24 @@+module Stack.Options.GhcVariantParser where++import           Data.Monoid.Extra+import           Options.Applicative+import           Options.Applicative.Types         (readerAsk)+import           Stack.Options.Utils+import           Stack.Types.Config++-- | GHC variant parser+ghcVariantParser :: Bool -> Parser GHCVariant+ghcVariantParser hide =+    option+        readGHCVariant+        (long "ghc-variant" <> metavar "VARIANT" <>+         help+             "Specialized GHC variant, e.g. integersimple (incompatible with --system-ghc)" <>+         hideMods hide+        )+  where+    readGHCVariant = do+        s <- readerAsk+        case parseGHCVariant s of+            Left e -> readerError (show e)+            Right v -> return v
+ src/Stack/Options/GhciParser.hs view
@@ -0,0 +1,43 @@+module Stack.Options.GhciParser where++import Data.Monoid.Extra+import Data.Version (showVersion)+import Options.Applicative+import Options.Applicative.Args+import Options.Applicative.Builder.Extra+import Paths_stack as Meta+import Stack.Config (packagesParser)+import Stack.Ghci (GhciOpts (..))++-- | Parser for GHCI options+ghciOptsParser :: Parser GhciOpts+ghciOptsParser = GhciOpts+             <$> many+                   (textArgument+                        (metavar "TARGET/FILE" <>+                         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" <>+                                    help "Additional options passed to GHCi")))+             <*> optional+                     (strOption (long "with-ghc" <>+                                 metavar "GHC" <>+                                 help "Use this GHC to run GHCi"))+             <*> (not <$> boolFlags True "load" "load modules on start-up" idm)+             <*> packagesParser+             <*> optional+                     (textOption+                           (long "main-is" <>+                            metavar "TARGET" <>+                            help "Specify which target should contain the main \+                                 \module to load, such as for an executable for \+                                 \test suite or benchmark."))+             <*> switch (long "load-local-deps" <> help "Load all local dependencies of your targets")+             -- TODO: deprecate this? probably useless.+             <*> switch (long "skip-intermediate-deps" <> help "Skip loading intermediate target dependencies" <> internal)+             <*> boolFlags True "package-hiding" "package hiding" idm+             <*> switch (long "no-build" <> help "Don't build before launching GHCi" <> internal)
+ src/Stack/Options/GlobalParser.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE RecordWildCards #-}++module Stack.Options.GlobalParser where++import           Control.Monad.Logger              (LogLevel (..))+import           Data.Monoid.Extra+import           Options.Applicative+import           Options.Applicative.Builder.Extra+import qualified Stack.Docker                      as Docker+import           Stack.Init+import           Stack.Options.ConfigParser+import           Stack.Options.LogLevelParser+import           Stack.Options.ResolverParser+import           Stack.Options.Utils+import           Stack.Types.Config+import           Stack.Types.Docker++-- | Parser for global command-line options.+globalOptsParser :: GlobalOptsContext -> Maybe LogLevel -> Parser GlobalOptsMonoid+globalOptsParser kind defLogLevel =+    GlobalOptsMonoid <$>+    optionalFirst (strOption (long Docker.reExecArgName <> hidden <> internal)) <*>+    optionalFirst (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*>+    (First <$> logLevelOptsParser hide0 defLogLevel) <*>+    firstBoolFlags+        "time-in-log"+        "inclusion of timings in logs, for the purposes of using diff with logs"+        hide <*>+    configOptsParser kind <*>+    optionalFirst (abstractResolverOptsParser hide0) <*>+    optionalFirst (compilerOptsParser hide0) <*>+    firstBoolFlags+        "terminal"+        "overriding terminal detection in the case of running in a false terminal"+        hide <*>+    optionalFirst (option readColorWhen+        (long "color" <>+         metavar "WHEN" <>+         help "Specify when to use color in output; WHEN is 'always', 'never', or 'auto'" <>+         hide)) <*>+    optionalFirst+        (strOption+            (long "stack-yaml" <>+             metavar "STACK-YAML" <>+             help ("Override project stack.yaml file " <>+                   "(overrides any STACK_YAML environment variable)") <>+             hide))+  where+    hide = hideMods hide0+    hide0 = kind /= OuterGlobalOpts++-- | Create GlobalOpts from GlobalOptsMonoid.+globalOptsFromMonoid :: Bool -> GlobalOptsMonoid -> GlobalOpts+globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts+    { globalReExecVersion = getFirst globalMonoidReExecVersion+    , globalDockerEntrypoint = getFirst globalMonoidDockerEntrypoint+    , globalLogLevel = fromFirst defaultLogLevel globalMonoidLogLevel+    , globalTimeInLog = fromFirst True globalMonoidTimeInLog+    , globalConfigMonoid = globalMonoidConfigMonoid+    , globalResolver = getFirst globalMonoidResolver+    , globalCompiler = getFirst globalMonoidCompiler+    , globalTerminal = fromFirst defaultTerminal globalMonoidTerminal+    , globalColorWhen = fromFirst ColorAuto globalMonoidColorWhen+    , globalStackYaml = getFirst globalMonoidStackYaml }++initOptsParser :: Parser InitOpts+initOptsParser =+    InitOpts <$> searchDirs+             <*> solver <*> omitPackages+             <*> overwrite <*> fmap not ignoreSubDirs+  where+    searchDirs =+      many (textArgument+              (metavar "DIRS" <>+               help "Directories to include, default is current directory."))+    ignoreSubDirs = switch (long "ignore-subdirs" <>+                           help "Do not search for .cabal files in sub directories")+    overwrite = switch (long "force" <>+                       help "Force overwriting an existing stack.yaml")+    omitPackages = switch (long "omit-packages" <>+                           help "Exclude conflicting or incompatible user packages")+    solver = switch (long "solver" <>+             help "Use a dependency solver to determine extra dependencies")
+ src/Stack/Options/HaddockParser.hs view
@@ -0,0 +1,20 @@+module Stack.Options.HaddockParser where++import           Data.Maybe+import           Data.Monoid.Extra+import           Options.Applicative+import           Options.Applicative.Args+import           Stack.Options.Utils+import           Stack.Types.Config++-- | Parser for haddock arguments.+haddockOptsParser :: Bool -> Parser HaddockOptsMonoid+haddockOptsParser hide0 =+  HaddockOptsMonoid <$> fmap (fromMaybe [])+                             (optional+                              (argsOption+                               (long "haddock-arguments" <>+                                metavar "HADDOCK_ARGS" <>+                                help "Arguments passed to the haddock program" <>+                                hide)))+  where hide = hideMods hide0
+ src/Stack/Options/HpcReportParser.hs view
@@ -0,0 +1,33 @@+module Stack.Options.HpcReportParser where++import           Data.Monoid.Extra+import qualified Data.Text                         as T+import           Options.Applicative+import           Options.Applicative.Builder.Extra+import           Options.Applicative.Types         (readerAsk)+import           Stack.Coverage                    (HpcReportOpts (..))+import           Stack.Types.Config++-- | Parser for @stack hpc report@.+hpcReportOptsParser :: Parser HpcReportOpts+hpcReportOptsParser = HpcReportOpts+    <$> many (textArgument $ metavar "TARGET_OR_TIX")+    <*> switch (long "all" <> help "Use results from all packages and components involved in previous --coverage run")+    <*> optional (strOption (long "destdir" <> 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" <>+         help+             "How PVP version bounds should be added to .cabal file: none, lower, upper, both")+  where+    readPvpBounds = do+        s <- readerAsk+        case parsePvpBounds $ T.pack s of+            Left e ->+                readerError e+            Right v ->+                return v
+ src/Stack/Options/LogLevelParser.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}++module Stack.Options.LogLevelParser where++import           Control.Monad.Logger              (LogLevel (..))+import           Data.Monoid.Extra+import qualified Data.Text                         as T+import           Options.Applicative+import           Stack.Options.Utils++-- | Parser for a logging level.+logLevelOptsParser :: Bool -> Maybe LogLevel -> Parser (Maybe LogLevel)+logLevelOptsParser hide defLogLevel =+  fmap (Just . parse)+       (strOption (long "verbosity" <>+                   metavar "VERBOSITY" <>+                   help "Verbosity: silent, error, warn, info, debug" <>+                   hideMods hide)) <|>+  flag' (Just verboseLevel)+       (short 'v' <> long "verbose" <>+        help ("Enable verbose mode: verbosity level \"" <> showLevel verboseLevel <> "\"") <>+        hideMods hide) <|>+  flag' (Just silentLevel)+       (long "silent" <>+        help ("Enable silent mode: verbosity level \"" <> showLevel silentLevel <> "\"") <>+        hideMods hide) <|>+  pure defLogLevel+  where verboseLevel = LevelDebug+        silentLevel = LevelOther "silent"+        showLevel l =+          case l of+            LevelDebug -> "debug"+            LevelInfo -> "info"+            LevelWarn -> "warn"+            LevelError -> "error"+            LevelOther x -> T.unpack x+        parse s =+          case s of+            "debug" -> LevelDebug+            "info" -> LevelInfo+            "warn" -> LevelWarn+            "error" -> LevelError+            _ -> LevelOther (T.pack s)
+ src/Stack/Options/NewParser.hs view
@@ -0,0 +1,34 @@+module Stack.Options.NewParser where++import qualified Data.Map.Strict                   as M+import           Data.Monoid.Extra+import           Options.Applicative+import           Stack.Init+import           Stack.New+import           Stack.Options.GlobalParser+import           Stack.Types.PackageName+import           Stack.Types.TemplateName++-- | Parser for @stack new@.+newOptsParser :: Parser (NewOpts,InitOpts)+newOptsParser = (,) <$> newOpts <*> initOptsParser+  where+    newOpts =+        NewOpts <$>+        packageNameArgument+            (metavar "PACKAGE_NAME" <> help "A valid package name.") <*>+        switch+            (long "bare" <>+             help "Do not create a subdirectory for the project") <*>+        optional (templateNameArgument+            (metavar "TEMPLATE_NAME" <>+             help "Name of a template or a local template in a file or a URL.\+                  \ For example: foo or foo.hsfiles or ~/foo or\+                  \ https://example.com/foo.hsfiles")) <*>+        fmap+            M.fromList+            (many+                 (templateParamArgument+                      (short 'p' <> long "param" <> metavar "KEY:VALUE" <>+                       help+                           "Parameter for the template in the format key:value")))
+ src/Stack/Options/NixParser.hs view
@@ -0,0 +1,56 @@+module Stack.Options.NixParser where++import           Data.Monoid.Extra+import qualified Data.Text                         as T+import           Options.Applicative+import           Options.Applicative.Args+import           Options.Applicative.Builder.Extra+import           Stack.Nix+import           Stack.Options.Utils+import           Stack.Types.Nix++nixOptsParser :: Bool -> Parser NixOptsMonoid+nixOptsParser hide0 = overrideActivation <$>+  (NixOptsMonoid+  <$> pure (Any False)+  <*> firstBoolFlags nixCmdName+                     "use of a Nix-shell. Implies 'system-ghc: true'"+                     hide+  <*> firstBoolFlags "nix-pure"+                     "use of a pure Nix-shell. Implies 'system-ghc: true'"+                     hide+  <*> optionalFirst+          (textArgsOption+              (long "nix-packages" <>+               metavar "NAMES" <>+               help "List of packages that should be available in the nix-shell (space separated)" <>+               hide))+  <*> optionalFirst+          (option+              str+              (long "nix-shell-file" <>+               metavar "FILEPATH" <>+               help "Nix file to be used to launch a nix-shell (for regular Nix users)" <>+               hide))+  <*> optionalFirst+          (textArgsOption+              (long "nix-shell-options" <>+               metavar "OPTIONS" <>+               help "Additional options passed to nix-shell" <>+               hide))+  <*> optionalFirst+          (textArgsOption+              (long "nix-path" <>+               metavar "PATH_OPTIONS" <>+               help "Additional options to override NIX_PATH parts (notably 'nixpkgs')" <>+               hide))+  <*> firstBoolFlags "nix-add-gc-roots"+                     "addition of packages to the nix GC roots so nix-collect-garbage doesn't remove them"+                     hide+  )+  where+    hide = hideMods hide0+    overrideActivation m =+      if m /= mempty then m { nixMonoidEnable = (First . Just . fromFirst True) (nixMonoidEnable m) }+      else m+    textArgsOption = fmap (map T.pack) . argsOption
+ src/Stack/Options/PackageParser.hs view
@@ -0,0 +1,31 @@+module Stack.Options.PackageParser where++import qualified Data.Map                          as Map+import           Data.Map.Strict                   (Map)+import           Options.Applicative+import           Options.Applicative.Types         (readerAsk)+import           Stack.Types.FlagName+import           Stack.Types.PackageName++-- | Parser for package:[-]flag+readFlag :: ReadM (Map (Maybe PackageName) (Map FlagName Bool))+readFlag = do+    s <- readerAsk+    case break (== ':') s of+        (pn, ':':mflag) -> do+            pn' <-+                case parsePackageNameFromString pn of+                    Nothing+                        | pn == "*" -> return Nothing+                        | otherwise -> readerError $ "Invalid package name: " ++ pn+                    Just x -> return $ Just x+            let (b, flagS) =+                    case mflag of+                        '-':x -> (False, x)+                        _ -> (True, mflag)+            flagN <-+                case parseFlagNameFromString flagS of+                    Nothing -> readerError $ "Invalid flag name: " ++ flagS+                    Just x -> return x+            return $ Map.singleton pn' $ Map.singleton flagN b+        _ -> readerError "Must have a colon"
+ src/Stack/Options/ResolverParser.hs view
@@ -0,0 +1,33 @@+module Stack.Options.ResolverParser where++import           Data.Monoid.Extra+import qualified Data.Text                         as T+import           Options.Applicative+import           Options.Applicative.Types         (readerAsk)+import           Stack.Options.Utils+import           Stack.Types.Compiler+import           Stack.Types.Resolver++-- | Parser for the resolver+abstractResolverOptsParser :: Bool -> Parser AbstractResolver+abstractResolverOptsParser hide =+    option readAbstractResolver+        (long "resolver" <>+         metavar "RESOLVER" <>+         help "Override resolver in project file" <>+         hideMods hide)++compilerOptsParser :: Bool -> Parser CompilerVersion+compilerOptsParser hide =+    option readCompilerVersion+        (long "compiler" <>+         metavar "COMPILER" <>+         help "Use the specified compiler" <>+         hideMods hide)++readCompilerVersion :: ReadM CompilerVersion+readCompilerVersion = do+    s <- readerAsk+    case parseCompilerVersion (T.pack s) of+        Nothing -> readerError $ "Failed to parse compiler: " ++ s+        Just x -> return x
+ src/Stack/Options/SolverParser.hs view
@@ -0,0 +1,11 @@+module Stack.Options.SolverParser where++import           Options.Applicative+import           Options.Applicative.Builder.Extra++-- | Parser for @solverCmd@+solverOptsParser :: Parser Bool+solverOptsParser = boolFlags False+    "update-config"+    "Automatically update stack.yaml with the solver's recommendations"+    idm
+ src/Stack/Options/TestParser.hs view
@@ -0,0 +1,38 @@+module Stack.Options.TestParser where++import           Data.Maybe+import           Data.Monoid.Extra+import           Options.Applicative+import           Options.Applicative.Args+import           Options.Applicative.Builder.Extra+import           Stack.Options.Utils+import           Stack.Types.Config++-- | Parser for test arguments.+-- FIXME hide args+testOptsParser :: Bool -> Parser TestOptsMonoid+testOptsParser hide0 =+    TestOptsMonoid+        <$> firstBoolFlags+                "rerun-tests"+                "running already successful tests"+                hide+        <*> fmap+                (fromMaybe [])+                (optional+                    (argsOption+                        (long "test-arguments" <>+                         metavar "TEST_ARGS" <>+                         help "Arguments passed in to the test suite program" <>+                         hide)))+        <*> optionalFirst+                (switch+                    (long "coverage" <>+                     help "Generate a code coverage report" <>+                     hide))+        <*> optionalFirst+                (switch+                    (long "no-run-tests" <>+                     help "Disable running of tests. (Tests will still be built.)" <>+                     hide))+   where hide = hideMods hide0
+ src/Stack/Options/Utils.hs view
@@ -0,0 +1,20 @@+module Stack.Options.Utils where++import           Data.Monoid.Extra+import           Options.Applicative++-- | If argument is True, hides the option from usage and help+hideMods :: Bool -> Mod f a+hideMods hide = if hide then internal <> hidden else idm++-- | Allows adjust global options depending on their context+-- Note: This was being used to remove ambibuity between the local and global+-- implementation of stack init --resolver option. Now that stack init has no+-- local --resolver this is not being used anymore but the code is kept for any+-- similar future use cases.+data GlobalOptsContext+    = OuterGlobalOpts -- ^ Global options before subcommand name+    | OtherCmdGlobalOpts -- ^ Global options following any other subcommand+    | BuildCmdGlobalOpts+    | GhciCmdGlobalOpts+    deriving (Show, Eq)
src/Stack/Package.hs view
@@ -40,8 +40,8 @@   ,cabalFilePackageId)   where -import Prelude ()-import Prelude.Compat+import           Prelude ()+import           Prelude.Compat  import           Control.Arrow ((&&&)) import           Control.Exception hiding (try,catch)@@ -78,7 +78,7 @@ import           Distribution.ParseUtils import           Distribution.Simple.Utils import           Distribution.System (OS (..), Arch, Platform (..))-import           Distribution.Text (display, simpleParse)+import qualified Distribution.Text as D import qualified Distribution.Verbosity as D import qualified Hpack import qualified Hpack.Config as Hpack@@ -89,15 +89,16 @@ import           Safe (headDef, tailSafe) import           Stack.Build.Installed import           Stack.Constants+import           Stack.PrettyPrint+import           Stack.Types.Build+import           Stack.Types.Compiler+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.Version-import           Stack.Types.Config-import           Stack.Types.Build-import           Stack.Types.Package-import           Stack.Types.Compiler import qualified System.Directory as D import           System.FilePath (splitExtensions, replaceExtension) import qualified System.FilePath as FilePath@@ -178,10 +179,10 @@                 ("Cabal file warning in " <> T.pack (toFilePath cabalfp) <>                  ": " <>                  T.pack x)-        (UTFWarning line msg) ->+        (UTFWarning ln msg) ->             $logWarn                 ("Cabal file warning in " <> T.pack (toFilePath cabalfp) <> ":" <>-                 T.pack (show line) <>+                 T.pack (show ln) <>                  ": " <>                  T.pack msg) @@ -213,6 +214,7 @@     Package     { packageName = name     , packageVersion = fromCabalVersion (pkgVersion pkgId)+    , packageLicense = license pkg     , packageDeps = deps     , packageFiles = pkgFiles     , packageTools = packageDescTools pkg@@ -245,28 +247,28 @@     }   where     pkgFiles = GetPackageFiles $-        \cabalfp ->-             do let pkgDir = parent cabalfp-                distDir <- distDirFromDir pkgDir-                (componentModules,componentFiles,dataFiles',warnings) <--                    runReaderT-                        (packageDescModulesAndFiles pkg)-                        (cabalfp, buildDir distDir)-                setupFiles <--                    if buildType pkg `elem` [Nothing, Just Custom]-                    then do-                        let setupHsPath = pkgDir </> $(mkRelFile "Setup.hs")-                            setupLhsPath = pkgDir </> $(mkRelFile "Setup.lhs")-                        setupHsExists <- doesFileExist setupHsPath-                        if setupHsExists then return (S.singleton setupHsPath) else do-                            setupLhsExists <- doesFileExist setupLhsPath-                            if setupLhsExists then return (S.singleton setupLhsPath) else return S.empty-                    else return S.empty-                buildFiles <- liftM (S.insert cabalfp . S.union setupFiles) $ do-                    let hpackPath = pkgDir </> $(mkRelFile Hpack.packageConfig)-                    hpackExists <- doesFileExist hpackPath-                    return $ if hpackExists then S.singleton hpackPath else S.empty-                return (componentModules, componentFiles, buildFiles <> dataFiles', warnings)+        \cabalfp -> $debugBracket ("getPackageFiles" <+> display cabalfp) $ do+             let pkgDir = parent cabalfp+             distDir <- distDirFromDir pkgDir+             (componentModules,componentFiles,dataFiles',warnings) <-+                 runReaderT+                     (packageDescModulesAndFiles pkg)+                     (cabalfp, buildDir distDir)+             setupFiles <-+                 if buildType pkg `elem` [Nothing, Just Custom]+                 then do+                     let setupHsPath = pkgDir </> $(mkRelFile "Setup.hs")+                         setupLhsPath = pkgDir </> $(mkRelFile "Setup.lhs")+                     setupHsExists <- doesFileExist setupHsPath+                     if setupHsExists then return (S.singleton setupHsPath) else do+                         setupLhsExists <- doesFileExist setupLhsPath+                         if setupLhsExists then return (S.singleton setupLhsPath) else return S.empty+                 else return S.empty+             buildFiles <- liftM (S.insert cabalfp . S.union setupFiles) $ do+                 let hpackPath = pkgDir </> $(mkRelFile Hpack.packageConfig)+                 hpackExists <- doesFileExist hpackPath+                 return $ if hpackExists then S.singleton hpackPath else S.empty+             return (componentModules, componentFiles, buildFiles <> dataFiles', warnings)     pkgId = package pkg     name = fromCabalPackageName (pkgName pkgId)     deps = M.filterWithKey (const . (/= name)) (packageDependencies pkg)@@ -396,7 +398,7 @@       where         isGhc GHC = True         isGhc _ = False-    extOpts = map (("-X" ++) . display) (usedExtensions biBuildInfo)+    extOpts = map (("-X" ++) . D.display) (usedExtensions biBuildInfo)     srcOpts =         map             (("-i" <>) . toFilePathNoTrailingSep)@@ -521,8 +523,8 @@ packageDescTools = concatMap buildTools . allBuildInfo'  -- | This is a copy-paste from Cabal's @allBuildInfo@ function, but with the--- @buildable@ test removed. The reason is that (surprise) Cabal is broken,--- see: https://github.com/haskell/cabal/issues/1725+-- @buildable@ test removed. The implementation is broken.+-- See: https://github.com/haskell/cabal/issues/1725 allBuildInfo' :: PackageDescription -> [BuildInfo] allBuildInfo' pkg_descr = [ bi | Just lib <- [library pkg_descr]                               , let bi = libBuildInfo lib@@ -566,7 +568,7 @@             (mapM                  (asModuleAndFileMap benchComponent benchmarkFiles)                  (benchmarks pkg))-    (dfiles) <- resolveGlobFiles+    dfiles <- resolveGlobFiles                     (extraSrcFiles pkg                         ++ map (dataDir pkg FilePath.</>) (dataFiles pkg))     let modules = libraryMods <> executableMods <> testMods <> benchModules@@ -732,7 +734,7 @@         resolveFilesAndDeps             Nothing             (dirs ++ [dir])-            (names <> exposed)+            names             haskellModuleExts     cfiles <- buildOtherSources build     return (modules, files <> cfiles, warnings)@@ -930,17 +932,17 @@         let unlistedModules =                 foundModules `S.difference`                 S.fromList (mapMaybe dotCabalModule names0)-        cabalfp <- asks fst         return $             if S.null unlistedModules                 then []                 else [ UnlistedModulesWarning-                           cabalfp                            component                            (S.toList unlistedModules)]     warnMissing _missingModules = do         return []-        {- FIXME: the issue with this is it's noisy for modules like Paths_*+        -- TODO: bring this back - see+        -- https://github.com/commercialhaskell/stack/issues/2649+        {-         cabalfp <- asks fst         return $             if null missingModules@@ -992,7 +994,7 @@             dropWhile (not . ("module dependencies:" `C8.isPrefixOf`)) dumpHI         moduleDeps =             S.fromList $-            mapMaybe (simpleParse . T.unpack . decodeUtf8) $+            mapMaybe (D.simpleParse . T.unpack . decodeUtf8) $             C8.words $             C8.concat $             C8.dropWhile (/= ' ') (headDef "" startModuleDeps) :@@ -1001,9 +1003,9 @@             -- The dependent file path is surrounded by quotes but is not escaped.             -- It can be an absolute or relative path.             mapMaybe-                ((fmap T.unpack .+                (fmap T.unpack .                   (T.stripSuffix "\"" <=< T.stripPrefix "\"") .-                  T.dropWhileEnd (== '\r') . decodeUtf8 . C8.dropWhile (/= '"'))) $+                  T.dropWhileEnd (== '\r') . decodeUtf8 . C8.dropWhile (/= '"')) $             filter ("addDependentFile \"" `C8.isPrefixOf`) dumpHI     thDepsResolved <- liftM catMaybes $ forM thDeps $ \x -> do         mresolved <- forgivingAbsence (resolveFile dir x) >>= rejectMissingFile@@ -1041,7 +1043,7 @@         [] -> do             case name of                 DotCabalModule mn-                  | display mn /= paths_pkg pkg -> logPossibilities dirs mn+                  | D.display mn /= paths_pkg pkg -> logPossibilities dirs mn                 _ -> return ()             return Nothing         (candidate:rest) -> do@@ -1093,7 +1095,7 @@          T.intercalate "," (map (T.pack . toFilePath) rest) <>          "), picking " <>          T.pack (toFilePath candidate))-  where showName (DotCabalModule name') = T.pack (display name')+  where showName (DotCabalModule name') = T.pack (D.display name')         showName (DotCabalMain fp) = T.pack fp         showName (DotCabalFile fp) = T.pack fp         showName (DotCabalCFile fp) = T.pack fp@@ -1113,7 +1115,7 @@         _ ->             $logWarn                 ("Unable to find a known candidate for the Cabal entry \"" <>-                 T.pack (display mn) <>+                 T.pack (D.display mn) <>                  "\", but did find: " <>                  T.intercalate ", " (map (T.pack . toFilePath) possibilities) <>                  ". If you are using a custom preprocessor for this module " <>@@ -1128,7 +1130,7 @@                          (map                               filename                               (filter-                                   (isPrefixOf (display name) .+                                   (isPrefixOf (D.display name) .                                     toFilePath . filename)                                    files)))             dirs
src/Stack/PackageDump.hs view
@@ -25,7 +25,7 @@  import           Control.Applicative import           Control.Arrow ((&&&))-import           Control.Exception.Enclosed (tryIO)+import           Control.Exception.Safe (tryIO) import           Control.Monad (liftM) import           Control.Monad.Catch import           Control.Monad.IO.Class@@ -269,14 +269,12 @@     deriving Typeable instance Exception PackageDumpException instance Show PackageDumpException where-    show (MissingSingleField name values) = unlines $ concat-        [ return $ concat-            [ "Expected single value for field name "-            , show name-            , " when parsing ghc-pkg dump output:"-            ]-        , map (\(k, v) -> "    " ++ show (k, v)) (Map.toList values)-        ]+    show (MissingSingleField name values) = unlines $+      return (concat+        [ "Expected single value for field name "+        , show name+        , " when parsing ghc-pkg dump output:"+        ]) ++ map (\(k, v) -> "    " ++ show (k, v)) (Map.toList values)     show (Couldn'tParseField name ls) =         "Couldn't parse the field " ++ show name ++ " from lines: " ++ show ls
src/Stack/PackageIndex.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE DataKinds                  #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveGeneric              #-}@@ -6,6 +7,7 @@ {-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE PatternGuards              #-}@@ -27,20 +29,18 @@  import qualified Codec.Archive.Tar as Tar import           Control.Exception (Exception)-import           Control.Exception.Enclosed (tryIO)+import           Control.Exception.Safe (tryIO) import           Control.Monad (unless, when, liftM, void)-import           Control.Monad.Catch (MonadThrow, throwM, MonadCatch)+import           Control.Monad.Catch (throwM) import qualified Control.Monad.Catch as C import           Control.Monad.IO.Class (MonadIO, liftIO)-import           Control.Monad.Logger                  (MonadLogger, logDebug,-                                                        logInfo, logWarn, logError)+import           Control.Monad.Logger (logDebug, logInfo, logWarn, logError) import           Control.Monad.Reader (asks) import           Control.Monad.Trans.Control import           Data.Aeson.Extended import qualified Data.ByteString.Lazy as L import           Data.Conduit (($$), (=$))-import           Data.Conduit.Binary                   (sinkHandle,-                                                        sourceHandle)+import           Data.Conduit.Binary (sinkHandle, sourceHandle) import           Data.Conduit.Zlib (ungzip) import           Data.Foldable (forM_) import           Data.IORef@@ -76,7 +76,7 @@  -- | Populate the package index caches and return them. populateCache-    :: (MonadIO m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)+    :: (StackMiniM env m, HasConfig env)     => EnvOverride     -> PackageIndex     -> m (Map PackageIdentifier PackageCache)@@ -182,35 +182,23 @@         ]  -- | Require that an index be present, updating if it isn't.-requireIndex :: (MonadIO m,MonadLogger m-                ,MonadReader env m,HasHttpManager env-                ,HasConfig env,MonadBaseControl IO m,MonadCatch m)-             => EnvOverride-             -> PackageIndex-             -> m ()+requireIndex :: (StackMiniM env m, HasConfig env)+             => EnvOverride -> PackageIndex -> m () requireIndex menv index = do     tarFile <- configPackageIndex $ indexName index     exists <- doesFileExist tarFile     unless exists $ updateIndex menv index  -- | Update all of the package indices-updateAllIndices-    :: (MonadIO m,MonadLogger m-       ,MonadReader env m,HasHttpManager env-       ,HasConfig env,MonadBaseControl IO m, MonadCatch m)-    => EnvOverride-    -> m ()+updateAllIndices :: (StackMiniM env m, HasConfig env)+                 => EnvOverride -> m () updateAllIndices menv = do     clearPackageCaches     asks (configPackageIndices . getConfig) >>= mapM_ (updateIndex menv)  -- | Update the index tarball-updateIndex :: (MonadIO m,MonadLogger m-               ,MonadReader env m,HasHttpManager env-               ,HasConfig env,MonadBaseControl IO m, MonadCatch m)-            => EnvOverride-            -> PackageIndex-            -> m ()+updateIndex :: (StackMiniM env m, HasConfig env)+            => EnvOverride -> PackageIndex -> m () updateIndex menv index =   do let name = indexName index          logUpdate mirror = $logSticky $ "Updating package index " <> indexNameText (indexName index) <> " (mirrored at " <> mirror  <> ") ..."@@ -223,7 +211,7 @@         (False, ILGit url) -> logUpdate url >> throwM (GitNotAvailable name)  -- | Update the index Git repo and the index tarball-updateIndexGit :: (MonadIO m,MonadLogger m,MonadReader env m,HasConfig env,MonadBaseControl IO m, MonadCatch m)+updateIndexGit :: (StackMiniM env m, HasConfig env)                => EnvOverride                -> IndexName                -> PackageIndex@@ -247,15 +235,26 @@                   $(mkRelDir "git-update")                 acfDir = suDir </> repoName             repoExists <- doesDirExist acfDir-            unless repoExists-                   (readProcessNull (Just suDir) menv "git" cloneArgs)+            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..."-              (readProcessNull (Just acfDir) menv "git" ["fetch", "--unshallow"])+              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 ["fetch","--tags"])+                    (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))@@ -267,12 +266,12 @@             $logStickyDone "Fetched package index."              when (indexGpgVerify index) $ do-                 result <- C.try $ readProcessNull (Just acfDir) menv "git" ["tag","-v","current-hackage"]+                 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-                             ReadProcessException{} -> $logError $ T.unlines+                             ProcessFailed{} -> $logError $ T.unlines                                  ["Signature verification failed. "                                  ,"Please ensure you've set up your"                                  ,"GPG keychain to accept the D6CF60FD signing key."@@ -302,13 +301,12 @@          $logDebug ("Exporting a tarball to " <> (T.pack . toFilePath) tarFile)          let tarFileTmp = toFilePath tarFile ++ ".tmp"          readProcessNull (Just acfDir) menv-             "git" ["archive","--format=tar","-o",tarFileTmp,"current-hackage"]+             "git" ["--git-dir=.git","archive","--format=tar","-o",tarFileTmp,"current-hackage"]          tarFileTmpPath <- parseAbsFile tarFileTmp          renameFile tarFileTmpPath tarFile  -- | Update the index tarball via HTTP-updateIndexHTTP :: (MonadIO m,MonadLogger m-                   ,MonadThrow m,MonadReader env m,HasHttpManager env,HasConfig env)+updateIndexHTTP :: (StackMiniM env m, HasConfig env)                 => IndexName                 -> PackageIndex                 -> Text -- ^ url@@ -350,7 +348,9 @@ isGitInstalled = flip doesExecutableExist "git"  -- | Delete the package index cache-deleteCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadThrow m) => IndexName -> m ()+deleteCache+    :: (StackMiniM env m, HasConfig env)+    => IndexName -> m () deleteCache indexName' = do     fp <- configPackageIndexCache indexName'     eres <- liftIO $ tryIO $ removeFile fp@@ -360,7 +360,7 @@  -- | Lookup a package's versions from 'IO'. getPackageVersionsIO-    :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)+    :: (StackMiniM env m, HasConfig env)     => m (PackageName -> IO (Set Version)) getPackageVersionsIO = do     getCaches <- getPackageCachesIO@@ -371,7 +371,7 @@ -- -- See 'getPackageCaches' for performance notes. getPackageVersions-    :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)+    :: (StackMiniM env m, HasConfig env)     => PackageName     -> m (Set Version) getPackageVersions pkgName =@@ -387,7 +387,7 @@ -- to access the package caches from Stack.Build.ConstructPlan -- has been found. getPackageCachesIO-    :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)+    :: (StackMiniM env m, HasConfig env)     => m (IO (Map PackageIdentifier (PackageIndex, PackageCache))) getPackageCachesIO = toIO getPackageCaches   where@@ -406,7 +406,7 @@ -- This has two levels of caching: in memory, and the on-disk cache. So, -- feel free to call this function multiple times. getPackageCaches-    :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)+    :: (StackMiniM env m, HasConfig env)     => m (Map PackageIdentifier (PackageIndex, PackageCache)) getPackageCaches = do     menv <- getMinimalEnvOverride@@ -428,8 +428,7 @@  -- | Clear the in-memory hackage index cache. This is needed when the -- hackage index is updated.-clearPackageCaches :: (MonadIO m, MonadReader env m, HasConfig env)-                   => m ()+clearPackageCaches :: (StackMiniM env m, HasConfig env) => m () clearPackageCaches = do     cacheRef <- asks (configPackageCaches . getConfig)     liftIO $ writeIORef cacheRef Nothing
src/Stack/Path.hs view
@@ -179,7 +179,7 @@     , ( "Local project documentation root"       , "local-doc-root"       , \pi' -> T.pack (toFilePathNoTrailingSep (piLocalRoot pi' </> docDirSuffix)))-    , ( "Dist work directory"+    , ( "Dist work directory, relative to package directory"       , "dist-dir"       , T.pack . toFilePathNoTrailingSep . piDistDir )     , ( "Where HPC reports and tix files are stored"
src/Stack/PrettyPrint.hs view
@@ -2,18 +2,23 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}  module Stack.PrettyPrint     (       -- * Pretty printing functions-      displayPlain, displayAnsiIfPossible+      displayPlain, displayWithColor       -- * Logging based on pretty-print typeclass     , prettyDebug, prettyInfo, prettyWarn, prettyError+    , debugBracket       -- * Color utils       -- | These are preferred to colors directly, so that we can       -- encourage consistency of color meanings.     , errorRed, goodGreen, shellMagenta     , displayTargetPkgId, displayCurrentPkgId, displayErrorPkgId+    , displayMilliseconds+      -- * Formatting utils+    , bulletedList       -- * Re-exports from "Text.PrettyPrint.Leijen.Extended"     , Display(..), AnsiDoc, AnsiAnn(..), HasAnsiAnn(..), Doc     , nest, line, linebreak, group, softline, softbreak@@ -24,23 +29,28 @@     , enclose, squotes, dquotes, parens, angles, braces, brackets     ) where +import           Control.Exception.Lifted import           Control.Monad.Logger import           Control.Monad.Reader+import           Data.List (intersperse)+import           Data.Monoid import           Data.String (fromString) import qualified Data.Text as T import           Language.Haskell.TH import           Path import           Stack.Types.Internal+import           Stack.Types.Package import           Stack.Types.PackageIdentifier import           Stack.Types.PackageName import           Stack.Types.Version+import qualified System.Clock as Clock import           Text.PrettyPrint.Leijen.Extended -displayAnsiIfPossible-    :: (HasTerminal env, MonadReader env m, Display a, HasAnsiAnn (Ann a))+displayWithColor+    :: (HasLogOptions env, MonadReader env m, Display a, HasAnsiAnn (Ann a))     => a -> m T.Text-displayAnsiIfPossible x = do-    useAnsi <- asks getAnsiTerminal+displayWithColor x = do+    useAnsi <- asks (logUseColor . getLogOptions)     return $ if useAnsi then displayAnsi x else displayPlain x  -- TODO: switch to using implicit callstacks once 7.8 support is dropped@@ -48,26 +58,49 @@ prettyDebug :: Q Exp prettyDebug = do     loc <- location-    [e| monadLoggerLog loc "" LevelDebug <=< displayAnsiIfPossible |]+    [e| monadLoggerLog loc "" LevelDebug <=< displayWithColor |]  prettyInfo :: Q Exp prettyInfo = do     loc <- location-    [e| monadLoggerLog loc "" LevelInfo <=< displayAnsiIfPossible |]+    [e| monadLoggerLog loc "" LevelInfo <=< displayWithColor |]  prettyWarn :: Q Exp prettyWarn = do     loc <- location-    [e| monadLoggerLog loc "" LevelWarn <=< displayAnsiIfPossible |]+    [e| monadLoggerLog loc "" LevelWarn <=< displayWithColor . (line <>) . (warningYellow "Warning:" <+>) |]  prettyError :: Q Exp prettyError = do     loc <- location-    [e| monadLoggerLog loc "" LevelError <=< displayAnsiIfPossible |]+    [e| monadLoggerLog loc "" LevelError <=< displayWithColor . (line <>) . (errorRed "Error:" <+>) |] +debugBracket :: Q Exp+debugBracket = do+    loc <- location+    [e| \msg f -> do+            let output = monadLoggerLog loc "" LevelDebug <=< displayWithColor+            output $ "Start: " <> msg+            start <- liftIO $ Clock.getTime Clock.Monotonic+            x <- f `catch` \ex -> do+                end <- liftIO $ Clock.getTime Clock.Monotonic+                let diff = Clock.diffTimeSpec start end+                output $ "Finished with exception in" <+> displayMilliseconds diff <> ":" <+>+                    msg <> line <>+                    "Exception thrown: " <> fromString (show ex)+                throw (ex :: SomeException)+            end <- liftIO $ Clock.getTime Clock.Monotonic+            let diff = Clock.diffTimeSpec start end+            output $ "Finished in" <+> displayMilliseconds diff <> ":" <+> msg+            return x+      |]+ errorRed :: AnsiDoc -> AnsiDoc errorRed = dullred +warningYellow :: AnsiDoc -> AnsiDoc+warningYellow = yellow+ goodGreen :: AnsiDoc -> AnsiDoc goodGreen = green @@ -97,3 +130,14 @@  instance Display (Path b Dir) where     display = bold . blue . fromString . toFilePath++instance Display (PackageName, NamedComponent) where+    display = cyan . fromString . T.unpack . renderPkgComponent++-- Display milliseconds.+displayMilliseconds :: Clock.TimeSpec -> AnsiDoc+displayMilliseconds t = goodGreen $+    (fromString . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> "ms"++bulletedList :: [AnsiDoc] -> AnsiDoc+bulletedList = mconcat . intersperse line . map ("*" <+>)
src/Stack/Runners.hs view
@@ -24,7 +24,6 @@ import           Control.Monad.Trans.Control import           Data.IORef import           Data.Traversable-import           Network.HTTP.Client import           Path import           Path.IO import           Stack.Config@@ -38,12 +37,11 @@ import           System.IO import           System.FileLock -loadCompilerVersion :: Manager-                    -> GlobalOpts-                    -> LoadConfig (StackLoggingT IO)+loadCompilerVersion :: GlobalOpts+                    -> LoadConfig (StackT () IO)                     -> IO CompilerVersion-loadCompilerVersion manager go lc = do-    bconfig <- runStackLoggingTGlobal manager go $+loadCompilerVersion go lc = do+    bconfig <- runStackTGlobal () go $       lcLoadBuildConfig lc (globalCompiler go)     return $ bcWantedCompiler bconfig @@ -92,13 +90,13 @@     -> StackT Config IO ()     -> IO () withConfigAndLock go@GlobalOpts{..} inner = do-    (manager, lc) <- loadConfigWithOpts go+    lc <- loadConfigWithOpts go     withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk ->-        runStackTGlobal manager (lcConfig lc) go $+        runStackTGlobal (lcConfig lc) go $             Docker.reexecWithOptionalContainer                 (lcProjectRoot lc)                 Nothing-                (runStackTGlobal manager (lcConfig lc) go inner)+                (runStackTGlobal (lcConfig lc) go inner)                 Nothing                 (Just $ munlockFile lk) @@ -109,11 +107,10 @@     -> StackT Config IO ()     -> IO () withGlobalConfigAndLock go@GlobalOpts{..} inner = do-    manager <- newTLSManager-    lc <- runStackLoggingTGlobal manager go $+    lc <- runStackTGlobal () go $         loadConfigMaybeProject globalConfigMonoid Nothing Nothing     withUserFileLock go (configStackRoot $ lcConfig lc) $ \_lk ->-        runStackTGlobal manager (lcConfig lc) go inner+        runStackTGlobal (lcConfig lc) go inner  -- For now the non-locking version just unlocks immediately. -- That is, there's still a serialization point.@@ -149,7 +146,7 @@     -- installed on the host OS.     -> IO () withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do-    (manager, lc) <- loadConfigWithOpts go+    lc <- loadConfigWithOpts go      withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk0 -> do       -- A local bit of state for communication between callbacks:@@ -167,37 +164,35 @@                  inner lk2        let inner'' lk = do-              bconfig <- runStackLoggingTGlobal manager go $+              bconfig <- runStackTGlobal () go $                   lcLoadBuildConfig lc globalCompiler               envConfig <-                  runStackTGlobal-                     manager bconfig go+                     bconfig go                      (setupEnv Nothing)               runStackTGlobal-                  manager                   envConfig                   go                   (inner' lk) -      let getCompilerVersion = loadCompilerVersion manager go lc-      runStackTGlobal manager (lcConfig lc) go $+      let getCompilerVersion = loadCompilerVersion go lc+      runStackTGlobal (lcConfig lc) go $         Docker.reexecWithOptionalContainer                  (lcProjectRoot lc)                  mbefore-                 (runStackTGlobal manager (lcConfig lc) go $+                 (runStackTGlobal (lcConfig lc) go $                     Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion (inner'' lk0))                  mafter                  (Just $ liftIO $                       do lk' <- readIORef curLk                          munlockFile lk') --- | Load the configuration with a manager. Convenience function used+-- | Load the configuration. Convenience function used -- throughout this module.-loadConfigWithOpts :: GlobalOpts -> IO (Manager,LoadConfig (StackLoggingT IO))+loadConfigWithOpts :: GlobalOpts -> IO (LoadConfig (StackT () IO)) loadConfigWithOpts go@GlobalOpts{..} = do-    manager <- newTLSManager     mstackYaml <- forM globalStackYaml resolveFile'-    lc <- runStackLoggingTGlobal manager go $ do+    runStackTGlobal () go $ do         lc <- loadConfig globalConfigMonoid globalResolver mstackYaml         -- If we have been relaunched in a Docker container, perform in-container initialization         -- (switch UID, etc.).  We do this after first loading the configuration since it must@@ -206,18 +201,16 @@             Just de -> Docker.entrypoint (lcConfig lc) de             Nothing -> return ()         return lc-    return (manager,lc)  withMiniConfigAndLock     :: GlobalOpts     -> StackT MiniConfig IO ()     -> IO () withMiniConfigAndLock go@GlobalOpts{..} inner = do-    manager <- newTLSManager-    miniConfig <- runStackLoggingTGlobal manager go $ do+    miniConfig <- runStackTGlobal () go $ do         lc <- loadConfigMaybeProject globalConfigMonoid globalResolver Nothing-        loadMiniConfig manager (lcConfig lc)-    runStackTGlobal manager miniConfig go inner+        loadMiniConfig (lcConfig lc)+    runStackTGlobal miniConfig go inner  -- | Unlock a lock file, if the value is Just munlockFile :: MonadIO m => Maybe FileLock -> m ()
src/Stack/SDist.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE ViewPatterns          #-} {-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE TypeFamilies          #-} -- Create a source distribution tarball module Stack.SDist     ( getSDistTarball@@ -21,10 +22,10 @@ import           Control.Monad.Catch import           Control.Monad.IO.Class import           Control.Monad.Logger-import           Control.Monad.Reader (MonadReader, asks)+import           Control.Monad.Reader (asks) import           Control.Monad.Trans.Control (liftBaseWith)-import           Control.Monad.Trans.Resource import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import           Data.Data (Data, Typeable, cast, gmapT) import           Data.Either (partitionEithers)@@ -36,6 +37,7 @@ import           Data.Monoid ((<>)) import qualified Data.Set as Set import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE import           Data.Time.Clock.POSIX@@ -44,7 +46,6 @@ import           Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) import           Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion) import           Distribution.Version.Extra-import           Network.HTTP.Client.Conduit (HasHttpManager) import           Path import           Path.IO hiding (getModificationTime, getPermissions) import           Prelude -- Fix redundant import warnings@@ -55,13 +56,13 @@ import           Stack.Build.Target import           Stack.Constants import           Stack.Package+import           Stack.Types.Build+import           Stack.Types.Config+import           Stack.Types.Package import           Stack.Types.PackageIdentifier import           Stack.Types.PackageName+import           Stack.Types.StackT import           Stack.Types.Version-import           Stack.Types.Config-import           Stack.Types.Build-import           Stack.Types.Package-import           Stack.Types.Internal import           System.Directory (getModificationTime, getPermissions) import qualified System.FilePath as FP @@ -79,8 +80,6 @@     "Package check reported the following errors:\n" ++     (intercalate "\n" . fmap show . NE.toList $ xs) -type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)- -- | Given the path to a local package, creates its source -- distribution tarball. --@@ -88,7 +87,7 @@ -- tarball is not written to the disk and instead yielded as a lazy -- bytestring. getSDistTarball-  :: M env m+  :: (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@@ -107,7 +106,12 @@     -- 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-            (Tar.toTarPath isDir (pkgId FP.</> fp))+            (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)         packDir = packWith Tar.packDirectoryEntry True         packFile fp@@ -124,11 +128,11 @@     return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries)))  -- | Get the PVP bounds-enabled version of the given cabal file-getCabalLbs :: M env m => PvpBounds -> FilePath -> m L.ByteString+getCabalLbs :: (StackM env m, HasEnvConfig env) => PvpBounds -> FilePath -> m L.ByteString getCabalLbs pvpBounds fp = do     bs <- liftIO $ S.readFile fp     (_warnings, gpd) <- readPackageUnresolvedBS Nothing bs-    (_, _, _, _, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI+    (_, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI     menv <- getMinimalEnvOverride     (installedMap, _, _, _) <- getInstalled menv GetInstalledOpts                                 { getInstalledProfiling = False@@ -178,7 +182,7 @@ -- | Read in a 'LocalPackage' config.  This makes some default decisions -- about 'LocalPackage' fields that might not be appropriate for other -- use-cases.-readLocalPackage :: M env m => Path Abs Dir -> m LocalPackage+readLocalPackage :: (StackM env m, HasEnvConfig env) => Path Abs Dir -> m LocalPackage readLocalPackage pkgDir = do     cabalfp <- findOrGenerateCabalFile pkgDir     config  <- getDefaultPackageConfig@@ -203,14 +207,14 @@         }  -- | Returns a newline-separate list of paths, and the absolute path to the .cabal file.-getSDistFileList :: M env m => LocalPackage -> m (String, Path Abs File)+getSDistFileList :: (StackM env m, HasEnvConfig env) => LocalPackage -> m (String, Path Abs File) getSDistFileList lp =     withSystemTempDir (stackProgName <> "-sdist") $ \tmpdir -> do         menv <- getMinimalEnvOverride         let bopts = defaultBuildOpts         let boptsCli = defaultBuildOptsCLI         baseConfigOpts <- mkBaseConfigOpts boptsCli-        (_, _mbp, locals, _extraToBuild, _sourceMap) <- loadSourceMap NeedTargets boptsCli+        (locals, _) <- loadSourceMap NeedTargets boptsCli         runInBase <- liftBaseWith $ \run -> return (void . run)         withExecuteEnv menv bopts boptsCli baseConfigOpts locals             [] [] [] -- provide empty list of globals. This is a hack around custom Setup.hs files@@ -222,7 +226,7 @@                 return (contents, cabalfp)   where     package = lpPackage lp-    ac = ActionContext Set.empty+    ac = ActionContext Set.empty []     task = Task         { taskProvides = PackageIdentifier (packageName package) (packageVersion package)         , taskType = TTLocal lp@@ -234,7 +238,7 @@         , taskAllInOne = True         } -normalizeTarballPaths :: M env m => [FilePath] -> m [FilePath]+normalizeTarballPaths :: (StackM env m) => [FilePath] -> m [FilePath] normalizeTarballPaths fps = do     -- TODO: consider whether erroring out is better - otherwise the     -- user might upload an incomplete tar?@@ -267,7 +271,7 @@ -- and will throw an exception in case of critical errors. -- -- Note that we temporarily decompress the archive to analyze it.-checkSDistTarball :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasEnvConfig env)+checkSDistTarball :: (StackM env m, HasEnvConfig env)   => Path Abs File -- ^ Absolute path to tarball   -> m () checkSDistTarball tarball = withTempTarGzContents tarball $ \pkgDir' -> do@@ -297,7 +301,7 @@  -- | Version of 'checkSDistTarball' that first saves lazy bytestring to -- temporary directory and then calls 'checkSDistTarball' on it.-checkSDistTarball' :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasEnvConfig env)+checkSDistTarball' :: (StackM env m, HasEnvConfig env)   => String       -- ^ Tarball name   -> L.ByteString -- ^ Tarball contents as a byte string   -> m ()
src/Stack/Setup.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -- ghc < 7.10 {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-}@@ -17,14 +18,23 @@   , ensureDockerStackExe   , getSystemCompiler   , SetupOpts (..)-  , defaultStackSetupYaml+  , defaultSetupInfoYaml   , removeHaskellEnvVars++  -- * Stack binary download+  , StackReleaseInfo+  , getDownloadVersion+  , stackVersion+  , preferredPlatforms+  , downloadStackReleaseInfo+  , downloadStackExe   ) where +import qualified    Codec.Archive.Tar as Tar import              Control.Applicative import              Control.Concurrent.Async.Lifted (Concurrently(..))-import              Control.Exception.Enclosed (catchIO, tryAny)-import              Control.Monad (liftM, when, join, void, unless)+import              Control.Exception.Safe (catchIO, tryAny)+import              Control.Monad (liftM, when, join, void, unless, guard) import              Control.Monad.Catch import              Control.Monad.IO.Class (MonadIO, liftIO) import              Control.Monad.Logger@@ -37,11 +47,14 @@ import qualified    Data.ByteString.Char8 as S8 import qualified    Data.ByteString.Lazy as LBS import              Data.Char (isSpace)-import              Data.Conduit (Conduit, ($$), (=$), await, yield, awaitForever)+import              Data.Conduit (Conduit, (=$), await, yield, awaitForever, (.|))+import              Data.Conduit.Lazy (lazyConsume) import              Data.Conduit.Lift (evalStateC) import qualified    Data.Conduit.List as CL+import              Data.Conduit.Zlib           (ungzip) import              Data.Either import              Data.Foldable hiding (concatMap, or, maximum)+import qualified    Data.HashMap.Strict as HashMap import              Data.IORef import              Data.IORef.RunOnce (runOnce) import              Data.List hiding (concat, elem, maximumBy, any)@@ -64,9 +77,8 @@ import qualified    Distribution.System as Cabal import              Distribution.Text (simpleParse) import              Lens.Micro (set)-import              Network.HTTP.Client.Conduit (HasHttpManager, Manager, getHttpManager, parseUrlThrow,-                                                 responseBody, withResponse)-import              Network.HTTP.Download.Verified+import              Network.HTTP.Simple (getResponseBody, httpLBS, withResponse, getResponseStatusCode)+import              Network.HTTP.Download import              Path import              Path.Extra (toFilePathNoTrailingSep) import              Path.IO hiding (findExecutable)@@ -74,7 +86,7 @@ import              Prelude hiding (concat, elem, any) -- Fix AMP warning import              Safe (headMay, readMay) import              Stack.Build (build)-import              Stack.Config (resolvePackageEntry, loadConfig)+import              Stack.Config (loadConfig) import              Stack.Constants (distRelativeDir, stackProgName) import              Stack.Exec (defaultEnvSettings) import              Stack.Fetch@@ -83,9 +95,10 @@ import              Stack.Setup.Installed import              Stack.Types.Build import              Stack.Types.Compiler+import              Stack.Types.CompilerBuild import              Stack.Types.Config import              Stack.Types.Docker-import              Stack.Types.Internal (HasTerminal, HasReExec, HasLogLevel, envConfigBuildOpts, buildOptsInstallExes)+import              Stack.Types.Internal (envConfigBuildOpts, buildOptsInstallExes, buildOptsHaddock) import              Stack.Types.PackageIdentifier import              Stack.Types.PackageName import              Stack.Types.StackT@@ -101,14 +114,19 @@ import              System.Process.Run (runCmd, Cmd(..)) import              Text.Printf (printf) +#if !WINDOWS+import           System.Posix.Files (setFileMode)+#endif+ -- | Default location of the stack-setup.yaml file-defaultStackSetupYaml :: String-defaultStackSetupYaml =+defaultSetupInfoYaml :: String+defaultSetupInfoYaml =     "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/stack-setup-2.yaml"  data SetupOpts = SetupOpts     { soptsInstallIfMissing :: !Bool     , soptsUseSystem :: !Bool+    -- ^ Should we use a system compiler installation, if available?     , soptsWantedCompiler :: !CompilerVersion     , soptsCompilerCheck :: !VersionCheck     , soptsStackYaml :: !(Maybe (Path Abs File))@@ -125,7 +143,7 @@     -- version. Only works reliably with a stack-managed installation.     , soptsResolveMissingGHC :: !(Maybe Text)     -- ^ Message shown to user for how to resolve the missing GHC-    , soptsStackSetupYaml :: !FilePath+    , soptsSetupInfoYaml :: !FilePath     -- ^ Location of the main stack-setup.yaml file     , soptsGHCBindistURL :: !(Maybe String)     -- ^ Alternate GHC binary distribution (requires custom GHCVariant)@@ -183,10 +201,10 @@         "stack does not yet support using --ghc-variant with GHCJS"     show GHCJSNotBooted =         "GHCJS does not yet have its boot packages installed.  Use \"stack setup\" to attempt to run ghcjs-boot."-    show (DockerStackExeNotFound stackVersion osKey) = concat+    show (DockerStackExeNotFound stackVersion' osKey) = concat         [ stackProgName         , "-"-        , versionString stackVersion+        , versionString stackVersion'         , " executable not found for "         , T.unpack osKey         , "\nUse the '"@@ -194,7 +212,7 @@         , "' option to specify a location"]  -- | Modify the environment variables (like PATH) appropriately, possibly doing installation too-setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, HasGHCVariant env, MonadBaseControl IO m)+setupEnv :: (StackM env m, HasBuildConfig env, HasGHCVariant env)          => Maybe Text -- ^ Message to give user when necessary GHC is not available          -> m EnvConfig setupEnv mResolveMissingGHC = do@@ -213,7 +231,7 @@             , soptsSkipMsys = configSkipMsys $ bcConfig bconfig             , soptsUpgradeCabal = False             , soptsResolveMissingGHC = mResolveMissingGHC-            , soptsStackSetupYaml = defaultStackSetupYaml+            , soptsSetupInfoYaml = defaultSetupInfoYaml             , soptsGHCBindistURL = Nothing             } @@ -232,15 +250,13 @@         <*> Concurrently (getGlobalDB menv wc)      $logDebug "Resolving package entries"-    packages <- mapM-        (resolvePackageEntry menv (bcRoot bconfig))-        (bcPackageEntries bconfig)+    packagesRef <- liftIO $ newIORef Nothing     let envConfig0 = EnvConfig             { envConfigBuildConfig = bconfig             , envConfigCabalVersion = cabalVer             , envConfigCompilerVersion = compilerVer             , envConfigCompilerBuild = compilerBuild-            , envConfigPackages = Map.fromList $ concat packages+            , envConfigPackagesRef = packagesRef             }      -- extra installation bin directories@@ -319,7 +335,7 @@         , envConfigCabalVersion = cabalVer         , envConfigCompilerVersion = compilerVer         , envConfigCompilerBuild = compilerBuild-        , envConfigPackages = envConfigPackages envConfig0+        , envConfigPackagesRef = envConfigPackagesRef envConfig0         }  -- | Add the include and lib paths to the given Config@@ -334,7 +350,7 @@     }  -- | Ensure compiler (ghc or ghcjs) is installed and provide the PATHs to add if necessary-ensureCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, HasGHCVariant env, MonadBaseControl IO m)+ensureCompiler :: (StackM env m, HasConfig env, HasGHCVariant env)                => SetupOpts                -> m (Maybe ExtraDirs, CompilerBuild) ensureCompiler sopts = do@@ -357,19 +373,44 @@      Platform expectedArch _ <- asks getPlatform -    let needLocal = case msystem of-            Nothing -> True-            Just _ | soptsSkipGhcCheck sopts -> False-            Just (system, arch) ->-                not (isWanted system) ||-                arch /= expectedArch+    let canUseCompiler compilerVersion arch+            | soptsSkipGhcCheck sopts = True+            | otherwise = isWanted compilerVersion && arch == expectedArch         isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts)+        needLocal = not (any (uncurry canUseCompiler) msystem) +    getSetupInfo' <- runOnce (getSetupInfo (soptsSetupInfoYaml sopts))++    let getMmsys2Tool = do+            platform <- asks getPlatform+            localPrograms <- asks $ configLocalPrograms . getConfig+            installed <- listInstalled localPrograms++            case platform of+                Platform _ Cabal.Windows | not (soptsSkipMsys sopts) ->+                    case getInstalledTool installed $(mkPackageName "msys2") (const True) of+                        Just tool -> return (Just tool)+                        Nothing+                            | soptsInstallIfMissing sopts -> do+                                si <- getSetupInfo'+                                osKey <- getOSKey platform+                                config <- asks getConfig+                                VersionedDownloadInfo version info <-+                                    case Map.lookup osKey $ siMsys2 si of+                                        Just x -> return x+                                        Nothing -> error $ "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+                                $logWarn "Continuing despite missing tool: msys2"+                                return Nothing+                _ -> return Nothing++         -- If we need to install a GHC or MSYS, try to do so         -- Return the additional directory paths of GHC & MSYS.     (mtools, compilerBuild) <- if needLocal         then do-            getSetupInfo' <- runOnce (getSetupInfo (soptsStackSetupYaml sopts) =<< asks getHttpManager)              localPrograms <- asks $ configLocalPrograms . getConfig             installed <- listInstalled localPrograms@@ -384,9 +425,9 @@                             ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)                             return (getInstalledTool installed ghcPkgName (isWanted . GhcVersion), ghcBuild)                         Ghcjs -> return (getInstalledGhcjs installed isWanted, CompilerBuildStandard)-            compilerTool <- case installedCompiler of-                Just tool -> return tool-                Nothing+            compilerTool <- case (installedCompiler, soptsForceReinstall sopts) of+                (Just tool, False) -> return tool+                _                     | soptsInstallIfMissing sopts -> do                         si <- getSetupInfo'                         downloadAndInstallCompiler@@ -395,7 +436,23 @@                             (soptsWantedCompiler sopts)                             (soptsCompilerCheck sopts)                             (soptsGHCBindistURL sopts)-                    | otherwise ->+                    | otherwise -> do+                        recommendSystemGhc <-+                            if soptsUseSystem sopts+                                then return False+                                else do+                                    msystemGhc <- getSystemCompiler menv0 wc+                                    return (any (uncurry canUseCompiler) msystemGhc)+                        let suggestion = fromMaybe+                                (mconcat+                                     ([ "To install the correct GHC into "+                                      , T.pack (toFilePath (configLocalPrograms config))+                                      , ", try running \"stack setup\" or use the \"--install-ghc\" flag."+                                      ] +++                                      [ " To use your system GHC installation, run \"stack config set system-ghc --global true\", or use the \"--system-ghc\" flag."+                                      | recommendSystemGhc+                                      ]))+                                (soptsResolveMissingGHC sopts)                         throwM $ CompilerVersionMismatch                             msystem                             (soptsWantedCompiler sopts, expectedArch)@@ -403,40 +460,21 @@                             compilerBuild                             (soptsCompilerCheck sopts)                             (soptsStackYaml sopts)-                            (fromMaybe-                                ("Try running \"stack setup\" to install the correct GHC into "-                                <> T.pack (toFilePath (configLocalPrograms config)))-                                $ soptsResolveMissingGHC sopts)+                            suggestion              -- Install msys2 on windows, if necessary-            platform <- asks getPlatform-            mmsys2Tool <- case platform of-                Platform _ Cabal.Windows | not (soptsSkipMsys sopts) ->-                    case getInstalledTool installed $(mkPackageName "msys2") (const True) of-                        Just tool -> return (Just tool)-                        Nothing-                            | soptsInstallIfMissing sopts -> do-                                si <- getSetupInfo'-                                osKey <- getOSKey platform-                                VersionedDownloadInfo version info <--                                    case Map.lookup osKey $ siMsys2 si of-                                        Just x -> return x-                                        Nothing -> error $ "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-                                $logWarn "Continuing despite missing tool: msys2"-                                return Nothing-                _ -> return Nothing--            return (Just (compilerTool, mmsys2Tool), compilerBuild)-        else return (Nothing, CompilerBuildStandard)+            mmsys2Tool <- getMmsys2Tool+            return (Just (Just compilerTool, mmsys2Tool), compilerBuild)+        -- Have the right ghc, may still need msys+        else do+            mmsys2Tool <- getMmsys2Tool+            return (Just (Nothing, mmsys2Tool), CompilerBuildStandard)      mpaths <- case mtools of         Nothing -> return Nothing         Just (compilerTool, mmsys2Tool) -> do             -- Add GHC's and MSYS's paths to the config.-            let idents = catMaybes [Just compilerTool, mmsys2Tool]+            let idents = catMaybes [compilerTool, mmsys2Tool]             paths <- mapM extraDirs idents             return $ Just $ mconcat paths @@ -455,136 +493,134 @@         upgradeCabal menv wc      case mtools of-        Just (ToolGhcjs cv, _) -> ensureGhcjsBooted menv cv (soptsInstallIfMissing sopts)+        Just (Just (ToolGhcjs cv), _) -> ensureGhcjsBooted menv cv (soptsInstallIfMissing sopts)         _ -> return ()      when (soptsSanityCheck sopts) $ sanityCheck menv wc      return (mpaths, compilerBuild) --- | Determine which GHC build to use dependong on which shared libraries are available+-- | Determine which GHC build to use depending on which shared libraries are available -- on the system. getGhcBuild-    :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m, HasPlatform env, MonadReader env m)+    :: (StackM env m, HasConfig env)     => EnvOverride -> m CompilerBuild getGhcBuild menv = do -    -- TODO: a more reliable, flexible, and data driven approach would be to actually download small-    -- "test" executables (from setup-info) that link to the same gmp/tinfo versions-    -- that GHC does (i.e. built in same environment as the GHC bindist). The algorithm would go-    -- something like this:-    ---    -- check for previous 'uname -a'/`ldconfig -p` plus compiler version/variant in cache-    -- if cached, then use that as suffix-    -- otherwise:-    --     download setup-info-    --     go through all with right prefix for os/version/variant-    --     first try "standard" (no extra suffix), then the rest-    --         download "compatibility check" exe if not already downloaded-    --         try running it-    --         if successful, then choose that-    --             cache compiler suffix with the uname -a and ldconfig -p output hash plus compiler version-    ---    -- Of course, could also try to make a static GHC bindist instead of all this rigamarole.+    config <- asks getConfig+    case configGHCBuild config of+        Just ghcBuild -> return ghcBuild+        Nothing -> determineGhcBuild+  where+    determineGhcBuild = do+        -- TODO: a more reliable, flexible, and data driven approach would be to actually download small+        -- "test" executables (from setup-info) that link to the same gmp/tinfo versions+        -- that GHC does (i.e. built in same environment as the GHC bindist). The algorithm would go+        -- something like this:+        --+        -- check for previous 'uname -a'/`ldconfig -p` plus compiler version/variant in cache+        -- if cached, then use that as suffix+        -- otherwise:+        --     download setup-info+        --     go through all with right prefix for os/version/variant+        --     first try "standard" (no extra suffix), then the rest+        --         download "compatibility check" exe if not already downloaded+        --         try running it+        --         if successful, then choose that+        --             cache compiler suffix with the uname -a and ldconfig -p output hash plus compiler version+        --+        -- Of course, could also try to make a static GHC bindist instead of all this rigamarole. -    platform <- asks getPlatform-    case platform of-        Platform _ Linux -> do-            -- Some systems don't have ldconfig in the PATH, so make sure to look in /sbin and /usr/sbin as well-            sbinEnv <- modifyEnvOverride menv $-                Map.insert "PATH" $-                "/sbin:/usr/sbin" <>-                (maybe "" (":" <>) $ Map.lookup "PATH" (eoTextMap menv))-            eldconfigOut <- tryProcessStdout Nothing sbinEnv "ldconfig" ["-p"]-            let firstWords = case eldconfigOut of-                    Right ldconfigOut -> mapMaybe (headMay . T.words) $-                        T.lines $ T.decodeUtf8With T.lenientDecode ldconfigOut-                    Left _ -> []-                checkLib lib-                    | libT `elem` firstWords = do-                        $logDebug ("Found shared library " <> libT <> " in 'ldconfig -p' output")-                        return True-#ifndef WINDOWS-                    -- (mkAbsDir "/usr/lib") fails to compile on Windows, thus the CPP-                    | otherwise = do-                        -- This is a workaround for the fact that libtinfo.so.6 doesn't appear in-                        -- the 'ldconfig -p' output on Arch even when it exists.-                        -- There doesn't seem to be an easy way to get the true list of directories-                        -- to scan for shared libs, but this works for our particular case.-                        e <- doesFileExist ($(mkAbsDir "/usr/lib") </> lib)-                        if e-                            then $logDebug ("Found shared library " <> libT <> " in /usr/lib")-                            else $logDebug ("Did not find shared library " <> libT)-                        return e+        platform <- asks getPlatform+        case platform of+            Platform _ Linux -> do+                -- Some systems don't have ldconfig in the PATH, so make sure to look in /sbin and /usr/sbin as well+                sbinEnv <- modifyEnvOverride menv $+                    Map.insert "PATH" $+                    "/sbin:/usr/sbin" <>+                    maybe "" (":" <>) (Map.lookup "PATH" (eoTextMap menv))+                eldconfigOut <- tryProcessStdout Nothing sbinEnv "ldconfig" ["-p"]+                egccErrOut <- tryProcessStderrStdout Nothing menv "gcc" ["-v"]+                let firstWords = case eldconfigOut of+                        Right ldconfigOut -> mapMaybe (headMay . T.words) $+                            T.lines $ T.decodeUtf8With T.lenientDecode ldconfigOut+                        Left _ -> []+                    checkLib lib+                        | libT `elem` firstWords = do+                            $logDebug ("Found shared library " <> libT <> " in 'ldconfig -p' output")+                            return True+                        | otherwise = do+#ifdef WINDOWS+                            -- (mkAbsDir "/usr/lib") fails to compile on Windows, thus the CPP+                            return False+#else+                            -- This is a workaround for the fact that libtinfo.so.6 doesn't appear in+                            -- the 'ldconfig -p' output on Arch even when it exists.+                            -- There doesn't seem to be an easy way to get the true list of directories+                            -- to scan for shared libs, but this works for our particular case.+                            e <- doesFileExist ($(mkAbsDir "/usr/lib") </> lib)+                            if e+                                then $logDebug ("Found shared library " <> libT <> " in /usr/lib")+                                else $logDebug ("Did not find shared library " <> libT)+                            return e #endif-                  where-                    libT = T.pack (toFilePath lib)-            hastinfo5 <- checkLib $(mkRelFile "libtinfo.so.5")-            hastinfo6 <- checkLib $(mkRelFile "libtinfo.so.6")-            hasncurses6 <- checkLib $(mkRelFile "libncursesw.so.6")-            hasgmp5 <- checkLib $(mkRelFile "libgmp.so.10")-            hasgmp4 <- checkLib $(mkRelFile "libgmp.so.3")-            if  | hastinfo5 && hasgmp5 -> useBuild CompilerBuildStandard-                | hastinfo6 && hasgmp5 -> useBuild (CompilerBuildSpecialized "tinfo6")-                | hasncurses6 && hasgmp5 -> useBuild (CompilerBuildSpecialized "ncurses6")-                | hasgmp4 && hastinfo5 -> useBuild (CompilerBuildSpecialized "gmp4")-                | otherwise -> useBuild CompilerBuildStandard-        _ -> useBuild CompilerBuildStandard-  where+                      where+                        libT = T.pack (toFilePath lib)+                    noPie = case egccErrOut of+                        Right (gccErr,gccOut) ->+                            "--enable-default-pie" `elem` S8.words gccOutput || "Gentoo Hardened" `S8.isInfixOf` gccOutput+                                where gccOutput = gccOut <> gccErr+                        Left _ -> False+                $logDebug $ if noPie+                               then "PIE disabled"+                               else "PIE enabled"+                hastinfo5 <- checkLib $(mkRelFile "libtinfo.so.5")+                hastinfo6 <- checkLib $(mkRelFile "libtinfo.so.6")+                hasncurses6 <- checkLib $(mkRelFile "libncursesw.so.6")+                hasgmp5 <- checkLib $(mkRelFile "libgmp.so.10")+                hasgmp4 <- checkLib $(mkRelFile "libgmp.so.3")+                let libComponents =+                        if  | hastinfo5 && hasgmp5 -> []+                            | hastinfo6 && hasgmp5 -> ["tinfo6"]+                            | hasncurses6 && hasgmp5 -> ["ncurses6"]+                            | hasgmp4 && hastinfo5 -> ["gmp4"]+                            | otherwise -> []+                    pieComponents =+                        if noPie+                            then ["nopie"]+                            else []+                case libComponents ++ pieComponents of+                    [] -> useBuild CompilerBuildStandard+                    components -> useBuild (CompilerBuildSpecialized (intercalate "-" components))+            _ -> useBuild CompilerBuildStandard     useBuild CompilerBuildStandard = do         $logDebug "Using standard GHC build"-        return (CompilerBuildStandard)+        return CompilerBuildStandard     useBuild (CompilerBuildSpecialized s) = do         $logDebug ("Using " <> T.pack s <> " GHC build")         return (CompilerBuildSpecialized s)  -- | Ensure Docker container-compatible 'stack' executable is downloaded ensureDockerStackExe-    :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)+    :: (StackM env m, HasConfig env)     => Platform -> m (Path Abs File) ensureDockerStackExe containerPlatform = do     config <- asks getConfig     containerPlatformDir <- runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone)     let programsPath = configLocalProgramsBase config </> containerPlatformDir-        stackVersion = fromCabalVersion Meta.version         tool = Tool (PackageIdentifier $(mkPackageName "stack") stackVersion)-    stackExePath <- (</> $(mkRelFile "stack")) <$> installDir programsPath tool+    stackExeDir <- installDir programsPath tool+    let stackExePath = stackExeDir </> $(mkRelFile "stack")     stackExeExists <- doesFileExist stackExePath-    unless stackExeExists $-        do-           $logInfo $ mconcat ["Downloading Docker-compatible ", T.pack stackProgName, " executable"]-           si <- getSetupInfo defaultStackSetupYaml =<< asks getHttpManager-           osKey <- getOSKey containerPlatform-           info <--               case Map.lookup osKey (siStack si) of-                   Just versions ->-                       case Map.lookup stackVersion versions of-                           Just x -> return x-                           Nothing ->-                               case mapMaybe (matchMinor stackVersion) (Map.keys versions) of-                                   (v:_) ->-                                       case Map.lookup v versions of-                                           Just x -> return x-                                           Nothing ->  throwM (DockerStackExeNotFound v osKey)-                                   [] -> throwM (DockerStackExeNotFound stackVersion osKey)-                   Nothing -> throwM (DockerStackExeNotFound stackVersion osKey)-           _ <--               downloadAndInstallTool-                   programsPath-                   si-                   info-                   tool-                   installDockerStackExe-           return ()+    unless stackExeExists $ do+        $logInfo $ mconcat ["Downloading Docker-compatible ", T.pack stackProgName, " executable"]+        sri <- downloadStackReleaseInfo Nothing Nothing (Just (versionString stackVersion))+        let platforms = preferredPlatforms (containerPlatform, PlatformVariantNone)+        downloadStackExe platforms sri stackExeDir (const $ return ())     return stackExePath-  where-    matchMinor stackVersion v =-        if checkVersion MatchMinor stackVersion v-            then Just v-            else Nothing  -- | Install the newest version of Cabal globally-upgradeCabal :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m, MonadMask m)+upgradeCabal :: (StackM env m, HasConfig env, HasGHCVariant env)              => EnvOverride              -> WhichCompiler              -> m ()@@ -675,8 +711,8 @@ -- | Download the most recent SetupInfo getSetupInfo     :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasConfig env)-    => String -> Manager -> m SetupInfo-getSetupInfo stackSetupYaml manager = do+    => String -> m SetupInfo+getSetupInfo stackSetupYaml = do     config <- asks getConfig     setupInfos <-         mapM@@ -689,17 +725,10 @@     loadSetupInfo (SetupInfoFileOrURL urlOrFile) = do         bs <-             case parseUrlThrow urlOrFile of-                Just req -> do-                    bss <--                        liftIO $-                        flip runReaderT manager $-                        withResponse req $-                        \res ->-                             responseBody res $$ CL.consume-                    return $ S8.concat bss+                Just req -> liftM (LBS.toStrict . getResponseBody) $ httpLBS req                 Nothing -> liftIO $ S.readFile urlOrFile         WithJSONWarnings si warnings <- either throwM return (Yaml.decodeEither' bs)-        when (urlOrFile /= defaultStackSetupYaml) $+        when (urlOrFile /= defaultSetupInfoYaml) $             logJSONWarnings urlOrFile warnings         return si @@ -732,7 +761,7 @@     goodPackage (ToolGhcjs cv) = if goodVersion cv then Just cv else Nothing     goodPackage _ = Nothing -downloadAndInstallTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m)+downloadAndInstallTool :: StackMiniM env m                        => Path Abs Dir                        -> SetupInfo                        -> DownloadInfo@@ -752,7 +781,7 @@     ignoringAbsence (removeDirRecur tempDir)     return tool -downloadAndInstallCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasGHCVariant env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)+downloadAndInstallCompiler :: (StackM env m, HasConfig env, HasGHCVariant env)                            => CompilerBuild                            -> SetupInfo                            -> CompilerVersion@@ -768,7 +797,7 @@                 _ -> throwM RequireCustomGHCVariant             case wanted of                 GhcVersion version ->-                    return (version, DownloadInfo (T.pack bindistURL) Nothing Nothing)+                    return (version, GHCDownloadInfo mempty mempty (DownloadInfo (T.pack bindistURL) Nothing Nothing))                 _ ->                     throwM WantedMustBeGHC         _ -> do@@ -780,7 +809,7 @@     let installer =             case configPlatform config of                 Platform _ Cabal.Windows -> installGHCWindows selectedVersion-                _ -> installGHCPosix selectedVersion+                _ -> installGHCPosix selectedVersion downloadInfo     $logInfo $         "Preparing to install GHC" <>         (case ghcVariant of@@ -793,7 +822,7 @@     $logInfo "This will not interfere with any system-level installation."     ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild)     let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion-    downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installer+    downloadAndInstallTool (configLocalPrograms config) si (gdiDownloadInfo downloadInfo) tool installer downloadAndInstallCompiler compilerBuild si wanted versionCheck _mbindistUrl = do     config <- asks getConfig     ghcVariant <- asks getGHCVariant@@ -851,7 +880,7 @@         Platform arch os -> throwM $ UnsupportedSetupCombo os arch  downloadFromInfo-    :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m)+    :: StackMiniM env m     => Path Abs Dir -> DownloadInfo -> Tool -> m (Path Abs File, ArchiveType) downloadFromInfo programsDir downloadInfo tool = do     at <-@@ -897,15 +926,16 @@     | TarGz     | SevenZ -installGHCPosix :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m, HasTerminal env)+installGHCPosix :: (StackM env m, HasConfig env)                 => Version+                -> GHCDownloadInfo                 -> SetupInfo                 -> Path Abs File                 -> ArchiveType                 -> Path Abs Dir                 -> Path Abs Dir                 -> m ()-installGHCPosix version _ archiveFile archiveType tempDir destDir = do+installGHCPosix version downloadInfo _ archiveFile archiveType tempDir destDir = do     platform <- asks getPlatform     menv0 <- getMinimalEnvOverride     menv <- mkEnvOverride platform (removeHaskellEnvVars (unEnvOverride menv0))@@ -936,8 +966,9 @@         parseRelDir $         "ghc-" ++ versionString version -    let runStep step wd cmd args = do-            result <- try (readProcessNull (Just wd) menv cmd args)+    let runStep step wd env cmd args = do+            menv' <- modifyEnvOverride menv (Map.union env)+            result <- try (readProcessNull (Just wd) menv' cmd args)             case result of                 Right _ -> return ()                 Left ex -> do@@ -956,18 +987,21 @@      $logSticky $ T.concat ["Unpacking GHC into ", T.pack . toFilePath $ tempDir, " ..."]     $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile)-    runStep "unpacking" tempDir tarTool [compOpt : "xf", toFilePath archiveFile]+    runStep "unpacking" tempDir mempty tarTool [compOpt : "xf", toFilePath archiveFile]      $logSticky "Configuring GHC ..."-    runStep "configuring" dir (toFilePath $ dir </> $(mkRelFile "configure")) ["--prefix=" ++ toFilePath destDir]+    runStep "configuring" dir+        (gdiConfigureEnv downloadInfo)+        (toFilePath $ dir </> $(mkRelFile "configure"))+        (("--prefix=" ++ toFilePath destDir) : map T.unpack (gdiConfigureOpts downloadInfo))      $logSticky "Installing GHC ..."-    runStep "installing" dir makeTool ["install"]+    runStep "installing" dir mempty makeTool ["install"]      $logStickyDone $ "Installed GHC."     $logDebug $ "GHC installed to " <> T.pack (toFilePath destDir) -installGHCJS :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)+installGHCJS :: (StackM env m, HasConfig env)              => SetupInfo              -> Path Abs File              -> ArchiveType@@ -1036,7 +1070,8 @@         _ -> return Nothing      $logSticky "Installing GHCJS (this will take a long time) ..."-    runInnerStackT (set (envConfigBuildOpts.buildOptsInstallExes) True envConfig') $+    runInnerStackT (set (envConfigBuildOpts.buildOptsInstallExes) True $+                    set (envConfigBuildOpts.buildOptsHaddock) False envConfig') $         build (\_ -> return ()) Nothing defaultBuildOptsCLI     -- Copy over *.options files needed on windows.     forM_ mwindowsInstallDir $ \dir -> do@@ -1047,36 +1082,15 @@             copyFile optionsFile dest     $logStickyDone "Installed GHCJS." --- Install the downloaded stack binary distribution-installDockerStackExe-    :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, MonadBaseControl IO m)-    => SetupInfo-    -> Path Abs File-    -> ArchiveType-    -> Path Abs Dir-    -> Path Abs Dir-    -> m ()-installDockerStackExe _ archiveFile _ _tempDir destDir = do-    (_,tarTool) <--        checkDependencies $-        (,) <$> checkDependency "gzip" <*> checkDependency "tar"-    menv <- getMinimalEnvOverride-    ensureDir destDir-    readProcessNull-        (Just destDir)-        menv-        tarTool-        ["xf", toFilePath archiveFile, "--strip-components", "1"]--ensureGhcjsBooted :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadReader env m)+ensureGhcjsBooted :: (StackM env m, HasConfig env)                   => EnvOverride -> CompilerVersion -> Bool -> m () ensureGhcjsBooted menv cv shouldBoot  = do     eres <- try $ sinkProcessStdout Nothing menv "ghcjs" [] (return ())     case eres of         Right () -> return ()-        Left (ReadProcessException _ _ _ err) | "no input files" `S.isInfixOf` LBS.toStrict err ->+        Left (ProcessFailed _ _ _ err) | "no input files" `S.isInfixOf` LBS.toStrict err ->             return ()-        Left (ReadProcessException _ _ _ err) | "ghcjs_boot.completed" `S.isInfixOf` LBS.toStrict err ->+        Left (ProcessFailed _ _ _ err) | "ghcjs_boot.completed" `S.isInfixOf` LBS.toStrict err ->             if not shouldBoot then throwM GHCJSNotBooted else do                 config <- asks getConfig                 destDir <- installDir (configLocalPrograms config) (ToolGhcjs cv)@@ -1103,7 +1117,7 @@                 bootGhcjs ghcjsVersion actualStackYaml destDir         Left err -> throwM err -bootGhcjs :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadReader env m)+bootGhcjs :: StackM env m           => Version -> Path Abs File -> Path Abs Dir -> m () bootGhcjs ghcjsVersion stackYaml destDir = do     envConfig <- loadGhcjsEnvConfig stackYaml (destDir </> $(mkRelDir "bin"))@@ -1161,9 +1175,9 @@     logProcessStderrStdout Nothing "ghcjs-boot" menv' ["--clean"]     $logStickyDone "GHCJS booted." -loadGhcjsEnvConfig :: (MonadIO m, HasHttpManager r, MonadReader r m, HasTerminal r, HasReExec r, HasLogLevel r)-                     => Path Abs File -> Path b t -> m EnvConfig-loadGhcjsEnvConfig stackYaml binPath = runInnerStackLoggingT $ do+loadGhcjsEnvConfig :: StackM env m+                   => Path Abs File -> Path b t -> m EnvConfig+loadGhcjsEnvConfig stackYaml binPath = runInnerStackT () $ do     lc <- loadConfig         (mempty             { configMonoidInstallGHC = First (Just True)@@ -1216,7 +1230,7 @@             Left _ -> y menv             Right x' -> return $ Right x' -installGHCWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)+installGHCWindows :: (StackMiniM env m, HasConfig env)                   => Version                   -> SetupInfo                   -> Path Abs File@@ -1229,7 +1243,7 @@     withUnpackedTarball7z "GHC" si archiveFile archiveType (Just tarComponent) destDir     $logInfo $ "GHC installed to " <> T.pack (toFilePath destDir) -installMsys2Windows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)+installMsys2Windows :: (StackMiniM env m, HasConfig env)                   => Text -- ^ OS Key                   -> SetupInfo                   -> Path Abs File@@ -1269,7 +1283,7 @@  -- | Unpack a compressed tarball using 7zip.  Expects a single directory in -- the unpacked results, which is renamed to the destination directory.-withUnpackedTarball7z :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)+withUnpackedTarball7z :: (StackMiniM env m, HasConfig env)                       => String -- ^ Name of tool, used in error messages                       -> SetupInfo                       -> Path Abs File -- ^ Path to archive file@@ -1317,7 +1331,7 @@ -- | Download 7z as necessary, and get a function for unpacking things. -- -- Returned function takes an unpack directory and archive.-setup7z :: (MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadLogger n, MonadBaseControl IO m)+setup7z :: (MonadIO n, MonadLogger n, StackMiniM env m, HasConfig env)         => SetupInfo         -> m (Path Abs Dir -> Path Abs File -> n ()) setup7z si = do@@ -1343,7 +1357,7 @@                     $ liftIO $ throwM (ProblemWhileDecompressing archive)         _ -> throwM SetupInfoMissingSevenz -chattyDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m)+chattyDownload :: StackMiniM env m                => Text          -- ^ label                -> DownloadInfo  -- ^ URL, content-length, and sha1                -> Path Abs File -- ^ destination@@ -1626,3 +1640,174 @@     fallbackPrefixes = ["C.", "en_US.", "en_"]     -- Suffixes of UTF-8 locales (case-insensitive)     utf8Suffixes = [".UTF-8", ".utf8"]++-- Binary Stack upgrades++newtype StackReleaseInfo = StackReleaseInfo Value++downloadStackReleaseInfo :: MonadIO m+                         => Maybe String -- Github org+                         -> Maybe String -- Github repo+                         -> Maybe String -- ^ optional version+                         -> m StackReleaseInfo+downloadStackReleaseInfo morg mrepo mver = liftIO $ do+    let org = fromMaybe "commercialhaskell" morg+        repo = fromMaybe "stack" mrepo+    let url = concat+            [ "https://api.github.com/repos/"+            , org+            , "/"+            , repo+            , "/releases/"+            , case mver of+                Nothing -> "latest"+                Just ver -> "tags/v" ++ ver+            ]+    req <- parseRequest url+    res <- httpJSON $ setGithubHeaders req+    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++preferredPlatforms :: (MonadReader env m, HasPlatform env)+                   => m [(Bool, String)]+preferredPlatforms = do+    Platform arch' os' <- asks getPlatform+    (isWindows, os) <-+      case os' of+        Cabal.Linux -> return (False, "linux")+        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'+    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'+    hasgmp4 <- return False -- FIXME import relevant code from Stack.Setup? checkLib $(mkRelFile "libgmp.so.3")+    let suffixes+          | hasgmp4 = ["-static", "-gmp4", ""]+          | otherwise = ["-static", ""]+    return $ map (\suffix -> (isWindows, concat [os, "-", arch, suffix])) suffixes++downloadStackExe+    :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env)+    => [(Bool, String)] -- ^ acceptable platforms+    -> StackReleaseInfo+    -> Path Abs Dir -- ^ destination directory+    -> (Path Abs File -> IO ()) -- ^ test the temp exe before renaming+    -> m ()+downloadStackExe platforms0 archiveInfo destDir testExe = do+    (isWindows, archiveURL) <-+      let loop [] = error $ "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+            case findArchive archiveInfo p of+              Just x -> return (isWindows, x)+              Nothing -> loop ps+       in loop platforms0++    let (destFile, tmpFile)+            | isWindows =+                ( destDir </> $(mkRelFile "stack.exe")+                , destDir </> $(mkRelFile "stack.tmp.exe")+                )+            | otherwise =+                ( destDir </> $(mkRelFile "stack")+                , destDir </> $(mkRelFile "stack.tmp")+                )++    $logInfo $ "Downloading from: " <> archiveURL++    liftIO $ do+      case () of+        ()+          | ".tar.gz" `T.isSuffixOf` archiveURL -> handleTarball tmpFile isWindows archiveURL+          | ".zip" `T.isSuffixOf` archiveURL -> error "FIXME: Handle zip files"+          | otherwise -> error $ "Unknown archive format for Stack archive: " ++ T.unpack archiveURL++    $logInfo "Download complete, testing executable"++    platform <- asks getPlatform++    liftIO $ do+#if !WINDOWS+      setFileMode (toFilePath tmpFile) 0o755+#endif++      testExe tmpFile++      currExe <- getExecutablePath+      case platform of+          Platform _ Cabal.Windows | FP.equalFilePath (toFilePath destFile) currExe -> do+              old <- parseAbsFile (toFilePath destFile ++ ".old")+              renameFile destFile old+              renameFile tmpFile destFile+          _ -> renameFile tmpFile destFile++    $logInfo $ T.pack $ "New stack executable available at " ++ toFilePath destFile+  where++    findArchive (StackReleaseInfo val) pattern = do+        Object top <- return val+        Array assets <- HashMap.lookup "assets" top+        getFirst $ fold $ fmap (First . findMatch pattern') assets+      where+        pattern' = mconcat ["-", pattern, "."]++        findMatch pattern'' (Object o) = do+            String name <- HashMap.lookup "name" o+            guard $ not $ ".asc" `T.isSuffixOf` name+            guard $ pattern'' `T.isInfixOf` name+            String url <- HashMap.lookup "browser_download_url" o+            Just url+        findMatch _ _ = Nothing++    handleTarball :: Path Abs File -> Bool -> T.Text -> IO ()+    handleTarball tmpFile isWindows url = do+        req <- fmap setGithubHeaders $ parseUrlThrow $ T.unpack url+        withResponse req $ \res -> do+            entries <- fmap (Tar.read . LBS.fromChunks)+                     $ lazyConsume+                     $ getResponseBody res .| ungzip+            let loop Tar.Done = error $ concat+                    [ "Stack executable "+                    , show exeName+                    , " not found in archive from "+                    , T.unpack url+                    ]+                loop (Tar.Fail e) = throwM e+                loop (Tar.Next e es)+                    | Tar.entryPath e == exeName =+                        case Tar.entryContent e of+                            Tar.NormalFile lbs _ -> do+                              ensureDir destDir+                              LBS.writeFile (toFilePath tmpFile) lbs+                            _ -> error $ concat+                                [ "Invalid file type for tar entry named "+                                , exeName+                                , " downloaded from "+                                , T.unpack url+                                ]+                    | otherwise = loop es+            loop entries+      where+        -- The takeBaseName drops the .gz, dropExtension drops the .tar+        exeName =+            let base = FP.dropExtension (FP.takeBaseName (T.unpack url)) FP.</> "stack"+             in if isWindows then base FP.<.> "exe" else base++getDownloadVersion :: StackReleaseInfo -> Maybe Version+getDownloadVersion (StackReleaseInfo val) = do+    Object o <- Just val+    String rawName <- HashMap.lookup "name" o+    -- drop the "v" at the beginning of the name+    parseVersion $ T.drop 1 rawName++stackVersion :: Version+stackVersion = fromCabalVersion Meta.version
src/Stack/Setup/Installed.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}@@ -40,10 +41,11 @@ import           Path import           Path.IO import           Prelude hiding (concat, elem) -- Fix AMP warning-import           Stack.Types.PackageIdentifier import           Stack.Types.Compiler import           Stack.Types.Config+import           Stack.Types.PackageIdentifier import           Stack.Types.PackageName+import           Stack.Types.StackT import           Stack.Types.Version import           System.Process.Read @@ -116,7 +118,7 @@     isValid c = c == '.' || ('0' <= c && c <= '9')  -- | Binary directories for the given installed package-extraDirs :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)+extraDirs :: (StackM env m, HasConfig env)           => Tool           -> m ExtraDirs extraDirs tool = do
src/Stack/SetupCmd.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -11,33 +12,42 @@     ) where  import           Control.Applicative-import           Control.Monad.Catch-import           Control.Monad.IO.Class import           Control.Monad.Logger import           Control.Monad.Reader-import           Control.Monad.Trans.Control import           Data.Monoid import qualified Data.Text as T import qualified Options.Applicative as OA import qualified Options.Applicative.Builder.Extra as OA import qualified Options.Applicative.Types as OA-import           Network.HTTP.Client import           Path import           Prelude -- silence redundant import warnings import           Stack.Setup import           Stack.Types.Compiler import           Stack.Types.Config-import           Stack.Types.Internal+import           Stack.Types.StackT import           Stack.Types.Version  data SetupCmdOpts = SetupCmdOpts     { scoCompilerVersion :: !(Maybe CompilerVersion)     , scoForceReinstall  :: !Bool     , scoUpgradeCabal    :: !Bool-    , scoStackSetupYaml  :: !String+    , scoSetupInfoYaml   :: !String     , scoGHCBindistURL   :: !(Maybe String)     } +setupYamlCompatParser :: OA.Parser String+setupYamlCompatParser = stackSetupYaml <|> setupInfoYaml+    where stackSetupYaml = OA.strOption (+               OA.long "stack-setup-yaml"+            <> OA.help "DEPRECATED: Use 'setup-info-yaml' instead"+            <> OA.metavar "URL"+            <> OA.hidden )+          setupInfoYaml  = OA.strOption (+               OA.long "setup-info-yaml"+            <> OA.help "Alternate URL or absolute path for stack dependencies"+            <> OA.metavar "URL"+            <> OA.value defaultSetupInfoYaml )+ setupParser :: OA.Parser SetupCmdOpts setupParser = SetupCmdOpts     <$> OA.optional (OA.argument readVersion@@ -46,17 +56,13 @@                       "The default is to install the version implied by the resolver.")))     <*> OA.boolFlags False             "reinstall"-            "reinstalling GHC, even if available (implies no-system-ghc)"+            "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.strOption-            ( OA.long "stack-setup-yaml"-           <> OA.help "Location of the main stack-setup.yaml file"-           <> OA.value defaultStackSetupYaml-           <> OA.showDefault )+    <*> setupYamlCompatParser     <*> OA.optional (OA.strOption             (OA.long "ghc-bindist"            <> OA.metavar "URL"@@ -72,9 +78,7 @@             Just x -> return x  setup-    :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env,-        MonadBaseControl IO m, MonadMask m, HasHttpManager env,-        HasGHCVariant env, HasTerminal env, HasReExec env, HasLogLevel env)+    :: (StackM env m, HasConfig env, HasGHCVariant env)     => SetupCmdOpts     -> CompilerVersion     -> VersionCheck@@ -94,7 +98,7 @@         , soptsSkipMsys = configSkipMsys         , soptsUpgradeCabal = scoUpgradeCabal         , soptsResolveMissingGHC = Nothing-        , soptsStackSetupYaml = scoStackSetupYaml+        , soptsSetupInfoYaml = scoSetupInfoYaml         , soptsGHCBindistURL = scoGHCBindistURL         }     let compiler = case wantedCompiler of
src/Stack/Sig/Sign.hs view
@@ -29,11 +29,10 @@ import qualified Data.ByteString.Lazy as L import           Data.Monoid ((<>)) import qualified Data.Text as T-import           Network.HTTP.Conduit (Response(..), RequestBody(..),-                                       Request(..), httpLbs)-import           Network.HTTP.Client (Manager)+import           Network.HTTP.Client (RequestBody (RequestBodyBS)) import           Network.HTTP.Download-import           Network.HTTP.Types (status200, methodPut)+import           Network.HTTP.Simple+import           Network.HTTP.Types (methodPut) import           Path import           Path.IO import           Stack.Package@@ -50,8 +49,8 @@ #else     :: (MonadIO m, MonadLogger m, MonadMask m) #endif-    => Manager -> String -> Path Abs File -> m Signature-sign manager url filePath =+    => String -> Path Abs File -> m Signature+sign url filePath =     withSystemTempDir         "stack"         (\tempDir ->@@ -65,7 +64,7 @@                      Nothing -> throwM SigInvalidSDistTarBall                      Just cabalPath -> do                          pkg <- cabalFilePackageId (tempDir </> cabalPath)-                         signPackage manager url pkg filePath)+                         signPackage url pkg filePath)   where     extractCabalFile tempDir (Tar.Next entry entries) =         case Tar.entryContent entry of@@ -95,21 +94,21 @@ #else     :: (MonadIO m, MonadLogger m, MonadMask m) #endif-    => Manager -> String -> Path Rel File -> L.ByteString -> m Signature-signTarBytes manager url tarPath bs =+    => String -> Path Rel File -> L.ByteString -> m Signature+signTarBytes url tarPath bs =     withSystemTempDir         "stack"         (\tempDir ->               do let tempTarBall = tempDir </> tarPath                  liftIO (L.writeFile (toFilePath tempTarBall) bs)-                 sign manager url tempTarBall)+                 sign url tempTarBall)  -- | Sign a haskell package given the url to the signature service, a -- @PackageIdentifier@ and a file path to the package on disk. signPackage     :: (MonadIO m, MonadLogger m, MonadThrow m)-    => Manager -> String -> PackageIdentifier -> Path Abs File -> m Signature-signPackage manager url pkg filePath = do+    => String -> PackageIdentifier -> Path Abs File -> m Signature+signPackage url pkg filePath = do     sig@(Signature signature) <- gpgSign filePath     let (PackageIdentifier name version) = pkg     fingerprint <- gpgVerify sig filePath@@ -118,14 +117,11 @@             "/" <>             show fingerprint     req <- parseUrlThrow fullUrl-    let put =-            req-            { method = methodPut-            , requestBody = RequestBodyBS signature-            }-    res <- liftIO (httpLbs put manager)+    let put = setRequestMethod methodPut+            $ setRequestBody (RequestBodyBS signature) req+    res <- liftIO (httpLbs put)     when-        (responseStatus res /= status200)+        (getResponseStatusCode res /= 200)         (throwM (GPGSignException "unable to sign & upload package"))     $logInfo ("Signature uploaded to " <> T.pack fullUrl)     return sig
src/Stack/Solver.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-}@@ -16,80 +17,78 @@     , parseCabalOutputLine     ) where -import Prelude ()-import Prelude.Compat+import           Prelude ()+import           Prelude.Compat  import           Control.Applicative import           Control.Exception (assert)-import           Control.Exception.Enclosed  (tryIO)-import           Control.Monad               (when,void,join,liftM,unless,zipWithM_)+import           Control.Exception.Safe (tryIO)+import           Control.Monad (when,void,join,liftM,unless,mapAndUnzipM, zipWithM_) import           Control.Monad.Catch import           Control.Monad.IO.Class import           Control.Monad.Logger-import           Control.Monad.Reader        (MonadReader, asks)-import           Control.Monad.Trans.Control+import           Control.Monad.Reader (asks) import           Data.Aeson.Extended         ( WithJSONWarnings(..), object, (.=), toJSON                                              , logJSONWarnings)-import qualified Data.ByteString             as S-import           Data.Char                   (isSpace)+import qualified Data.ByteString as S+import           Data.Char (isSpace) import           Data.Either-import           Data.Foldable               (forM_)-import           Data.Function               (on)-import qualified Data.HashMap.Strict         as HashMap-import qualified Data.HashSet                as HashSet+import           Data.Foldable (forM_)+import           Data.Function (on)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet import           Data.List                   ( (\\), isSuffixOf, intercalate                                              , minimumBy, isPrefixOf)-import           Data.List.Extra             (groupSortOn)-import           Data.Map                    (Map)-import qualified Data.Map                    as Map-import           Data.Maybe                  (catMaybes, isNothing, mapMaybe, fromMaybe)+import           Data.List.Extra (groupSortOn)+import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.Maybe (catMaybes, isNothing, mapMaybe) import           Data.Monoid-import           Data.Set                    (Set)-import qualified Data.Set                    as Set-import           Data.Text                   (Text)-import qualified Data.Text                   as T-import           Data.Text.Encoding          (decodeUtf8, encodeUtf8)-import           Data.Text.Encoding.Error    (lenientDecode)-import qualified Data.Text.Lazy              as LT-import           Data.Text.Lazy.Encoding     (decodeUtf8With)-import           Data.Tuple                  (swap)-import qualified Data.Yaml.Extra             as Yaml-import qualified Distribution.Package        as C+import           Data.Set (Set)+import qualified Data.Set as Set+import           Data.Text (Text)+import qualified Data.Text as T+import           Data.Text.Encoding (decodeUtf8, encodeUtf8)+import           Data.Text.Encoding.Error (lenientDecode)+import           Data.Text.Extra (stripCR)+import qualified Data.Text.Lazy as LT+import           Data.Text.Lazy.Encoding (decodeUtf8With)+import           Data.Tuple (swap)+import qualified Data.Yaml as Yaml+import qualified Distribution.Package as C import qualified Distribution.PackageDescription as C-import qualified Distribution.Text           as C-import           Network.HTTP.Client.Conduit (HasHttpManager)-import           Text.Regex.Applicative.Text (match, sym, psym, anySym, few)+import qualified Distribution.Text as C import           Path-import           Path.Find                   (findFiles)-import           Path.IO                     hiding (findExecutable, findFiles)+import           Path.Find (findFiles)+import           Path.IO hiding (findExecutable, findFiles) import           Stack.BuildPlan-import           Stack.Constants             (stackDotYaml, wiredInPackages)+import           Stack.Config (getLocalPackages)+import           Stack.Constants (stackDotYaml, wiredInPackages) import           Stack.Package               (printCabalFileWarning                                              , hpack                                              , readPackageUnresolved) import           Stack.Setup import           Stack.Setup.Installed+import           Stack.Types.Build+import           Stack.Types.Compiler+import           Stack.Types.Config import           Stack.Types.FlagName import           Stack.Types.PackageIdentifier-import           Stack.Types.PackageIndex import           Stack.Types.PackageName+import           Stack.Types.Resolver+import           Stack.Types.StackT (StackM) import           Stack.Types.Version-import           Stack.Types.Config-import           Stack.Types.Build-import           Stack.Types.Compiler-import           Stack.Types.Internal        ( HasTerminal-                                             , HasReExec-                                             , HasLogLevel)-import qualified System.Directory            as D-import qualified System.FilePath             as FP+import qualified System.Directory as D+import qualified System.FilePath as FP import           System.Process.Read+import           Text.Regex.Applicative.Text (match, sym, psym, anySym, few) -import qualified Data.Text.Normalize         as T ( normalize , NormalizationMode(NFC) )+import qualified Data.Text.Normalize as T ( normalize , NormalizationMode(NFC) )  data ConstraintType = Constraint | Preference deriving (Eq) type ConstraintSpec = Map PackageName (Version, Map FlagName Bool) -cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, MonadReader env m, HasConfig env)+cabalSolver :: (StackM env m, HasConfig env)             => EnvOverride             -> [Path Abs Dir] -- ^ cabal files             -> ConstraintType@@ -130,7 +129,7 @@      catch (liftM Right (readProcessStdout (Just tmpdir) menv "cabal" args))           (\ex -> case ex of-              ReadProcessException _ _ _ err -> return $ Left err+              ProcessFailed _ _ _ err -> return $ Left err               _ -> throwM ex)     >>= either parseCabalErrors parseCabalOutput @@ -157,10 +156,10 @@              when (any isNothing mPkgNames) $ do                   $logInfo $ "*** Only some package names could be parsed: " <>-                      (T.pack (intercalate ", " (map show pkgNames)))+                      T.pack (intercalate ", " (map show pkgNames))                   error $ T.unpack $                        "*** User packages involved in cabal failure: "-                       <> (T.intercalate ", " $ parseConflictingPkgs msg)+                       <> T.intercalate ", " (parseConflictingPkgs msg)              if pkgNames /= [] then do                   return $ Left pkgNames@@ -169,14 +168,14 @@      parseConflictingPkgs msg =         let ls = dropWhile (not . errCheck) $ linesNoCR msg-            select s = ((T.isPrefixOf "trying:" s)-                      || (T.isPrefixOf "next goal:" s))-                      && (T.isSuffixOf "(user goal)" s)-            pkgName =   (take 1)+            select s = (T.isPrefixOf "trying:" s+                      || T.isPrefixOf "next goal:" s)+                      && T.isSuffixOf "(user goal)" s+            pkgName =   take 1                       . T.words-                      . (T.drop 1)-                      . (T.dropWhile (/= ':'))-        in concat $ map pkgName (filter select ls)+                      . T.drop 1+                      . T.dropWhile (/= ':')+        in concatMap pkgName (filter select ls)      parseCabalOutput bs = do         let ls = drop 1@@ -188,9 +187,7 @@           then return $ Right (Map.fromList pairs)           else error $ "The following lines from cabal-install output could \                        \not be parsed: \n"-                       ++ (T.unpack (T.intercalate "\n" errs))--    stripCR t = fromMaybe t (T.stripSuffix "\r" t)+                       ++ T.unpack (T.intercalate "\n" errs)      toConstraintArgs userFlagMap =         [formatFlagConstraint package flag enabled@@ -238,7 +235,7 @@      lexeme r = some (psym isSpace) *> r -getCabalConfig :: (MonadLogger m, MonadReader env m, HasConfig env, MonadIO m, MonadThrow m)+getCabalConfig :: (StackM env m, HasConfig env)                => FilePath -- ^ temp dir                -> ConstraintType                -> Map PackageName Version -- ^ constraints@@ -265,20 +262,17 @@     goConstraint (name, version) =         assert (not . null . versionString $ version) $             T.concat-              [ (if constraintType == Constraint-                    || name `HashSet.member` wiredInPackages-                 then "constraint: "-                 else "preference: ")+              [ if constraintType == Constraint+                   || name `HashSet.member` wiredInPackages+                then "constraint: "+                else "preference: "               , T.pack $ packageNameString name               , "=="               , T.pack $ versionString version               ]  setupCompiler-    :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m-       , MonadReader env m, HasConfig env , HasGHCVariant env-       , HasHttpManager env , HasLogLevel env , HasReExec env-       , HasTerminal env)+    :: (StackM env m, HasConfig env, HasGHCVariant env)     => CompilerVersion     -> m (Maybe ExtraDirs) setupCompiler compiler = do@@ -290,7 +284,7 @@           , "compiler available on your PATH." ]      config <- asks getConfig-    mpaths <- fst <$> ensureCompiler SetupOpts+    fst <$> ensureCompiler SetupOpts         { soptsInstallIfMissing  = configInstallGHC config         , soptsUseSystem         = configSystemGHC config         , soptsWantedCompiler    = compiler@@ -303,17 +297,12 @@         , soptsSkipMsys          = configSkipMsys config         , soptsUpgradeCabal      = False         , soptsResolveMissingGHC = msg-        , soptsStackSetupYaml    = defaultStackSetupYaml+        , soptsSetupInfoYaml    = defaultSetupInfoYaml         , soptsGHCBindistURL     = Nothing         } -    return mpaths- setupCabalEnv-    :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m-       , MonadReader env m, HasConfig env , HasGHCVariant env-       , HasHttpManager env , HasLogLevel env , HasReExec env-       , HasTerminal env)+    :: (StackM env m, HasConfig env, HasGHCVariant env)     => CompilerVersion     -> m EnvOverride setupCabalEnv compiler = do@@ -367,10 +356,7 @@ -- or the solution in terms of src package flag settings and extra -- dependencies. solveResolverSpec-    :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m-       , MonadReader env m, HasConfig env , HasGHCVariant env-       , HasHttpManager env , HasLogLevel env , HasReExec env-       , HasTerminal env)+    :: (StackM env m, HasConfig env, HasGHCVariant env)     => Path Abs File  -- ^ stack.yaml file location     -> [Path Abs Dir] -- ^ package dirs containing cabal files     -> ( Resolver@@ -396,15 +382,14 @@         -- 1. We do not want snapshot versions to override the sources         -- 2. Sources may have blank versions leading to bad cabal constraints         depOnlyConstraints = Map.difference depConstraints srcConstraints-        solver t = cabalSolver menv cabalDirs t-                               srcConstraints depOnlyConstraints $-                          ["-v"] -- TODO make it conditional on debug-                       ++ ["--ghcjs" | (whichCompiler compilerVer) == Ghcjs]+        solver t = cabalSolver menv cabalDirs t srcConstraints depOnlyConstraints $+                     "-v" : -- TODO make it conditional on debug+                     ["--ghcjs" | whichCompiler compilerVer == Ghcjs] -    let srcNames = (T.intercalate " and ") $+    let srcNames = T.intercalate " and " $           ["packages from " <> resolverName resolver               | not (Map.null snapConstraints)] ++-          [T.pack ((show $ Map.size extraConstraints) <> " external packages")+          [T.pack (show (Map.size extraConstraints) <> " external packages")               | not (Map.null extraConstraints)]      $logInfo "Asking cabal to calculate a build plan..."@@ -443,13 +428,13 @@                 inVers   = fmap fst srcConstraints                 bothVers = Map.intersectionWith (\v1 v2 -> (v1, v2))                                                 inVers outVers-            when (not $ outVers `Map.isSubmapOf` inVers) $ do+            unless (outVers `Map.isSubmapOf` inVers) $ do                 let msg = "Error: user package versions returned by cabal \                           \solver are not the same as the versions in the \                           \cabal files:\n"                 -- TODO We can do better in formatting the message                 error $ T.unpack $ msg-                        <> (showItems $ map show (Map.toList bothVers))+                        <> showItems (map show (Map.toList bothVers))              $logInfo $ "Successfully determined a build plan with "                      <> T.pack (show $ Map.size external)@@ -478,9 +463,7 @@ -- return the compiler version, package versions and packages flags -- for that resolver. getResolverConstraints-    :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m-       , MonadReader env m, HasConfig env , HasGHCVariant env-       , HasHttpManager env)+    :: (StackM env m, HasConfig env, HasGHCVariant env)     => Path Abs File     -> Resolver     -> m (CompilerVersion,@@ -499,9 +482,7 @@ -- If the package flags are passed as 'Nothing' then flags are chosen -- automatically. checkResolverSpec-    :: ( MonadIO m, MonadMask m, MonadLogger m, MonadReader env m-       , HasHttpManager env, HasConfig env, HasGHCVariant env-       , MonadBaseControl IO m)+    :: (StackM env m, HasConfig env, HasGHCVariant env)     => [C.GenericPackageDescription]     -> Maybe (Map PackageName (Map FlagName Bool))     -> Resolver@@ -544,10 +525,7 @@ -- pairs as well as any filenames for duplicate packages not included in the -- pairs. cabalPackagesCheck-    :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m-       , MonadReader env m, HasConfig env , HasGHCVariant env-       , HasHttpManager env , HasLogLevel env , HasReExec env-       , HasTerminal env)+    :: (StackM env m, HasConfig env, HasGHCVariant env)      => [Path Abs File]      -> String      -> Maybe String@@ -561,7 +539,7 @@     $logInfo $ "Using cabal packages:"     $logInfo $ T.pack (formatGroup relpaths) -    (warnings, gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps)+    (warnings, gpds) <- mapAndUnzipM readPackageUnresolved cabalfps     zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings      -- package name cannot be empty or missing otherwise@@ -582,7 +560,7 @@         error $ "Package name as defined in the .cabal file must match the \                 \.cabal file name.\n\                 \Please fix the following packages and try again:\n"-                <> (formatGroup rels)+                <> formatGroup rels      let dupGroups = filter ((> 1) . length)                             . groupSortOn (gpdPackageName . snd)@@ -635,20 +613,18 @@ -- dependencies in an existing stack.yaml and suggest changes in flags or -- extra dependencies so that the specified packages can be compiled. solveExtraDeps-    :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m-       , MonadReader env m, HasEnvConfig env, HasHttpManager env-       , HasLogLevel env, HasReExec env, HasTerminal env)+    :: (StackM env m, HasEnvConfig env)     => Bool -- ^ modify stack.yaml?     -> m () solveExtraDeps modStackYaml = do-    econfig <- asks getEnvConfig     bconfig <- asks getBuildConfig      let stackYaml = bcStackYaml bconfig-    relStackYaml <- toFilePath <$> makeRelativeToCurrentDir stackYaml+    relStackYaml <- prettyPath stackYaml      $logInfo $ "Using configuration file: " <> T.pack relStackYaml-    let cabalDirs = Map.keys $ envConfigPackages econfig+    packages <- getLocalPackages+    let cabalDirs = Map.keys packages         noPkgMsg = "No cabal packages found in " <> relStackYaml <>                    ". Please add at least one directory containing a .cabal \                    \file. You can also use 'stack init' to automatically \@@ -677,7 +653,7 @@     resolverResult <- checkResolverSpec gpds (Just oldSrcFlags) resolver'     resultSpecs <- case resolverResult of         BuildPlanCheckOk flags ->-            return $ Just ((mergeConstraints oldSrcs flags), Map.empty)+            return $ Just (mergeConstraints oldSrcs flags, Map.empty)         BuildPlanCheckPartial {} -> do             eres <- solveResolverSpec stackYaml cabalDirs                               (resolver', srcConstraints, extraConstraints)@@ -748,16 +724,16 @@                         ]          printFlags fl msg = do-            when ((not . Map.null) fl) $ do+            unless (Map.null fl) $ do                 $logInfo $ T.pack msg                 $logInfo $ indent $ decodeUtf8 $ Yaml.encode                                   $ object ["flags" .= fl]          printDeps deps msg = do-            when ((not . Map.null) deps) $ do+            unless (Map.null deps) $ do                 $logInfo $ T.pack msg-                $logInfo $ indent $ decodeUtf8 $ Yaml.encode $ object $-                        [("extra-deps" .= map fromTuple (Map.toList deps))]+                $logInfo $ indent $ decodeUtf8 $ Yaml.encode $ object+                        ["extra-deps" .= map fromTuple (Map.toList deps)]          writeStackYaml path res deps fl = do             let fp = toFilePath path@@ -778,6 +754,7 @@             , "        - Remove any unnecessary packages.\n"             , "        - Add any missing remote packages.\n"             , "        - Add extra dependencies to guide solver.\n"+            , "        - Adjust resolver.\n"             ]  prettyPath
src/Stack/Types/Build.hs view
@@ -52,7 +52,7 @@ import           Data.Char (isSpace) import           Data.Data import           Data.Hashable-import           Data.List (dropWhileEnd, intercalate)+import           Data.List.Extra import qualified Data.Map as Map import           Data.Map.Strict (Map) import           Data.Maybe@@ -75,8 +75,10 @@ import           Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, (</>)) import           Path.Extra (toFilePathNoTrailingSep) import           Prelude+import           Stack.Constants import           Stack.Types.BuildPlan (GitSHA1) import           Stack.Types.Compiler+import           Stack.Types.CompilerBuild import           Stack.Types.Config import           Stack.Types.FlagName import           Stack.Types.GhcPkgId@@ -93,14 +95,13 @@ data StackBuildException   = Couldn'tFindPkgId PackageName   | CompilerVersionMismatch-        (Maybe (CompilerVersion, Arch))-        (CompilerVersion, Arch)-        GHCVariant-        CompilerBuild+        (Maybe (CompilerVersion, Arch)) -- found+        (CompilerVersion, Arch) -- expected+        GHCVariant -- expected+        CompilerBuild -- expected         VersionCheck-        (Maybe (Path Abs File))+        (Maybe (Path Abs File)) -- Path to the stack.yaml file         Text -- recommended resolution-  -- ^ Path to the stack.yaml file   | Couldn'tParseTargets [Text]   | UnknownTargets     (Set PackageName) -- no known version@@ -142,10 +143,10 @@  instance Show StackBuildException where     show (Couldn'tFindPkgId name) =-              ("After installing " <> packageNameString name <>+              "After installing " <> packageNameString name <>                ", the package id couldn't be found " <> "(via ghc-pkg describe " <>                packageNameString name <> "). This shouldn't happen, " <>-               "please report as a bug")+               "please report as a bug"     show (CompilerVersionMismatch mactual (expected, earch) ghcVariant ghcBuild check mstack resolution) = concat                 [ case mactual of                     Nothing -> "No compiler found, expected "@@ -219,7 +220,7 @@           indent = dropWhileEnd isSpace . unlines . fmap (\line -> "  " ++ line) . lines           doubleIndent = indent . indent     show (TestSuiteTypeUnsupported interface) =-              ("Unsupported test suite type: " <> show interface)+              "Unsupported test suite type: " <> show interface      -- Supressing duplicate output     show (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bss) =         let fullCmd = unwords@@ -450,7 +451,7 @@     , bcoLocalInstallRoot :: !(Path Abs Dir)     , bcoBuildOpts :: !BuildOpts     , bcoBuildOptsCLI :: !BuildOptsCLI-    , bcoExtraDBs :: ![(Path Abs Dir)]+    , bcoExtraDBs :: ![Path Abs Dir]     }     deriving Show @@ -487,9 +488,7 @@     , "--enable-executable-profiling"     , "--enable-profiling"     , "--exact-configuration"-    ] || elem t-    [ "--user"-    ]+    ] || t == "--user"  configureOptsDirs :: BaseConfigOpts                   -> InstallLocation@@ -544,7 +543,7 @@                            else "-") <>                        flagNameString name)                     (Map.toList flags)-    , concatMap (\x -> ["--ghc-options", T.unpack x]) (packageGhcOptions package)+    , 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))     , maybe [] (\customGcc -> ["--with-gcc=" ++ toFilePath customGcc]) (configOverrideGccPath config)@@ -552,6 +551,7 @@     , ["--exact-configuration" | useExactConf]     ]   where+    wc = whichCompiler (envConfigCompilerVersion econfig)     config = getConfig econfig     bopts = bcoBuildOpts bco
src/Stack/Types/BuildPlan.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE TemplateHaskell            #-}+ {-# LANGUAGE DataKinds                  #-} -- | Shared types for various stackage packages. module Stack.Types.BuildPlan@@ -37,7 +37,7 @@ import           Control.DeepSeq (NFData) import           Control.Exception (Exception) import           Control.Monad.Catch (MonadThrow, throwM)-import           Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, withText, (.!=), (.:), (.:?), (.=))+import           Data.Aeson (FromJSON (..), FromJSONKey(..), ToJSON (..), ToJSONKey (..), object, withObject, withText, (.!=), (.:), (.:?), (.=)) import           Data.ByteString (ByteString) import qualified Data.ByteString as BS import           Data.Data@@ -121,7 +121,7 @@  instance ToJSON PackagePlan where     toJSON PackagePlan {..} = object-        $ maybe id (\cfi -> (("cabal-file-info" .= cfi):)) ppCabalFileInfo $+        $ maybe id (\cfi -> (("cabal-file-info" .= cfi):)) ppCabalFileInfo         [ "version"      .= ppVersion         , "github-pings" .= ppGithubPings         , "users"        .= ppUsers@@ -281,9 +281,7 @@  -- | Name of an executable. newtype ExeName = ExeName { unExeName :: Text }-    deriving (Show, Eq, Ord, Hashable, IsString, Generic, Store, NFData, Data, Typeable)-instance ToJSON ExeName where-    toJSON = toJSON . unExeName+    deriving (Show, Eq, Ord, Hashable, IsString, Generic, Store, NFData, Data, Typeable, ToJSON, ToJSONKey, FromJSONKey) instance FromJSON ExeName where     parseJSON = withText "ExeName" $ return . ExeName @@ -402,8 +400,7 @@ instance FromJSON Snapshots where     parseJSON = withObject "Snapshots" $ \o -> Snapshots         <$> (o .: "nightly" >>= parseNightly)-        <*> (fmap IntMap.unions-                $ mapM (parseLTS . snd)+        <*> fmap IntMap.unions (mapM (parseLTS . snd)                 $ filter (isLTS . fst)                 $ HashMap.toList o)       where@@ -420,11 +417,6 @@                 Left e -> fail $ show e                 Right (LTS x y) -> return $ IntMap.singleton x y                 Right (Nightly _) -> fail "Unexpected nightly value"--instance ToJSON a => ToJSON (Map ExeName a) where-  toJSON = toJSON . Map.mapKeysWith const unExeName-instance FromJSON a => FromJSON (Map ExeName a) where-    parseJSON = fmap (Map.mapKeysWith const ExeName) . parseJSON  -- | A simplified version of the 'BuildPlan' + cabal file. data MiniBuildPlan = MiniBuildPlan
src/Stack/Types/Compiler.hs view
@@ -8,8 +8,6 @@ import           Control.DeepSeq import           Data.Aeson import           Data.Data-import           Data.Map (Map)-import qualified Data.Map as Map import           Data.Monoid ((<>)) import           Data.Store (Store) import qualified Data.Text as T@@ -43,20 +41,11 @@ instance FromJSON CompilerVersion where     parseJSON (String t) = maybe (fail "Failed to parse compiler version") return (parseCompilerVersion t)     parseJSON _ = fail "Invalid CompilerVersion, must be String"-instance FromJSON a => FromJSON (Map CompilerVersion a) where-    -- TODO: Dedupe with similar code in Stack.Types.Version?-    ---    -- Maybe this ought to be abstracted into a 'JSONKey' class, so that a-    -- fully generic definition for Map can be provided.-    parseJSON val = do-        m <- parseJSON val-        fmap Map.fromList $ mapM go $ Map.toList m-      where-        go (k, v) = do-            let mparsed = parseCompilerVersion (T.pack k)-            case mparsed of-                Nothing -> fail $ "Failed to parse CompilerVersion " ++ k-                Just parsed -> return (parsed, v)+instance FromJSONKey CompilerVersion where+    fromJSONKey = FromJSONKeyTextParser $ \k ->+        case parseCompilerVersion k of+            Nothing -> fail $ "Failed to parse CompilerVersion " ++ T.unpack k+            Just parsed -> return parsed  parseCompilerVersion :: T.Text -> Maybe CompilerVersion parseCompilerVersion t
+ src/Stack/Types/CompilerBuild.hs view
@@ -0,0 +1,38 @@+module Stack.Types.CompilerBuild+  (CompilerBuild(..)+  ,compilerBuildName+  ,compilerBuildSuffix+  ,parseCompilerBuild+  ) where++import           Control.Monad.Catch (MonadThrow)+import           Data.Aeson.Extended (FromJSON, parseJSON, withText)+import           Data.Text as T++data CompilerBuild+    = CompilerBuildStandard+    | CompilerBuildSpecialized String+    deriving (Show)++instance FromJSON CompilerBuild where+    -- Strange structuring is to give consistent error messages+    parseJSON =+        withText+            "CompilerBuild"+            (either (fail . show) return . parseCompilerBuild . T.unpack)++-- | Descriptive name for compiler build+compilerBuildName :: CompilerBuild -> String+compilerBuildName CompilerBuildStandard = "standard"+compilerBuildName (CompilerBuildSpecialized s) = s++-- | Suffix to use for filenames/directories constructed with compiler build+compilerBuildSuffix :: CompilerBuild -> String+compilerBuildSuffix CompilerBuildStandard = ""+compilerBuildSuffix (CompilerBuildSpecialized s) = '-' : s++-- | Parse compiler build from a String.+parseCompilerBuild :: (MonadThrow m) => String -> m CompilerBuild+parseCompilerBuild "" = return CompilerBuildStandard+parseCompilerBuild "standard" = return CompilerBuildStandard+parseCompilerBuild name = return (CompilerBuildSpecialized name)
src/Stack/Types/Config.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiWayIf #-}@@ -44,10 +46,8 @@   ,parseGHCVariant   ,HasGHCVariant(..)   ,snapshotsDir-  -- ** CompilerBuild-  ,CompilerBuild(..)-  ,compilerBuildName-  ,compilerBuildSuffix+  -- ** Constraint synonym for use with StackMini+  ,StackMiniM   -- ** EnvConfig & HasEnvConfig   ,EnvConfig(..)   ,HasEnvConfig(..)@@ -62,6 +62,10 @@   ,WhichSolverCmd(..)   -- ** ConfigMonoid   ,ConfigMonoid(..)+  ,configMonoidInstallGHCName+  ,configMonoidSystemGHCName+  -- ** DumpLogs+  ,DumpLogs(..)   -- ** EnvSettings   ,EnvSettings(..)   ,minimalEnvSettings@@ -96,16 +100,9 @@   -- ** PvpBounds   ,PvpBounds(..)   ,parsePvpBounds-  -- ** Resolver & AbstractResolver-  ,Resolver-  ,LoadedResolver-  ,ResolverThat's(..)-  ,parseResolverText-  ,resolverDirName-  ,resolverName-  ,customResolverHash-  ,toResolverNotLoaded-  ,AbstractResolver(..)+  -- ** ColorWhen+  ,ColorWhen(..)+  ,readColorWhen   -- ** SCM   ,SCM(..)   -- ** CustomSnapshot@@ -145,6 +142,7 @@   -- ** Setup   ,DownloadInfo(..)   ,VersionedDownloadInfo(..)+  ,GHCDownloadInfo(..)   ,SetupInfo(..)   ,SetupInfoLocation(..)   -- ** Docker entrypoint@@ -157,12 +155,13 @@ import           Control.Arrow ((&&&)) import           Control.Exception import           Control.Monad (liftM, mzero, join)-import           Control.Monad.Catch (MonadThrow, throwM)-import           Control.Monad.Logger (LogLevel(..))+import           Control.Monad.Catch (MonadThrow, MonadMask)+import           Control.Monad.Logger (LogLevel(..), MonadLoggerIO) import           Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO)+import           Control.Monad.Trans.Control import           Data.Aeson.Extended                  (ToJSON, toJSON, FromJSON, parseJSON, withText, object,-                  (.=), (..:), (..:?), (..!=), Value(String, Object),+                  (.=), (..:), (..:?), (..!=), Value(Bool, String),                   withObjectWarnings, WarningParser, Object, jsonSubWarnings,                   jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings) import           Data.Attoparsec.Args@@ -182,7 +181,7 @@ import qualified Data.Set as Set import           Data.Text (Text) import qualified Data.Text as T-import           Data.Text.Encoding (encodeUtf8, decodeUtf8)+import           Data.Text.Encoding (encodeUtf8) import           Data.Typeable import           Data.Yaml (ParseException) import qualified Data.Yaml as Yaml@@ -192,26 +191,31 @@ import           GHC.Generics (Generic) import           Generics.Deriving.Monoid (memptydefault, mappenddefault) import           Network.HTTP.Client (parseRequest)+import           Options.Applicative (ReadM)+import qualified Options.Applicative as OA+import qualified Options.Applicative.Types as OA import           Path import qualified Paths_stack as Meta-import           Stack.Types.BuildPlan (MiniBuildPlan(..), SnapName, renderSnapName, parseSnapName, SnapshotHash (..), trimmedSnapshotHash)-import           Stack.Types.Urls+import           Stack.Types.BuildPlan (MiniBuildPlan(..), SnapName, renderSnapName) import           Stack.Types.Compiler+import           Stack.Types.CompilerBuild import           Stack.Types.Docker-import           Stack.Types.Nix import           Stack.Types.FlagName import           Stack.Types.Image+import           Stack.Types.Nix import           Stack.Types.PackageIdentifier import           Stack.Types.PackageIndex import           Stack.Types.PackageName+import           Stack.Types.Resolver import           Stack.Types.TemplateName+import           Stack.Types.Urls import           Stack.Types.Version import           System.FilePath (takeBaseName) import           System.PosixCompat.Types (UserID, GroupID, FileMode) import           System.Process.Read (EnvOverride, findExecutable)  -- Re-exports-import          Stack.Types.Config.Build as X+import           Stack.Types.Config.Build as X  #ifdef mingw32_HOST_OS import qualified Crypto.Hash.SHA1 as SHA1@@ -251,6 +255,8 @@          -- ^ The variant of GHC requested by the user.          -- In most cases, use 'BuildConfig' or 'MiniConfig's version instead,          -- which will have an auto-detected default.+         ,configGHCBuild            :: !(Maybe CompilerBuild)+         -- ^ Override build of the compiler distribution (e.g. standard, gmp4, tinfo6)          ,configUrls                :: !Urls          -- ^ URLs for other files used by stack.          -- TODO: Better document@@ -329,7 +335,11 @@          -- installation.          ,configPackageCaches       :: !(IORef (Maybe (Map PackageIdentifier (PackageIndex, PackageCache))))          -- ^ In memory cache of hackage index.+         ,configDumpLogs            :: !DumpLogs+         -- ^ Dump logs of local non-dependencies when doing a build.          ,configMaybeProject        :: !(Maybe (Project, Path Abs File))+         -- ^ 'Just' when a local project can be found, 'Nothing' when stack must+         -- fall back on the implicit global project.          }  -- | Which packages do ghc-options on the command line apply to?@@ -346,6 +356,26 @@             "everything" -> return AGOEverything             _ -> fail $ "Invalid ApplyGhcOptions: " ++ show t +-- | Which build log files to dump+data DumpLogs+  = DumpNoLogs -- ^ don't dump any logfiles+  | DumpWarningLogs -- ^ dump logfiles containing warnings+  | DumpAllLogs -- ^ dump all logfiles+  deriving (Show, Read, Eq, Ord, Enum, Bounded)++instance FromJSON DumpLogs where+  parseJSON (Bool True) = return DumpAllLogs+  parseJSON (Bool False) = return DumpNoLogs+  parseJSON v =+    withText+      "DumpLogs"+      (\t ->+          if | t == "none" -> return DumpNoLogs+             | t == "warning" -> return DumpWarningLogs+             | t == "all" -> return DumpAllLogs+             | otherwise -> fail ("Invalid DumpLogs: " ++ show t))+      v+ -- | Controls which version of the environment is used data EnvSettings = EnvSettings     { esIncludeLocals :: !Bool@@ -390,10 +420,12 @@     , globalDockerEntrypoint :: !(Maybe DockerEntrypoint)       -- ^ Data used when stack is acting as a Docker entrypoint (internal use only)     , globalLogLevel     :: !LogLevel -- ^ Log level+    , globalTimeInLog    :: !Bool -- ^ Whether to include timings in logs.     , globalConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'     , globalResolver     :: !(Maybe AbstractResolver) -- ^ Resolver override     , globalCompiler     :: !(Maybe CompilerVersion) -- ^ Compiler override     , globalTerminal     :: !Bool -- ^ We're in a terminal?+    , globalColorWhen    :: !ColorWhen -- ^ When to use ansi terminal colors     , globalStackYaml    :: !(Maybe FilePath) -- ^ Override project stack.yaml     } deriving (Show) @@ -403,10 +435,12 @@     , globalMonoidDockerEntrypoint :: !(First DockerEntrypoint)       -- ^ Data used when stack is acting as a Docker entrypoint (internal use only)     , globalMonoidLogLevel     :: !(First LogLevel) -- ^ Log level+    , globalMonoidTimeInLog    :: !(First Bool) -- ^ Whether to include timings in logs.     , globalMonoidConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'     , globalMonoidResolver     :: !(First AbstractResolver) -- ^ Resolver override     , globalMonoidCompiler     :: !(First CompilerVersion) -- ^ Compiler override     , globalMonoidTerminal     :: !(First Bool) -- ^ We're in a terminal?+    , globalMonoidColorWhen    :: !(First ColorWhen) -- ^ When to use ansi colors     , globalMonoidStackYaml    :: !(First FilePath) -- ^ Override project stack.yaml     } deriving (Show, Generic) @@ -414,20 +448,22 @@     mempty = memptydefault     mappend = mappenddefault --- | Either an actual resolver value, or an abstract description of one (e.g.,--- latest nightly).-data AbstractResolver-    = ARLatestNightly-    | ARLatestLTS-    | ARLatestLTSMajor !Int-    | ARResolver !Resolver-    | ARGlobal-    deriving Show- -- | Default logging level should be something useful but not crazy. defaultLogLevel :: LogLevel defaultLogLevel = LevelInfo +data ColorWhen = ColorNever | ColorAlways | ColorAuto+    deriving (Show, Generic)++readColorWhen :: ReadM ColorWhen+readColorWhen = do+    s <- OA.readerAsk+    case s of+        "never" -> return ColorNever+        "always" -> return ColorAlways+        "auto" -> return ColorAuto+        _ -> OA.readerError "Expected values of color option are 'never', 'always', or 'auto'."+ -- | A superset of 'Config' adding information on how to build code. The reason -- for this breakdown is because we will need some of the information from -- 'Config' in order to determine the values here.@@ -486,7 +522,10 @@     -- @stack list-dependencies | grep Cabal@ in the stack project.     ,envConfigCompilerVersion :: !CompilerVersion     ,envConfigCompilerBuild :: !CompilerBuild-    ,envConfigPackages   :: !(Map (Path Abs Dir) TreatLikeExtraDep)}+    ,envConfigPackagesRef :: !(IORef (Maybe (Map (Path Abs Dir) TreatLikeExtraDep)))+    -- ^ Cache for 'getLocalPackages'.+    }+ instance HasBuildConfig EnvConfig where     getBuildConfig = envConfigBuildConfig instance HasConfig EnvConfig@@ -509,12 +548,16 @@     }  data PackageEntry = PackageEntry-    { peExtraDep :: !TreatLikeExtraDep+    { peExtraDepMaybe :: !(Maybe TreatLikeExtraDep)     , peLocation :: !PackageLocation     , peSubdirs :: ![FilePath]     }     deriving Show +-- | Perform defaulting of peExtraDepMaybe+peExtraDepDef :: PackageEntry -> TreatLikeExtraDep+peExtraDepDef = fromMaybe False . peExtraDepMaybe+ -- | Should a package be treated just like an extra-dep? -- -- 'True' means, it will only be built as a dependency@@ -526,11 +569,11 @@ type TreatLikeExtraDep = Bool  instance ToJSON PackageEntry where-    toJSON pe | not (peExtraDep pe) && null (peSubdirs pe) =+    toJSON pe | not (peExtraDepDef pe) && null (peSubdirs pe) =         toJSON $ peLocation pe-    toJSON pe = object-        [ "extra-dep" .= peExtraDep pe-        , "location" .= peLocation pe+    toJSON pe = object $+        maybe id (\e -> (("extra-dep" .= e):)) (peExtraDepMaybe pe)+        [ "location" .= peLocation pe         , "subdirs" .= peSubdirs pe         ] instance FromJSON (WithJSONWarnings PackageEntry) where@@ -538,12 +581,12 @@         WithJSONWarnings loc _ <- parseJSON $ String t         return $ noJSONWarnings             PackageEntry-                { peExtraDep = False+                { peExtraDepMaybe = Nothing                 , peLocation = loc                 , peSubdirs = []                 }     parseJSON v = withObjectWarnings "PackageEntry" (\o -> PackageEntry-        <$> o ..:? "extra-dep" ..!= False+        <$> o ..:? "extra-dep"         <*> jsonSubWarnings (o ..: "location")         <*> o ..:? "subdirs" ..!= []) v @@ -618,90 +661,6 @@         , "extra-package-dbs" .= projectExtraPackageDBs p         ] -data IsLoaded = Loaded | NotLoaded--type LoadedResolver = ResolverThat's 'Loaded-type Resolver = ResolverThat's 'NotLoaded---- TODO: once GHC 8.0 is the lowest version we support, make these into--- actual haddock comments...---- | How we resolve which dependencies to install given a set of packages.-data ResolverThat's (l :: IsLoaded) where-    -- Use an official snapshot from the Stackage project, either an LTS-    -- Haskell or Stackage Nightly.-    ResolverSnapshot :: !SnapName -> ResolverThat's l-    -- Require a specific compiler version, but otherwise provide no-    -- build plan. Intended for use cases where end user wishes to-    -- specify all upstream dependencies manually, such as using a-    -- 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-    -- 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-    -- Like 'ResolverCustom', but after loading the build-plan, so we-    -- have a hash. This is necessary in order to identify the location-    -- files are stored for the resolver.-    ResolverCustomLoaded :: !Text -> !Text -> !SnapshotHash -> ResolverThat's 'Loaded--deriving instance Eq (ResolverThat's k)-deriving instance Show (ResolverThat's k)--instance ToJSON (ResolverThat's k) where-    toJSON x = case x of-        ResolverSnapshot{} -> toJSON $ resolverName x-        ResolverCompiler{} -> toJSON $ resolverName x-        ResolverCustom n l -> handleCustom n l-        ResolverCustomLoaded n l _ -> handleCustom n l-      where-        handleCustom n l = object-             [ "name" .= n-             , "location" .= l-             ]-instance FromJSON (WithJSONWarnings (ResolverThat's 'NotLoaded)) where-    -- Strange structuring is to give consistent error messages-    parseJSON v@(Object _) = withObjectWarnings "Resolver" (\o -> ResolverCustom-        <$> o ..: "name"-        <*> o ..: "location") v--    parseJSON (String t) = either (fail . show) return (noJSONWarnings <$> parseResolverText t)--    parseJSON _ = fail "Invalid Resolver, must be Object or String"---- | Convert a Resolver into its @Text@ representation, as will be used by--- directory names-resolverDirName :: LoadedResolver -> Text-resolverDirName (ResolverSnapshot name) = renderSnapName name-resolverDirName (ResolverCompiler v) = compilerVersionText v-resolverDirName (ResolverCustomLoaded name _ hash) = "custom-" <> name <> "-" <> decodeUtf8 (trimmedSnapshotHash hash)---- | Convert a Resolver into its @Text@ representation for human--- presentation.-resolverName :: ResolverThat's l -> Text-resolverName (ResolverSnapshot name) = renderSnapName name-resolverName (ResolverCompiler v) = compilerVersionText v-resolverName (ResolverCustom name _) = "custom-" <> name-resolverName (ResolverCustomLoaded name _ _) = "custom-" <> name--customResolverHash :: LoadedResolver-> Maybe SnapshotHash-customResolverHash (ResolverCustomLoaded _ _ hash) = Just hash-customResolverHash _ = Nothing---- | Try to parse a @Resolver@ from a @Text@. Won't work for complex resolvers (like custom).-parseResolverText :: MonadThrow m => Text -> m Resolver-parseResolverText t-    | Right x <- parseSnapName t = return $ ResolverSnapshot x-    | Just v <- parseCompilerVersion t = return $ ResolverCompiler v-    | otherwise = throwM $ ParseResolverException t--toResolverNotLoaded :: LoadedResolver -> Resolver-toResolverNotLoaded r = case r of-    ResolverSnapshot s -> ResolverSnapshot s-    ResolverCompiler v -> ResolverCompiler v-    ResolverCustomLoaded n l _ -> ResolverCustom n l- -- | Class for environment values which have access to the stack root class HasStackRoot env where     getStackRoot :: env -> Path Abs Dir@@ -755,6 +714,12 @@     getBuildConfig = id     {-# INLINE getBuildConfig #-} +-- | Constraint synonym for constraints satisfied by a 'MiniConfig'+-- environment.+type StackMiniM r m =+    ( MonadReader r m, MonadIO m, MonadBaseControl IO m, MonadLoggerIO m, MonadMask m+    )+ -- An uninterpreted representation of configuration options. -- Configurations may be "cascaded" using mappend (left-biased). data ConfigMonoid =@@ -794,7 +759,9 @@     ,configMonoidArch                :: !(First String)     -- ^ Used for overriding the platform     ,configMonoidGHCVariant          :: !(First GHCVariant)-    -- ^ Used for overriding the GHC variant+    -- ^ Used for overriding the platform+    ,configMonoidGHCBuild            :: !(First CompilerBuild)+    -- ^ Used for overriding the GHC build     ,configMonoidJobs                :: !(First Int)     -- ^ See: 'configJobs'     ,configMonoidExtraIncludeDirs    :: !(Set (Path Abs Dir))@@ -819,6 +786,8 @@     -- ^ Additional paths to search for executables in     ,configMonoidSetupInfoLocations  :: ![SetupInfoLocation]     -- ^ Additional setup info (inline or remote) to use for installing tools+    ,configMonoidLocalProgramsBase   :: !(First (Path Abs Dir))+    -- ^ Override the default local programs dir, where e.g. GHC is installed.     ,configMonoidPvpBounds           :: !(First PvpBounds)     -- ^ See 'configPvpBounds'     ,configMonoidModifyCodePage      :: !(First Bool)@@ -837,6 +806,8 @@     , configMonoidAllowDifferentUser :: !(First Bool)     -- ^ Allow users other than the stack root owner to use the stack     -- installation.+    , configMonoidDumpLogs           :: !(First DumpLogs)+    -- ^ See 'configDumpLogs'     }   deriving (Show, Generic) @@ -867,11 +838,12 @@     configMonoidInstallGHC <- First <$> obj ..:? configMonoidInstallGHCName     configMonoidSkipGHCCheck <- First <$> obj ..:? configMonoidSkipGHCCheckName     configMonoidSkipMsys <- First <$> obj ..:? configMonoidSkipMsysName-    configMonoidRequireStackVersion <- IntersectingVersionRange <$> unVersionRangeJSON <$>+    configMonoidRequireStackVersion <- IntersectingVersionRange . unVersionRangeJSON <$> (                                        obj ..:? configMonoidRequireStackVersionName-                                           ..!= VersionRangeJSON anyVersion+                                           ..!= VersionRangeJSON anyVersion)     configMonoidArch <- First <$> obj ..:? configMonoidArchName     configMonoidGHCVariant <- First <$> obj ..:? configMonoidGHCVariantName+    configMonoidGHCBuild <- First <$> obj ..:? configMonoidGHCBuildName     configMonoidJobs <- First <$> obj ..:? configMonoidJobsName     configMonoidExtraIncludeDirs <- obj ..:?  configMonoidExtraIncludeDirsName ..!= Set.empty     configMonoidExtraLibDirs <- obj ..:?  configMonoidExtraLibDirsName ..!= Set.empty@@ -893,6 +865,7 @@     configMonoidExtraPath <- obj ..:? configMonoidExtraPathName ..!= []     configMonoidSetupInfoLocations <-         maybeToList <$> jsonSubWarningsT (obj ..:?  configMonoidSetupInfoLocationsName)+    configMonoidLocalProgramsBase <- First <$> obj ..:? configMonoidLocalProgramsBaseName     configMonoidPvpBounds <- First <$> obj ..:? configMonoidPvpBoundsName     configMonoidModifyCodePage <- First <$> obj ..:? configMonoidModifyCodePageName     configMonoidExplicitSetupDeps <-@@ -903,6 +876,7 @@     configMonoidAllowNewer <- First <$> obj ..:? configMonoidAllowNewerName     configMonoidDefaultTemplate <- First <$> obj ..:? configMonoidDefaultTemplateName     configMonoidAllowDifferentUser <- First <$> obj ..:? configMonoidAllowDifferentUserName+    configMonoidDumpLogs <- First <$> obj ..:? configMonoidDumpLogsName      return ConfigMonoid {..}   where@@ -964,6 +938,9 @@ configMonoidGHCVariantName :: Text configMonoidGHCVariantName = "ghc-variant" +configMonoidGHCBuildName :: Text+configMonoidGHCBuildName = "ghc-build"+ configMonoidJobsName :: Text configMonoidJobsName = "jobs" @@ -1003,6 +980,9 @@ configMonoidSetupInfoLocationsName :: Text configMonoidSetupInfoLocationsName = "setup-info" +configMonoidLocalProgramsBaseName :: Text+configMonoidLocalProgramsBaseName = "local-programs-path"+ configMonoidPvpBoundsName :: Text configMonoidPvpBoundsName = "pvp-bounds" @@ -1027,6 +1007,9 @@ configMonoidAllowDifferentUserName :: Text configMonoidAllowDifferentUserName = "allow-different-user" +configMonoidDumpLogsName :: Text+configMonoidDumpLogsName = "dump-logs"+ data ConfigException   = ParseConfigFileException (Path Abs File) ParseException   | ParseCustomSnapshotException Text ParseException@@ -1043,6 +1026,9 @@   | BadStackRoot (Path Abs Dir)   | Won'tCreateStackRootInDirectoryOwnedByDifferentUser (Path Abs Dir) (Path Abs Dir) -- ^ @$STACK_ROOT@, parent dir   | UserDoesn'tOwnDirectory (Path Abs Dir)+  | FailedToCloneRepo String+  | ManualGHCVariantSettingsAreIncompatibleWithSystemGHC+  | NixRequiresSystemGhc   deriving Typeable instance Show ConfigException where     show (ParseConfigFileException configFile exception) = concat@@ -1050,7 +1036,7 @@         , toFilePath configFile         , "':\n"         , Yaml.prettyPrintParseException exception-        , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/."+        , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/"         ]     show (ParseCustomSnapshotException url exception) = concat         [ "Could not parse '"@@ -1058,7 +1044,7 @@         , "':\n"         , Yaml.prettyPrintParseException exception         -- FIXME: Link to docs about custom snapshots-        -- , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/."+        -- , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/"         ]     show (ParseResolverException t) = concat         [ "Invalid resolver value: "@@ -1097,7 +1083,7 @@         , "your package(s):\n"         , unlines $ map (\name -> "    - " <> T.unpack (renderSnapName name))                         (NonEmpty.toList names)-        , showOptions whichCmd+        , showOptions whichCmd Don'tSuggestSolver         ]     show (ResolverMismatch whichCmd resolver errDesc) = concat         [ "Resolver '"@@ -1105,7 +1091,7 @@         , "' does not have a matching compiler to build some or all of your "         , "package(s).\n"         , errDesc-        , showOptions whichCmd+        , showOptions whichCmd Don'tSuggestSolver         ]     show (ResolverPartial whichCmd resolver errDesc) = concat         [ "Resolver '"@@ -1113,6 +1099,9 @@         , "' does not have all the packages to match your requirements.\n"         , unlines $ fmap ("    " <>) (lines errDesc)         , showOptions whichCmd+            (case whichCmd of+                IsSolverCmd -> Don'tSuggestSolver+                _ -> SuggestSolver)         ]     show (NoSuchDirectory dir) =         "No directory could be located matching the supplied path: " ++ dir@@ -1138,22 +1127,48 @@         , T.unpack configMonoidAllowDifferentUserName         , "' to disable this precaution."         ]+    show (FailedToCloneRepo commandName) = concat+        [ "Failed to use "+        , commandName+        , " to clone the repo.  Please ensure that "+        , commandName+        , " is installed and available to stack on your PATH environment variable."+        ]+    show ManualGHCVariantSettingsAreIncompatibleWithSystemGHC = T.unpack $ T.concat+        [ "stack can only control the "+        , configMonoidGHCVariantName+        , " of its own GHC installations. Please use '--no-"+        , configMonoidSystemGHCName+        , "'."+        ]+    show NixRequiresSystemGhc = T.unpack $ T.concat+        [ "stack's Nix integration is incompatible with '--no-system-ghc'. "+        , "Please use '--"+        , configMonoidSystemGHCName+        , "' or disable the Nix integration."+        ] instance Exception ConfigException -showOptions :: WhichSolverCmd -> String-showOptions whichCmd = unlines $ "\nThis may be resolved by:" : options+showOptions :: WhichSolverCmd -> SuggestSolver -> String+showOptions whichCmd suggestSolver = unlines $ "\nThis may be resolved by:" : options   where     options =-        case whichCmd of+        (case suggestSolver of+            SuggestSolver -> [useSolver]+            Don'tSuggestSolver -> []) +++        (case whichCmd of             IsSolverCmd -> [useResolver]             IsInitCmd -> both-            IsNewCmd -> both+            IsNewCmd -> both)     both = [omitPackages, useResolver]+    useSolver    = "    - Using '--solver' to ask cabal-install to generate extra-deps, atop the chosen snapshot."     omitPackages = "    - Using '--omit-packages to exclude mismatching package(s)."     useResolver  = "    - Using '--resolver' to specify a matching snapshot/resolver"  data WhichSolverCmd = IsInitCmd | IsSolverCmd | IsNewCmd +data SuggestSolver = SuggestSolver | Don'tSuggestSolver+ -- | Helper function to ask the environment and apply getConfig askConfig :: (MonadReader env m, HasConfig env) => m Config askConfig = liftM getConfig ask@@ -1476,7 +1491,7 @@ -- | A PackageEntry for the current directory, used as a default packageEntryCurrDir :: PackageEntry packageEntryCurrDir = PackageEntry-    { peExtraDep = False+    { peExtraDepMaybe = Nothing     , peLocation = PLFilePath "."     , peSubdirs = []     }@@ -1541,20 +1556,6 @@           | otherwise -> return (GHCCustom s)  -- | Build of the compiler distribution (e.g. standard, gmp4, tinfo6)-data CompilerBuild-  = CompilerBuildStandard-  | CompilerBuildSpecialized String---- | Descriptive name for compiler build-compilerBuildName :: CompilerBuild -> String-compilerBuildName CompilerBuildStandard = "standard"-compilerBuildName (CompilerBuildSpecialized s) = s---- | Suffix to use for filenames/directories constructed with compiler build-compilerBuildSuffix :: CompilerBuild -> String-compilerBuildSuffix CompilerBuildStandard = ""-compilerBuildSuffix (CompilerBuildSpecialized s) = '-' : s- -- | Information for a file to download. data DownloadInfo = DownloadInfo     { downloadInfoUrl :: Text@@ -1594,11 +1595,29 @@             , vdiDownloadInfo = downloadInfo             } +data GHCDownloadInfo = GHCDownloadInfo+    { gdiConfigureOpts :: [Text]+    , gdiConfigureEnv :: Map Text Text+    , gdiDownloadInfo :: DownloadInfo+    }+    deriving Show++instance FromJSON (WithJSONWarnings GHCDownloadInfo) where+    parseJSON = withObjectWarnings "GHCDownloadInfo" $ \o -> do+        configureOpts <- o ..:? "configure-opts" ..!= mempty+        configureEnv <- o ..:? "configure-env" ..!= mempty+        downloadInfo <- parseDownloadInfoFromObject o+        return GHCDownloadInfo+            { gdiConfigureOpts = configureOpts+            , gdiConfigureEnv = configureEnv+            , gdiDownloadInfo = downloadInfo+            }+ data SetupInfo = SetupInfo     { siSevenzExe :: Maybe DownloadInfo     , siSevenzDll :: Maybe DownloadInfo     , siMsys2 :: Map Text VersionedDownloadInfo-    , siGHCs :: Map Text (Map Version DownloadInfo)+    , siGHCs :: Map Text (Map Version GHCDownloadInfo)     , siGHCJSs :: Map Text (Map CompilerVersion DownloadInfo)     , siStack :: Map Text (Map Version DownloadInfo)     }
+ src/Stack/Types/Config.hs-boot view
@@ -0,0 +1,35 @@+{-# LANGUAGE ExistentialQuantification #-}++module Stack.Types.Config where++import           Control.Exception+import           Data.List.NonEmpty (NonEmpty)+import           Distribution.Version+import           Data.Text (Text)+import           Data.Yaml (ParseException)+import           Path+import           Stack.Types.BuildPlan (SnapName)+import           {-# SOURCE #-} Stack.Types.Resolver (Resolver, ResolverThat's)++data WhichSolverCmd++data ConfigException+  = ParseConfigFileException (Path Abs File) ParseException+  | ParseCustomSnapshotException Text ParseException+  | ParseResolverException Text+  | NoProjectConfigFound (Path Abs Dir) (Maybe Text)+  | UnexpectedArchiveContents [Path Abs Dir] [Path Abs File]+  | UnableToExtractArchive Text (Path Abs File)+  | BadStackVersionException VersionRange+  | NoMatchingSnapshot WhichSolverCmd (NonEmpty SnapName)+  | forall l. ResolverMismatch WhichSolverCmd (ResolverThat's l) String+  | ResolverPartial WhichSolverCmd Resolver String+  | NoSuchDirectory FilePath+  | ParseGHCVariantException String+  | BadStackRoot (Path Abs Dir)+  | Won'tCreateStackRootInDirectoryOwnedByDifferentUser (Path Abs Dir) (Path Abs Dir) -- ^ @$STACK_ROOT@, parent dir+  | UserDoesn'tOwnDirectory (Path Abs Dir)+  | FailedToCloneRepo String+  | ManualGHCVariantSettingsAreIncompatibleWithSystemGHC+  | NixRequiresSystemGhc+instance Exception ConfigException
src/Stack/Types/Config/Build.hs view
@@ -52,6 +52,8 @@             -- ^ Open haddocks in the browser?             ,boptsHaddockDeps :: !(Maybe Bool)             -- ^ Build haddocks for dependencies?+            ,boptsHaddockInternal :: !Bool+            -- ^ Build haddocks for all symbols and packages, like @cabal haddock --internal@             ,boptsInstallExes :: !Bool             -- ^ Install executables to user path after building?             ,boptsPreFetch :: !Bool@@ -90,6 +92,7 @@     , boptsHaddockOpts = defaultHaddockOpts     , boptsOpenHaddocks = False     , boptsHaddockDeps = Nothing+    , boptsHaddockInternal = False     , boptsInstallExes = False     , boptsPreFetch = False     , boptsKeepGoing = Nothing@@ -114,6 +117,7 @@     , boptsCLIExec = []     , boptsCLIOnlyConfigure = False     , boptsCLICommand = Build+    , boptsCLIInitialBuildSteps = False     }  -- | Build options that may only be specified from the CLI@@ -127,6 +131,7 @@     , boptsCLIExec :: ![(String, [String])]     , boptsCLIOnlyConfigure :: !Bool     , boptsCLICommand :: !BuildCommand+    , boptsCLIInitialBuildSteps :: !Bool     } deriving Show  -- | Command sum type for conditional arguments.@@ -146,6 +151,7 @@     , buildMonoidHaddockOpts :: !HaddockOptsMonoid     , buildMonoidOpenHaddocks :: !(First Bool)     , buildMonoidHaddockDeps :: !(First Bool)+    , buildMonoidHaddockInternal :: !(First Bool)     , buildMonoidInstallExes :: !(First Bool)     , buildMonoidPreFetch :: !(First Bool)     , buildMonoidKeepGoing :: !(First Bool)@@ -167,6 +173,7 @@               buildMonoidHaddockOpts <- jsonSubWarnings (o ..:? buildMonoidHaddockOptsArgName ..!= mempty)               buildMonoidOpenHaddocks <- First <$> o ..:? buildMonoidOpenHaddocksArgName               buildMonoidHaddockDeps <- First <$> o ..:? buildMonoidHaddockDepsArgName+              buildMonoidHaddockInternal <- First <$> o ..:? buildMonoidHaddockInternalArgName               buildMonoidInstallExes <- First <$> o ..:? buildMonoidInstallExesArgName               buildMonoidPreFetch <- First <$> o ..:? buildMonoidPreFetchArgName               buildMonoidKeepGoing <- First <$> o ..:? buildMonoidKeepGoingArgName@@ -197,6 +204,9 @@  buildMonoidHaddockDepsArgName :: Text buildMonoidHaddockDepsArgName = "haddock-deps"++buildMonoidHaddockInternalArgName :: Text+buildMonoidHaddockInternalArgName = "haddock-internal"  buildMonoidInstallExesArgName :: Text buildMonoidInstallExesArgName = "copy-bins"
src/Stack/Types/Docker.hs view
@@ -129,9 +129,9 @@               dockerMonoidStackExe         <- First <$> o ..:? dockerStackExeArgName               dockerMonoidSetUser          <- First <$> o ..:? dockerSetUserArgName               dockerMonoidRequireDockerVersion-                                           <- IntersectingVersionRange <$> unVersionRangeJSON <$>+                                           <- IntersectingVersionRange . unVersionRangeJSON <$> (                                                  o ..:? dockerRequireDockerVersionArgName-                                                   ..!= VersionRangeJSON anyVersion+                                                   ..!= VersionRangeJSON anyVersion)               return DockerOptsMonoid{..})  -- | Left-biased combine Docker options
src/Stack/Types/FlagName.hs view
@@ -30,8 +30,6 @@ import           Data.Char (isLetter, isDigit, toLower) import           Data.Data import           Data.Hashable-import           Data.Map (Map)-import qualified Data.Map as Map import           Data.Store (Store) import           Data.Text (Text) import qualified Data.Text as T@@ -52,7 +50,7 @@ -- | A flag name. newtype FlagName =   FlagName Text-  deriving (Typeable,Data,Generic,Hashable,Store,NFData)+  deriving (Typeable,Data,Generic,Hashable,Store,NFData,ToJSONKey) instance Eq FlagName where     x == y = compare x y == EQ instance Ord FlagName where@@ -75,6 +73,10 @@            fail ("Couldn't parse flag name: " ++ s)          Just ver -> return ver +instance FromJSONKey FlagName where+  fromJSONKey = FromJSONKeyTextParser $ \k ->+    either (fail . show) return $ parseFlagName k+ -- | Attoparsec parser for a flag name flagNameParser :: Parser FlagName flagNameParser =@@ -125,12 +127,3 @@ toCabalFlagName (FlagName name) =   let !x = T.unpack name   in Cabal.FlagName x--instance ToJSON a => ToJSON (Map FlagName a) where-  toJSON = toJSON . Map.mapKeysWith const flagNameText-instance FromJSON a => FromJSON (Map FlagName a) where-    parseJSON val = do-        m <- parseJSON val-        fmap Map.fromList $ mapM go $ Map.toList m-      where-        go (k, v) = fmap (, v) $ either (fail . show) return $ parseFlagNameFromString k
src/Stack/Types/Internal.hs view
@@ -9,19 +9,16 @@ import Data.Monoid.Extra import Data.Text (Text) import Lens.Micro-import Network.HTTP.Client.Conduit (Manager,HasHttpManager(..)) import Stack.Types.Config  -- | Monadic environment. data Env config =   Env {envConfig :: !config-      ,envLogLevel :: !LogLevel-      ,envTerminal :: !Bool-      ,envAnsiTerminal :: !Bool       ,envReExec :: !Bool-      ,envManager :: !Manager+      ,envLogOptions :: !LogOptions+      ,envTerminal :: !Bool       ,envSticky :: !Sticky-      ,envSupportsUnicode :: !Bool}+      }  instance HasStackRoot config => HasStackRoot (Env config) where     getStackRoot = getStackRoot . envConfig@@ -37,25 +34,11 @@ instance HasEnvConfig config => HasEnvConfig (Env config) where     getEnvConfig = getEnvConfig . envConfig -instance HasHttpManager (Env config) where-  getHttpManager = envManager--class HasLogLevel r where-  getLogLevel :: r -> LogLevel--instance HasLogLevel (Env config) where-  getLogLevel = envLogLevel--instance HasLogLevel LogLevel where-  getLogLevel = id- class HasTerminal r where   getTerminal :: r -> Bool-  getAnsiTerminal :: r -> Bool  instance HasTerminal (Env config) where   getTerminal = envTerminal-  getAnsiTerminal = envAnsiTerminal  class HasReExec r where   getReExec :: r -> Bool@@ -63,24 +46,32 @@ instance HasReExec (Env config) where   getReExec = envReExec -class HasSupportsUnicode r where-  getSupportsUnicode :: r -> Bool--instance HasSupportsUnicode (Env config) where-  getSupportsUnicode = envSupportsUnicode- newtype Sticky = Sticky-    { unSticky :: Maybe (MVar (Maybe Text))-    }+  { unSticky :: Maybe (MVar (Maybe Text))+  }  class HasSticky r where-    getSticky :: r -> Sticky+  getSticky :: r -> Sticky  instance HasSticky (Env config) where   getSticky = envSticky +data LogOptions = LogOptions+  { logUseColor :: Bool+  , logUseUnicode :: Bool+  , logUseTime :: Bool+  , logMinLevel :: LogLevel+  , logVerboseFormat :: Bool+  }++class HasLogOptions r where+  getLogOptions :: r -> LogOptions++instance HasLogOptions (Env config) where+  getLogOptions = envLogOptions+ envEnvConfig :: Lens' (Env EnvConfig) EnvConfig-envEnvConfig = lens (envConfig)+envEnvConfig = lens envConfig                     (\s t -> s {envConfig = t})  buildOptsMonoidHaddock :: Lens' BuildOptsMonoid (Maybe Bool)@@ -102,13 +93,18 @@  buildOptsInstallExes :: Lens' BuildOpts Bool buildOptsInstallExes =-  lens (boptsInstallExes)+  lens boptsInstallExes        (\bopts t -> bopts {boptsInstallExes = t}) +buildOptsHaddock :: Lens' BuildOpts Bool+buildOptsHaddock =+  lens boptsHaddock+       (\bopts t -> bopts {boptsHaddock = t})+ envConfigBuildOpts :: Lens' EnvConfig BuildOpts envConfigBuildOpts =     lens-        (\envCfg -> configBuild (bcConfig (envConfigBuildConfig envCfg)))+        (configBuild . bcConfig . envConfigBuildConfig)         (\envCfg bopts ->               envCfg               { envConfigBuildConfig = (envConfigBuildConfig envCfg)@@ -121,9 +117,7 @@ globalOptsBuildOptsMonoid :: Lens' GlobalOpts BuildOptsMonoid globalOptsBuildOptsMonoid =     lens-        (\globalOpts ->-              configMonoidBuildOpts-                  (globalConfigMonoid globalOpts))+        (configMonoidBuildOpts . globalConfigMonoid)         (\globalOpts boptsMonoid ->               globalOpts               { globalConfigMonoid = (globalConfigMonoid globalOpts)
src/Stack/Types/Nix.hs view
@@ -26,6 +26,8 @@     -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix)   ,nixShellOptions :: ![Text]     -- ^ Options to be given to the nix-shell command line+  ,nixAddGCRoots :: !Bool+    -- ^ Should we register gc roots so running nix-collect-garbage doesn't remove nix dependencies   }   deriving (Show) @@ -46,6 +48,8 @@     -- ^ Options to be given to the nix-shell command line   ,nixMonoidPath :: !(First [Text])     -- ^ Override parts of NIX_PATH (notably 'nixpkgs')+  ,nixMonoidAddGCRoots :: !(First Bool)+    -- ^ Should we register gc roots so running nix-collect-garbage doesn't remove nix dependencies   }   deriving (Eq, Show, Generic) @@ -59,6 +63,7 @@               nixMonoidInitFile      <- First <$> o ..:? nixInitFileArgName               nixMonoidShellOptions  <- First <$> o ..:? nixShellOptsArgName               nixMonoidPath          <- First <$> o ..:? nixPathArgName+              nixMonoidAddGCRoots    <- First <$> o ..:? nixAddGCRootsArgName               return NixOptsMonoid{..})  -- | Left-biased combine Nix options@@ -89,3 +94,7 @@ -- | NIX_PATH override argument name nixPathArgName :: Text nixPathArgName = "path"++-- | Add GC roots arg name+nixAddGCRootsArgName :: Text+nixAddGCRootsArgName = "add-gc-roots"
src/Stack/Types/Package.hs view
@@ -3,18 +3,13 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-}--- |-+{-# LANGUAGE ConstraintKinds #-} module Stack.Types.Package where  import           Control.DeepSeq import           Control.Exception hiding (try,catch)-import           Control.Monad.Catch-import           Control.Monad.IO.Class-import           Control.Monad.Logger (MonadLogger)-import           Control.Monad.Reader import qualified Data.ByteString as S import           Data.Data import           Data.Function@@ -33,11 +28,11 @@ import           Data.Text.Encoding (encodeUtf8, decodeUtf8) import           Data.Word (Word64) import           Distribution.InstalledPackageInfo (PError)+import           Distribution.License (License) import           Distribution.ModuleName (ModuleName) import           Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier) import           Distribution.PackageDescription (TestSuiteInterface) import           Distribution.System (Platform (..))-import           Distribution.Text (display) import           GHC.Generics (Generic) import           Path as FL import           Prelude@@ -48,6 +43,7 @@ import           Stack.Types.GhcPkgId import           Stack.Types.PackageIdentifier import           Stack.Types.PackageName+import           Stack.Types.StackT (StackM) import           Stack.Types.Version  -- | All exceptions thrown by the library.@@ -66,9 +62,12 @@             Just file -> ' ' : toFilePath file) ++         ": " ++         show err-    show (PackageNoCabalFileFound dir) =-        "No .cabal file found in directory " ++-        toFilePath dir+    show (PackageNoCabalFileFound dir) = concat+        [ "Stack looks for packages in the directories configured in"+        , " the 'packages' variable defined in your stack.yaml\n"+        , "The current entry points to " ++ toFilePath dir +++          " but no .cabal file could be found there."+        ]     show (PackageMultipleCabalFilesFound dir files) =         "Multiple .cabal files found in directory " ++         toFilePath dir ++@@ -88,6 +87,7 @@ data Package =   Package {packageName :: !PackageName                    -- ^ Name of the package.           ,packageVersion :: !Version                     -- ^ Version of the package+          ,packageLicense :: !License                     -- ^ The license the package was released under.           ,packageFiles :: !GetPackageFiles               -- ^ Get all files of the package.           ,packageDeps :: !(Map PackageName VersionRange) -- ^ Packages that the package depends on.           ,packageTools :: ![Dependency]                  -- ^ A build tool name.@@ -115,7 +115,7 @@ -- | Files that the package depends on, relative to package directory. -- Argument is the location of the .cabal file newtype GetPackageOpts = GetPackageOpts-    { getPackageOpts :: forall env m. (MonadIO m,HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m, MonadLogger m, MonadCatch m)+    { getPackageOpts :: forall env m. (StackM env m, HasEnvConfig env)                      => SourceMap                      -> InstalledMap                      -> [PackageName]@@ -147,7 +147,7 @@ -- | Files that the package depends on, relative to package directory. -- Argument is the location of the .cabal file newtype GetPackageFiles = GetPackageFiles-    { getPackageFiles :: forall m env. (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadReader env m, HasPlatform env, HasEnvConfig env)+    { getPackageFiles :: forall m env. (StackM env m, HasEnvConfig env)                       => Path Abs File                       -> m (Map NamedComponent (Set ModuleName)                            ,Map NamedComponent (Set DotCabalPath)@@ -159,48 +159,15 @@  -- | Warning generated when reading a package data PackageWarning-    = UnlistedModulesWarning (Path Abs File) (Maybe String) [ModuleName]+    = UnlistedModulesWarning (Maybe String) [ModuleName]       -- ^ Modules found that are not listed in cabal file++    -- TODO: bring this back - see+    -- https://github.com/commercialhaskell/stack/issues/2649+    {-     | MissingModulesWarning (Path Abs File) (Maybe String) [ModuleName]       -- ^ Modules not found in file system, which are listed in cabal file-instance Show PackageWarning where-    show (UnlistedModulesWarning cabalfp component [unlistedModule]) =-        concat-            [ "module not listed in "-            , toFilePath (filename cabalfp)-            , case component of-                   Nothing -> " for library"-                   Just c -> " for '" ++ c ++ "'"-            , " component (add to other-modules): "-            , display unlistedModule]-    show (UnlistedModulesWarning cabalfp component unlistedModules) =-        concat-            [ "modules not listed in "-            , toFilePath (filename cabalfp)-            , case component of-                   Nothing -> " for library"-                   Just c -> " for '" ++ c ++ "'"-            , " component (add to other-modules):\n    "-            , intercalate "\n    " (map display unlistedModules)]-    show (MissingModulesWarning cabalfp component [missingModule]) =-        concat-            [ "module listed in "-            , toFilePath (filename cabalfp)-            , case component of-                   Nothing -> " for library"-                   Just c -> " for '" ++ c ++ "'"-            , " component not found in filesystem: "-            , display missingModule]-    show (MissingModulesWarning cabalfp component missingModules) =-        concat-            [ "modules listed in "-            , toFilePath (filename cabalfp)-            , case component of-                   Nothing -> " for library"-                   Just c -> " for '" ++ c ++ "'"-            , " component not found in filesystem:\n    "-            , intercalate "\n    " (map display missingModules)]-+    -}  -- | Package build configuration data PackageConfig =
src/Stack/Types/PackageIndex.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}
src/Stack/Types/PackageName.hs view
@@ -33,8 +33,6 @@ import           Data.Data import           Data.Hashable import           Data.List (intercalate)-import           Data.Map (Map)-import qualified Data.Map as Map import           Data.Store (Store) import           Data.Text (Text) import qualified Data.Text as T@@ -61,7 +59,7 @@ -- | A package name. newtype PackageName =   PackageName Text-  deriving (Eq,Ord,Typeable,Data,Generic,Hashable,NFData,Store)+  deriving (Eq,Ord,Typeable,Data,Generic,Hashable,NFData,Store,ToJSON,ToJSONKey)  instance Lift PackageName where   lift (PackageName n) =@@ -71,8 +69,6 @@ instance Show PackageName where   show (PackageName n) = T.unpack n -instance ToJSON PackageName where-    toJSON = toJSON . packageNameText instance FromJSON PackageName where   parseJSON j =     do s <- parseJSON j@@ -81,6 +77,10 @@            fail ("Couldn't parse package name: " ++ s)          Just ver -> return ver +instance FromJSONKey PackageName where+  fromJSONKey = FromJSONKeyTextParser $ \k ->+    either (fail . show) return $ parsePackageName k+ -- | Attoparsec parser for a package name packageNameParser :: Parser PackageName packageNameParser =@@ -140,15 +140,6 @@   where clean = liftM reverse . strip . reverse         strip ('l':'a':'b':'a':'c':'.':xs) = return xs         strip _ = throwM (CabalFileNameParseFail (toFilePath fp))--instance ToJSON a => ToJSON (Map PackageName a) where-  toJSON = toJSON . Map.mapKeysWith const packageNameText-instance FromJSON a => FromJSON (Map PackageName a) where-    parseJSON val = do-        m <- parseJSON val-        fmap Map.fromList $ mapM go $ Map.toList m-      where-        go (k, v) = fmap (, v) $ either (fail . show) return $ parsePackageNameFromString k  -- | An argument which accepts a template name of the format -- @foo.hsfiles@.
+ src/Stack/Types/Resolver.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}++module Stack.Types.Resolver+  (Resolver+  ,IsLoaded(..)+  ,LoadedResolver+  ,ResolverThat's(..)+  ,parseResolverText+  ,resolverDirName+  ,resolverName+  ,customResolverHash+  ,toResolverNotLoaded+  ,AbstractResolver(..)+  ,readAbstractResolver+  ) where++import           Control.Applicative+import           Control.Monad.Catch (MonadThrow, throwM)+import           Data.Aeson.Extended+                 (ToJSON, toJSON, FromJSON, parseJSON, object,+                  WithJSONWarnings(..), Value(String, Object), (.=),+                  noJSONWarnings, (..:), withObjectWarnings)+import           Data.Monoid.Extra+import           Data.Text (Text)+import qualified Data.Text as T+import           Data.Text.Encoding (decodeUtf8)+import           Data.Text.Read (decimal)+import           Options.Applicative (ReadM)+import qualified Options.Applicative as OA+import qualified Options.Applicative.Types as OA+import           Prelude+import           Stack.Types.BuildPlan (parseSnapName, renderSnapName, SnapName, SnapshotHash,+                                        trimmedSnapshotHash)+import           {-# SOURCE #-} Stack.Types.Config (ConfigException(..))+import           Stack.Types.Compiler++data IsLoaded = Loaded | NotLoaded++type LoadedResolver = ResolverThat's 'Loaded+type Resolver = ResolverThat's 'NotLoaded++-- TODO: once GHC 8.0 is the lowest version we support, make these into+-- actual haddock comments...++-- | How we resolve which dependencies to install given a set of packages.+data ResolverThat's (l :: IsLoaded) where+    -- Use an official snapshot from the Stackage project, either an LTS+    -- Haskell or Stackage Nightly.+    ResolverSnapshot :: !SnapName -> ResolverThat's l+    -- Require a specific compiler version, but otherwise provide no+    -- build plan. Intended for use cases where end user wishes to+    -- specify all upstream dependencies manually, such as using a+    -- 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+    -- 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+    -- Like 'ResolverCustom', but after loading the build-plan, so we+    -- have a hash. This is necessary in order to identify the location+    -- files are stored for the resolver.+    ResolverCustomLoaded :: !Text -> !Text -> !SnapshotHash -> ResolverThat's 'Loaded++deriving instance Eq (ResolverThat's k)+deriving instance Show (ResolverThat's k)++instance ToJSON (ResolverThat's k) where+    toJSON x = case x of+        ResolverSnapshot{} -> toJSON $ resolverName x+        ResolverCompiler{} -> toJSON $ resolverName x+        ResolverCustom n l -> handleCustom n l+        ResolverCustomLoaded n l _ -> handleCustom n l+      where+        handleCustom n l = object+             [ "name" .= n+             , "location" .= l+             ]+instance FromJSON (WithJSONWarnings (ResolverThat's 'NotLoaded)) where+    -- Strange structuring is to give consistent error messages+    parseJSON v@(Object _) = withObjectWarnings "Resolver" (\o -> ResolverCustom+        <$> o ..: "name"+        <*> o ..: "location") v++    parseJSON (String t) = either (fail . show) return (noJSONWarnings <$> parseResolverText t)++    parseJSON _ = fail "Invalid Resolver, must be Object or String"++-- | Convert a Resolver into its @Text@ representation, as will be used by+-- directory names+resolverDirName :: LoadedResolver -> Text+resolverDirName (ResolverSnapshot name) = renderSnapName name+resolverDirName (ResolverCompiler v) = compilerVersionText v+resolverDirName (ResolverCustomLoaded name _ hash) = "custom-" <> name <> "-" <> decodeUtf8 (trimmedSnapshotHash hash)++-- | Convert a Resolver into its @Text@ representation for human+-- presentation.+resolverName :: ResolverThat's l -> Text+resolverName (ResolverSnapshot name) = renderSnapName name+resolverName (ResolverCompiler v) = compilerVersionText v+resolverName (ResolverCustom name _) = "custom-" <> name+resolverName (ResolverCustomLoaded name _ _) = "custom-" <> name++customResolverHash :: LoadedResolver-> Maybe SnapshotHash+customResolverHash (ResolverCustomLoaded _ _ hash) = Just hash+customResolverHash _ = Nothing++-- | Try to parse a @Resolver@ from a @Text@. Won't work for complex resolvers (like custom).+parseResolverText :: MonadThrow m => Text -> m Resolver+parseResolverText t+    | Right x <- parseSnapName t = return $ ResolverSnapshot x+    | Just v <- parseCompilerVersion t = return $ ResolverCompiler v+    | otherwise = throwM $ ParseResolverException t++toResolverNotLoaded :: LoadedResolver -> Resolver+toResolverNotLoaded r = case r of+    ResolverSnapshot s -> ResolverSnapshot s+    ResolverCompiler v -> ResolverCompiler v+    ResolverCustomLoaded n l _ -> ResolverCustom n l++-- | Either an actual resolver value, or an abstract description of one (e.g.,+-- latest nightly).+data AbstractResolver+    = ARLatestNightly+    | ARLatestLTS+    | ARLatestLTSMajor !Int+    | ARResolver !Resolver+    | ARGlobal+    deriving Show++readAbstractResolver :: ReadM AbstractResolver+readAbstractResolver = do+    s <- OA.readerAsk+    case s of+        "global" -> return ARGlobal+        "nightly" -> return ARLatestNightly+        "lts" -> return ARLatestLTS+        'l':'t':'s':'-':x | Right (x', "") <- decimal $ T.pack x ->+            return $ ARLatestLTSMajor x'+        _ ->+            case parseResolverText $ T.pack s of+                Left e -> OA.readerError $ show e+                Right x -> return $ ARResolver x
+ src/Stack/Types/Resolver.hs-boot view
@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GADTs #-}++module Stack.Types.Resolver where++import           Data.Text (Text)+import           Stack.Types.BuildPlan (SnapName, SnapshotHash)+import           Stack.Types.Compiler++data IsLoaded = Loaded | NotLoaded++data ResolverThat's (l :: IsLoaded) where+    ResolverSnapshot :: !SnapName -> ResolverThat's l+    ResolverCompiler :: !CompilerVersion -> ResolverThat's l+    ResolverCustom :: !Text -> !Text -> ResolverThat's 'NotLoaded+    ResolverCustomLoaded :: !Text -> !Text -> !SnapshotHash -> ResolverThat's 'Loaded++type LoadedResolver = ResolverThat's 'Loaded++type Resolver = ResolverThat's 'NotLoaded
src/Stack/Types/StackT.hs view
@@ -9,20 +9,18 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  -- | The monad used for the command-line executable @stack@.  module Stack.Types.StackT   (StackT-  ,StackLoggingT+  ,HasEnv+  ,StackM   ,runStackT   ,runStackTGlobal-  ,runStackLoggingT-  ,runStackLoggingTGlobal   ,runInnerStackT-  ,runInnerStackLoggingT-  ,newTLSManager   ,logSticky   ,logStickyDone)   where@@ -50,13 +48,11 @@ import           GHC.Foreign (withCString, peekCString) import           Language.Haskell.TH import           Language.Haskell.TH.Syntax (lift)-import           Network.HTTP.Client.Conduit (HasHttpManager(..))-import           Network.HTTP.Conduit import           Prelude -- Fix AMP warning-import           System.FilePath-import           Stack.Types.Config (GlobalOpts (..))+import           Stack.Types.Config (GlobalOpts (..), ColorWhen(..)) import           Stack.Types.Internal import           System.Console.ANSI+import           System.FilePath import           System.IO import           System.Log.FastLogger @@ -67,6 +63,13 @@ import           System.Locale #endif +-- | Constraint synonym for all of the common environment instances+type HasEnv r = (HasLogOptions r, HasTerminal r, HasReExec r, HasSticky r)++-- | Constraint synonym for constraints commonly satisifed by monads used in stack.+type StackM r m =+    (MonadReader r m, MonadIO m, MonadBaseControl IO m, MonadLoggerIO m, MonadMask m, HasEnv r)+ -------------------------------------------------------------------------------- -- Main StackT monad transformer @@ -96,22 +99,31 @@  -- | Run a Stack action, using global options. runStackTGlobal :: (MonadIO m)-                => Manager -> config -> GlobalOpts -> StackT config m a -> m a-runStackTGlobal manager config GlobalOpts{..} =-    runStackT manager globalLogLevel config globalTerminal (isJust globalReExecVersion)+                => config -> GlobalOpts -> StackT config m a -> m a+runStackTGlobal config GlobalOpts{..} =+   runStackT config globalLogLevel globalTimeInLog globalTerminal globalColorWhen (isJust globalReExecVersion) --- | Run a Stack action. runStackT :: (MonadIO m)-          => Manager -> LogLevel -> config -> Bool -> Bool -> StackT config m a -> m a-runStackT manager logLevel config terminal reExec m = do-    ansiTerminal <- liftIO $ hSupportsANSI stderr+          => config -> LogLevel -> Bool -> Bool -> ColorWhen -> Bool -> StackT config m a -> m a+runStackT config logLevel useTime terminal colorWhen reExec m = do+    useColor <- case colorWhen of+        ColorNever -> return False+        ColorAlways -> return True+        ColorAuto -> liftIO $ hSupportsANSI stderr     canUseUnicode <- liftIO getCanUseUnicode-    withSticky-        terminal-        (\sticky ->-              runReaderT-                  (unStackT m)-                  (Env config logLevel terminal ansiTerminal reExec manager sticky canUseUnicode))+    withSticky terminal $ \sticky -> runReaderT (unStackT m) Env+        { envConfig = config+        , envReExec = reExec+        , envLogOptions = LogOptions+            { logUseColor = useColor+            , logUseUnicode = canUseUnicode+            , logUseTime = useTime+            , logMinLevel = logLevel+            , logVerboseFormat = logLevel <= LevelDebug+            }+        , envTerminal = terminal+        , envSticky = sticky+        }  -- | Taken from GHC: determine if we should use Unicode syntax getCanUseUnicode :: IO Bool@@ -123,139 +135,47 @@             return (str == str')     test `catchIOError` \_ -> return False ------------------------------------------------------------------------------------ Logging only StackLoggingT monad transformer---- | Monadic environment for 'StackLoggingT'.-data LoggingEnv = LoggingEnv-    { lenvLogLevel :: !LogLevel-    , lenvTerminal :: !Bool-    , lenvAnsiTerminal :: !Bool-    , lenvReExec :: !Bool-    , lenvManager :: !Manager-    , lenvSticky :: !Sticky-    , lenvSupportsUnicode :: !Bool-    }---- | The monad used for logging in the executable @stack@ before--- anything has been initialized.-newtype StackLoggingT m a = StackLoggingT-    { unStackLoggingT :: ReaderT LoggingEnv m a-    } deriving (Functor,Applicative,Monad,MonadIO,MonadThrow,MonadReader LoggingEnv,MonadCatch,MonadMask,MonadTrans)--deriving instance (MonadBase b m) => MonadBase b (StackLoggingT m)--instance MonadBaseControl b m => MonadBaseControl b (StackLoggingT m) where-    type StM (StackLoggingT m) a = ComposeSt StackLoggingT m a-    liftBaseWith     = defaultLiftBaseWith-    restoreM         = defaultRestoreM--instance MonadTransControl StackLoggingT where-    type StT StackLoggingT a = StT (ReaderT LoggingEnv) a-    liftWith = defaultLiftWith StackLoggingT unStackLoggingT-    restoreT = defaultRestoreT StackLoggingT---- | Takes the configured log level into account.-instance (MonadIO m) => MonadLogger (StackLoggingT m) where-    monadLoggerLog = stickyLoggerFunc--instance HasSticky LoggingEnv where-    getSticky = lenvSticky--instance HasLogLevel LoggingEnv where-    getLogLevel = lenvLogLevel--instance HasHttpManager LoggingEnv where-    getHttpManager = lenvManager--instance HasTerminal LoggingEnv where-    getTerminal = lenvTerminal-    getAnsiTerminal = lenvAnsiTerminal--instance HasReExec LoggingEnv where-    getReExec = lenvReExec--instance HasSupportsUnicode LoggingEnv where-    getSupportsUnicode = lenvSupportsUnicode--runInnerStackT :: (HasHttpManager r, HasLogLevel r, HasTerminal r, HasReExec r, MonadReader r m, MonadIO m)+runInnerStackT :: (HasEnv r, MonadReader r m, MonadIO m)                => config -> StackT config IO a -> m a runInnerStackT config inner = do-    manager <- asks getHttpManager-    logLevel <- asks getLogLevel-    terminal <- asks getTerminal     reExec <- asks getReExec-    liftIO $ runStackT manager logLevel config terminal reExec inner--runInnerStackLoggingT :: (HasHttpManager r, HasLogLevel r, HasTerminal r, HasReExec r, MonadReader r m, MonadIO m)-                      => StackLoggingT IO a -> m a-runInnerStackLoggingT inner = do-    manager <- asks getHttpManager-    logLevel <- asks getLogLevel+    logOptions <- asks getLogOptions     terminal <- asks getTerminal-    reExec <- asks getReExec-    liftIO $ runStackLoggingT manager logLevel terminal reExec inner---- | Run the logging monad, using global options.-runStackLoggingTGlobal :: MonadIO m-                       => Manager -> GlobalOpts -> StackLoggingT m a -> m a-runStackLoggingTGlobal manager GlobalOpts{..} =-    runStackLoggingT manager globalLogLevel globalTerminal (isJust globalReExecVersion)---- | Run the logging monad.-runStackLoggingT :: MonadIO m-                 => Manager -> LogLevel -> Bool -> Bool -> StackLoggingT m a -> m a-runStackLoggingT manager logLevel terminal reExec m = do-    ansiTerminal <- liftIO $ hSupportsANSI stderr-    canUseUnicode <- liftIO getCanUseUnicode-    withSticky-        terminal-        (\sticky ->-              runReaderT-                  (unStackLoggingT m)-                  LoggingEnv-                  { lenvLogLevel = logLevel-                  , lenvManager = manager-                  , lenvSticky = sticky-                  , lenvTerminal = terminal-                  , lenvAnsiTerminal = ansiTerminal-                  , lenvReExec = reExec-                  , lenvSupportsUnicode = canUseUnicode-                  })---- | Convenience for getting a 'Manager'-newTLSManager :: MonadIO m => m Manager-newTLSManager = liftIO $ newManager tlsManagerSettings+    sticky <- asks getSticky+    liftIO $ runReaderT (unStackT inner) Env+        { envConfig = config+        , envReExec = reExec+        , envLogOptions = logOptions+        , envTerminal = terminal+        , envSticky = sticky+        }  -------------------------------------------------------------------------------- -- Logging functionality stickyLoggerFunc-    :: (HasSticky r, HasLogLevel r, HasSupportsUnicode r, HasTerminal r, ToLogStr msg, MonadReader r m, MonadIO m)+    :: (HasEnv r, ToLogStr msg, MonadReader r m, MonadIO m)     => Loc -> LogSource -> LogLevel -> msg -> m () stickyLoggerFunc loc src level msg = do     func <- getStickyLoggerFunc     liftIO $ func loc src level msg  getStickyLoggerFunc-    :: (HasSticky r, HasLogLevel r, HasSupportsUnicode r, HasTerminal r, ToLogStr msg, MonadReader r m)+    :: (HasEnv r, ToLogStr msg, MonadReader r m)     => m (Loc -> LogSource -> LogLevel -> msg -> IO ()) getStickyLoggerFunc = do     sticky <- asks getSticky-    logLevel <- asks getLogLevel-    supportsUnicode <- asks getSupportsUnicode-    supportsAnsi <- asks getAnsiTerminal-    return $ stickyLoggerFuncImpl sticky logLevel supportsUnicode supportsAnsi+    lo <- asks getLogOptions+    return $ stickyLoggerFuncImpl sticky lo  stickyLoggerFuncImpl     :: ToLogStr msg-    => Sticky -> LogLevel -> Bool -> Bool+    => Sticky -> LogOptions     -> (Loc -> LogSource -> LogLevel -> msg -> IO ())-stickyLoggerFuncImpl (Sticky mref) maxLogLevel supportsUnicode supportsAnsi loc src level msg =+stickyLoggerFuncImpl (Sticky mref) lo loc src level msg =     case mref of         Nothing ->             loggerFunc-                supportsAnsi-                maxLogLevel+                lo                 out                 loc                 src@@ -275,7 +195,7 @@              -- Convert some GHC-generated Unicode characters as necessary             let msgText-                    | supportsUnicode = msgTextRaw+                    | logUseUnicode lo = msgTextRaw                     | otherwise = T.map replaceUnicode msgTextRaw              newState <-@@ -291,9 +211,9 @@                         hFlush out                         return (Just msgText)                     _-                      | level >= maxLogLevel -> do+                      | level >= logMinLevel lo -> do                           clear-                          loggerFunc supportsAnsi maxLogLevel out loc src level $ toLogStr msgText+                          loggerFunc lo out loc src level $ toLogStr msgText                           case sticky of                               Nothing ->                                   return Nothing@@ -316,9 +236,9 @@  -- | Logging function takes the log level into account. loggerFunc :: ToLogStr msg-           => Bool -> LogLevel -> Handle -> Loc -> Text -> LogLevel -> msg -> IO ()-loggerFunc supportsAnsi maxLogLevel outputChannel loc _src level msg =-   when (level >= maxLogLevel)+           => LogOptions -> Handle -> Loc -> Text -> LogLevel -> msg -> IO ()+loggerFunc lo outputChannel loc _src level msg =+   when (level >= logMinLevel lo)         (liftIO (do out <- getOutput                     T.hPutStrLn outputChannel out))   where@@ -335,10 +255,10 @@         , T.pack (ansi [Reset])         ]      where-       ansi xs | supportsAnsi = setSGRCode xs+       ansi xs | logUseColor lo = setSGRCode xs                | otherwise = ""        getTimestamp-         | maxLogLevel <= LevelDebug =+         | logVerboseFormat lo && logUseTime lo =            do now <- getZonedTime               return $                   ansi [SetColor Foreground Vivid Black]@@ -348,7 +268,7 @@            formatTime' =                take timestampLength . formatTime defaultTimeLocale "%F %T.%q"        getLevel-         | maxLogLevel <= LevelDebug =+         | logVerboseFormat lo =            return ((case level of                       LevelDebug -> ansi [SetColor Foreground Dull Green]                       LevelInfo -> ansi [SetColor Foreground Dull Blue]@@ -360,7 +280,7 @@                    "] ")          | otherwise = return ""        getLoc-         | maxLogLevel <= LevelDebug =+         | logVerboseFormat lo =            return $                ansi [SetColor Foreground Vivid Black] ++                "\n@(" ++ fileLocStr ++ ")"
src/Stack/Types/Version.hs view
@@ -38,8 +38,6 @@ import           Data.Data import           Data.Hashable import           Data.List-import           Data.Map (Map)-import qualified Data.Map as Map import           Data.Maybe (listToMaybe) import           Data.Monoid import           Data.Set (Set)@@ -95,14 +93,9 @@          Nothing ->            fail ("Couldn't parse package version: " ++ s)          Just ver -> return ver-instance FromJSON a => FromJSON (Map Version a) where-    parseJSON val = do-        m <- parseJSON val-        fmap Map.fromList $ mapM go $ Map.toList m-      where-        go (k, v) = do-            k' <- either (fail . show) return $ parseVersionFromString k-            return (k', v)+instance FromJSONKey Version where+  fromJSONKey = FromJSONKeyTextParser $ \k ->+    either (fail . show) return $ parseVersion k  newtype IntersectingVersionRange =     IntersectingVersionRange { getIntersectingVersionRange :: Cabal.VersionRange }@@ -116,7 +109,7 @@ -- | Attoparsec parser for a package version. versionParser :: Parser Version versionParser =-  do ls <- ((:) <$> num <*> many num')+  do ls <- (:) <$> num <*> many num'      let !v = V.fromList ls      return (Version v)   where num = decimal
src/Stack/Upgrade.hs view
@@ -1,22 +1,27 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE TemplateHaskell       #-}-module Stack.Upgrade (upgrade) where+module Stack.Upgrade+    ( upgrade+    , UpgradeOpts+    , upgradeOpts+    ) where -import           Control.Monad               (when)-import           Control.Monad.Catch+import           Control.Exception.Safe      (catchAny)+import           Control.Monad               (unless, when) import           Control.Monad.IO.Class import           Control.Monad.Logger-import           Control.Monad.Reader        (MonadReader)-import           Control.Monad.Trans.Control import           Data.Foldable               (forM_) import qualified Data.Map                    as Map import           Data.Maybe                  (isNothing) import           Data.Monoid.Extra import qualified Data.Text as T import           Lens.Micro                  (set)-import           Network.HTTP.Client.Conduit (HasHttpManager)+import           Options.Applicative import           Path import           Path.IO import qualified Paths_stack as Paths@@ -30,17 +35,154 @@ import           Stack.Types.Version import           Stack.Types.Config import           Stack.Types.Internal+import           Stack.Types.Resolver import           Stack.Types.StackT-import           System.Process              (readProcess)+import           System.Exit                 (ExitCode (ExitSuccess))+import           System.Process              (rawSystem, readProcess) import           System.Process.Run -upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)+upgradeOpts :: Parser UpgradeOpts+upgradeOpts = UpgradeOpts+    <$> (sourceOnly <|> optional binaryOpts)+    <*> (binaryOnly <|> optional sourceOpts)+  where+    binaryOnly = flag' Nothing (long "binary-only" <> help "Do not use a source upgrade path")+    sourceOnly = flag' Nothing (long "source-only" <> help "Do not use a binary upgrade path")++    binaryOpts = BinaryOpts+        <$> optional (strOption+              ( long "binary-platform"+             <> help "Platform type for archive to download"+             <> showDefault))+        <*> switch+         (long "force-download" <>+          help "Download a stack executable, even if the version number is older than what we have")+        <*> optional (strOption+         (long "binary-version" <>+          help "Download a specific version, even if it's out of date"))+        <*> optional (strOption+         (long "github-org" <>+          help "Github organization name"))+        <*> optional (strOption+         (long "github-repo" <>+          help "Github repository name"))++    sourceOpts = SourceOpts+        <$> ((\fromGit repo -> if fromGit then Just repo else Nothing)+                <$> switch+                    ( long "git"+                    <> help "Clone from Git instead of downloading from Hackage (more dangerous)" )+                <*> strOption+                    ( long "git-repo"+                    <> help "Clone from specified git repository"+                    <> value "https://github.com/commercialhaskell/stack"+                    <> showDefault ))++data BinaryOpts = BinaryOpts+    { _boPlatform :: !(Maybe String)+    , _boForce :: !Bool+    -- ^ force a download, even if the downloaded version is older+    -- than what we are+    , _boVersion :: !(Maybe String)+    -- ^ specific version to download+    , _boGithubOrg :: !(Maybe String)+    , _boGithubRepo :: !(Maybe String)+    }+    deriving Show+data SourceOpts = SourceOpts+    { _soRepo :: !(Maybe String)+    }+    deriving Show++data UpgradeOpts = UpgradeOpts+    { _uoBinary :: !(Maybe BinaryOpts)+    , _uoSource :: !(Maybe SourceOpts)+    }+    deriving Show++upgrade :: (StackM env m, HasConfig env)         => ConfigMonoid-        -> Maybe String -- ^ git repository to use         -> Maybe AbstractResolver         -> Maybe String -- ^ git hash at time of building, if known+        -> UpgradeOpts         -> m ()-upgrade gConfigMonoid gitRepo mresolver builtHash =+upgrade gConfigMonoid mresolver builtHash (UpgradeOpts mbo mso) =+    case (mbo, mso) of+        -- 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"+        (Just bo, Nothing) -> binary bo+        (Nothing, Just so) -> source so+        (Just bo, Just so) -> binary bo `catchAny` \e -> do+            $logWarn "Exception occured when trying to perform binary upgrade:"+            $logWarn $ T.pack $ show e+            $logWarn "Falling back to source upgrade"++            source so+  where+    binary bo = binaryUpgrade bo+    source so = sourceUpgrade gConfigMonoid mresolver builtHash so++binaryUpgrade+  :: (StackM env m, HasConfig env)+  => BinaryOpts+  -> m ()+binaryUpgrade (BinaryOpts mplatform force' mver morg mrepo) = do+    platforms0 <-+      case mplatform of+        Nothing -> preferredPlatforms+        Just p -> return [("windows" `T.isInfixOf` T.pack p, p)]+    archiveInfo <- downloadStackReleaseInfo morg mrepo mver++    let mdownloadVersion = getDownloadVersion archiveInfo+        force =+          case mver of+            Nothing -> force'+            Just _ -> True -- specifying a version implies we're forcing things+    isNewer <-+        case mdownloadVersion of+            Nothing -> do+                $logError "Unable to determine upstream version from Github metadata"+                unless force $+                    $logError "Rerun with --force-download to force an upgrade"+                return False+            Just downloadVersion -> do+                $logInfo $ T.concat+                    [ "Current Stack version: "+                    , versionText stackVersion+                    , ", available download version: "+                    , versionText downloadVersion+                    ]+                return $ downloadVersion > stackVersion++    toUpgrade <- case (force, isNewer) of+        (False, False) -> do+            $logInfo "Skipping binary upgrade, your version is already more recent"+            return False+        (True, False) -> do+            $logInfo "Forcing binary upgrade"+            return True+        (_, True) -> do+            $logInfo "Newer version detected, downloading"+            return True+    when toUpgrade $ do+        config <- askConfig+        downloadStackExe platforms0 archiveInfo (configLocalBin config) $ \tmpFile -> do+            -- Sanity check!+            ec <- rawSystem (toFilePath tmpFile) ["--version"]++            unless (ec == ExitSuccess)+                    $ error "Non-success exit code from running newly downloaded executable"++sourceUpgrade+  :: (StackM env m, HasConfig env)+  => ConfigMonoid+  -> Maybe AbstractResolver+  -> Maybe String+  -> SourceOpts+  -> m ()+sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) =   withSystemTempDir "stack-upgrade" $ \tmp -> do     menv <- getMinimalEnvOverride     mdir <- case gitRepo of
src/Stack/Upload.hs view
@@ -12,7 +12,6 @@     , UploadSettings     , defaultUploadSettings     , setUploadUrl-    , setGetManager     , setCredsSource     , setSaveCreds       -- * Credentials@@ -31,7 +30,7 @@ import           Control.Applicative import           Control.Exception                     (bracket) import qualified Control.Exception                     as E-import           Control.Monad                         (when, unless)+import           Control.Monad                         (when) import           Data.Aeson                            (FromJSON (..),                                                         ToJSON (..),                                                         eitherDecode', encode,@@ -39,24 +38,24 @@                                                         (.:), (.=)) import qualified Data.ByteString.Char8                 as S import qualified Data.ByteString.Lazy                  as L+import           Data.Conduit                          (ConduitM, runConduit, (.|))+import qualified Data.Conduit.Binary                   as CB import           Data.Text                             (Text) 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                   (BodyReader, Manager,-                                                        Response,-                                                        RequestBody(RequestBodyLBS),-                                                        applyBasicAuth, brRead,-                                                        newManager,-                                                        parseRequest,-                                                        requestHeaders,-                                                        responseBody,-                                                        responseStatus,-                                                        withResponse)+import           Network.HTTP.Client                   (Response,+                                                        RequestBody(RequestBodyLBS))+import           Network.HTTP.Simple                   (withResponse,+                                                        getResponseStatusCode,+                                                        getResponseBody,+                                                        setRequestHeader,+                                                        parseRequest) import           Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody)-import           Network.HTTP.Client.TLS               (tlsManagerSettings)-import           Network.HTTP.Types                    (statusCode)+import           Network.HTTP.Client.TLS               (getGlobalManager,+                                                        applyDigestAuth,+                                                        displayDigestAuthException) import           Path                                  (toFilePath) import           Prelude -- Fix redundant import warnings import           Stack.Types.Config@@ -192,25 +191,33 @@ -- Since 0.1.0.0 mkUploader :: Config -> UploadSettings -> IO Uploader mkUploader config us = do-    manager <- usGetManager us     (creds, fromFile') <- loadCreds $ usCredsSource us config     when (not fromFile' && usSaveCreds us) $ saveCreds config creds     req0 <- parseRequest $ usUploadUrl us-    let req1 = req0-            { requestHeaders = [("Accept", "text/plain")]-            }+    let req1 = setRequestHeader "Accept" ["text/plain"] req0     return Uploader         { upload_ = \tarName bytes -> do             let formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)]             req2 <- formDataBody formData req1-            let req3 = applyBasicAuth+            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 manager $ \res ->-                case statusCode $ responseStatus res of+            withResponse req3 $ \res ->+                case getResponseStatusCode res of                     200 -> putStrLn "done!"                     401 -> do                         putStrLn "authentication failure"@@ -233,15 +240,8 @@                         error $ "Upload failed on " ++ tarName         } -printBody :: Response BodyReader -> IO ()-printBody res =-    loop-  where-    loop = do-        bs <- brRead $ responseBody res-        unless (S.null bs) $ do-            S.hPut stdout bs-            loop+printBody :: Response (ConduitM () S.ByteString IO ()) -> IO ()+printBody res = runConduit $ getResponseBody res .| CB.sinkHandle stdout  -- | The computed value from a @UploadSettings@. --@@ -270,7 +270,6 @@ -- Since 0.1.0.0 data UploadSettings = UploadSettings     { usUploadUrl   :: !String-    , usGetManager  :: !(IO Manager)     , usCredsSource :: !(Config -> HackageCredsSource)     , usSaveCreds   :: !Bool     }@@ -283,7 +282,6 @@ defaultUploadSettings :: UploadSettings defaultUploadSettings = UploadSettings     { usUploadUrl = "https://hackage.haskell.org/packages/"-    , usGetManager = newManager tlsManagerSettings     , usCredsSource = fromAnywhere     , usSaveCreds = True     }@@ -295,14 +293,6 @@ -- Since 0.1.0.0 setUploadUrl :: String -> UploadSettings -> UploadSettings setUploadUrl x us = us { usUploadUrl = x }---- | How to get an HTTP connection manager.------ Default: @newManager tlsManagerSettings@------ Since 0.1.0.0-setGetManager :: IO Manager -> UploadSettings -> UploadSettings-setGetManager x us = us { usGetManager = x }  -- | How to get the Hackage credentials. --
src/System/Process/Log.hs view
@@ -9,8 +9,8 @@     ,showProcessArgDebug)     where -import           Control.Monad.Logger import           Control.Monad.IO.Class+import           Control.Monad.Logger import           Data.Monoid import           Data.Text (Text) import qualified Data.Text as T@@ -22,9 +22,9 @@ logCreateProcess :: Q Exp logCreateProcess =     [|let f :: MonadLogger m => CreateProcess -> m ()-          f (CreateProcess { cmdspec = ShellCommand shellCmd }) =+          f CreateProcess { cmdspec = ShellCommand shellCmd } =               $logDebug ("Creating shell process: " <> T.pack shellCmd)-          f (CreateProcess { cmdspec = RawCommand name args }) =+          f CreateProcess { cmdspec = RawCommand name args } =               $logDebug                   ("Creating process: " <> T.pack name <> " " <>                    T.intercalate@@ -48,15 +48,20 @@               x <- proc               end <- liftIO $ Clock.getTime Clock.Monotonic               let diff = Clock.diffTimeSpec start end+              -- useAnsi <- asks getAnsiTerminal+              let useAnsi = True               $logDebug-                  ("Process finished in " <> timeSpecMilliSecondText diff <>+                  ("Process finished in " <>+                  (if useAnsi then "\ESC[92m" else "") <> -- green+                  timeSpecMilliSecondText diff <>+                  (if useAnsi then "\ESC[0m" else "") <> -- reset                    ": " <> cmdText)               return x       in f|]  timeSpecMilliSecondText :: Clock.TimeSpec -> Text timeSpecMilliSecondText t =-    (T.pack . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> " ms"+    (T.pack . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> "ms"  -- | Show a process arg including speechmarks when necessary. Just for -- debugging purposes, not functionally important.
src/System/Process/Read.hs view
@@ -11,7 +11,9 @@  module System.Process.Read   (readProcessStdout+  ,readProcessStderrStdout   ,tryProcessStdout+  ,tryProcessStderrStdout   ,sinkProcessStdout   ,sinkProcessStderrStdout   ,sinkProcessStderrStdoutHandle@@ -35,6 +37,7 @@   )   where +import           Control.Applicative import           Control.Arrow ((***), first) import           Control.Concurrent.Async (concurrently) import           Control.Exception hiding (try, catch)@@ -71,8 +74,9 @@ import           System.Environment (getEnvironment) import           System.Exit import qualified System.FilePath as FP-import           System.IO (Handle)+import           System.IO (Handle, hClose) import           System.Process.Log+import           Prelude () -- Hide post-AMP warnings  -- | Override the environment received by a child process. data EnvOverride = EnvOverride@@ -164,6 +168,17 @@ tryProcessStdout wd menv name args =     try (readProcessStdout wd menv name args) +-- | Try to produce strict 'S.ByteString's from the stderr and stdout of a+-- process.+tryProcessStderrStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m)+                       => Maybe (Path Abs Dir) -- ^ Optional directory to run in+                       -> EnvOverride+                       -> String -- ^ Command+                       -> [String] -- ^ Command line arguments+                       -> m (Either ReadProcessException (S.ByteString, S.ByteString))+tryProcessStderrStdout wd menv name args =+    try (readProcessStderrStdout wd menv name args)+ -- | Produce a strict 'S.ByteString' from the stdout of a process. -- -- Throws a 'ReadProcessException' exception if the process fails.@@ -177,15 +192,29 @@   sinkProcessStdout wd menv name args CL.consume >>=   liftIO . evaluate . S.concat +-- | Produce strict 'S.ByteString's from the stderr and stdout of a process.+--+-- Throws a 'ReadProcessException' exception if the process fails.+readProcessStderrStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)+                        => Maybe (Path Abs Dir) -- ^ Optional directory to run in+                        -> EnvOverride+                        -> String -- ^ Command+                        -> [String] -- ^ Command line arguments+                        -> m (S.ByteString, S.ByteString)+readProcessStderrStdout wd menv name args = do+  (e, o) <- sinkProcessStderrStdout wd menv name args CL.consume CL.consume+  liftIO $ (,) <$> evaluate (S.concat e) <*> evaluate (S.concat o)+ -- | An exception while trying to read from process. data ReadProcessException-    = ReadProcessException CreateProcess ExitCode L.ByteString L.ByteString+    = ProcessFailed CreateProcess ExitCode L.ByteString L.ByteString+    -- ^ @'ProcessFailed' createProcess exitCode stdout stderr@     | NoPathFound     | ExecutableNotFound String [FilePath]     | ExecutableNotFoundAt FilePath     deriving Typeable instance Show ReadProcessException where-    show (ReadProcessException cp ec out err) = concat $+    show (ProcessFailed cp ec out err) = concat $         [ "Running "         , showSpec $ cmdspec cp] ++         maybe [] (\x -> [" in directory ", x]) (cwd cp) ++@@ -243,7 +272,7 @@           (\(ProcessExitedUnsuccessfully cp ec) ->                do stderrBuilder <- liftIO (readIORef stderrBuffer)                   stdoutBuilder <- liftIO (readIORef stdoutBuffer)-                  throwM $ ReadProcessException+                  throwM $ ProcessFailed                     cp                     ec                     (toLazyByteString stdoutBuilder)@@ -279,8 +308,21 @@           (proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd }           (\ClosedStream out err -> f err out)   where-    f :: Source IO S.ByteString -> Source IO S.ByteString -> IO (e, o)-    f err out = (err $$ sinkStderr) `concurrently` (out $$ sinkStdout)++    -- There is a bug in streaming-commons or conduit-extra which+    -- leads to a file descriptor leak. Ideally, we should be able to+    -- simply use the following code. Instead, we're using the code+    -- below it, which is explicit in closing Handles. When the+    -- upstream bug is fixed, we can consider moving back to the+    -- simpler code, though there's really no downside to the more+    -- complex version used here.+    --+    -- f :: Source IO S.ByteString -> Source IO S.ByteString -> IO (e, o)+    -- f err out = (err $$ sinkStderr) `concurrently` (out $$ sinkStdout)++    f :: Handle -> Handle -> IO (e, o)+    f err out = ((CB.sourceHandle err $$ sinkStderr) `concurrently` (CB.sourceHandle out $$ sinkStdout))+        `finally` hClose err `finally` hClose out  -- | Like sinkProcessStderrStdout, but receives Handles for stderr and stdout instead of 'Sink's. --
src/System/Process/Run.hs view
@@ -30,8 +30,7 @@ import           Data.Foldable (forM_) import           Data.Text (Text) import qualified Data.Text as T-import           Path (Dir, Abs, Path)-import           Path (toFilePath)+import           Path (Dir, Abs, Path, toFilePath) import           Prelude -- Fix AMP warning import           System.Exit (exitWith, ExitCode (..)) import           System.IO@@ -64,7 +63,7 @@       -> Cmd       -> Maybe Text  -- ^ optional additional error message       -> m ()-runCmd' modCP cmd@(Cmd{..}) mbErrMsg = do+runCmd' modCP cmd@Cmd{..} mbErrMsg = do     result <- try (callProcess' modCP cmd)     case result of         Left (ProcessExitedUnsuccessfully _ ec) -> do
src/Text/PrettyPrint/Leijen/Extended.hs view
@@ -7,7 +7,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} -- | This module re-exports some of the interface for@@ -180,7 +180,7 @@     getAnsiAnn _ = mempty  displayPlain :: Display a => a -> T.Text-displayPlain = LT.toStrict . displayAnsiSimple . renderDefault . fmap (\_ -> mempty) . display+displayPlain = LT.toStrict . displayAnsiSimple . renderDefault . fmap (const mempty) . display  -- TODO: tweak these settings more? -- TODO: options for settings if this is released as a lib@@ -208,7 +208,7 @@             new = if Reset `elem` sgrs                       then M.fromList sgrs'                       else foldl (\mp (tag, sgr) -> M.insert tag sgr mp) old sgrs'-        (extra, contents) <- local (\_ -> new) inner+        (extra, contents) <- local (const new) inner         return (extra, transitionCodes old new <> contents <> transitionCodes new old)     transitionCodes old new =         case (null removals, null additions) of
src/main/Main.hs view
@@ -72,7 +72,18 @@ import qualified Stack.Image as Image import           Stack.Init import           Stack.New-import           Stack.Options+import           Stack.Options.BuildParser+import           Stack.Options.CleanParser+import           Stack.Options.DockerParser+import           Stack.Options.DotParser+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.SolverParser+import           Stack.Options.Utils import qualified Stack.PackageIndex import qualified Stack.Path import           Stack.Runners@@ -126,9 +137,9 @@   where #endif #ifdef HIDE_DEP_VERSIONS-    depsString = (" hpack-" ++ VERSION_hpack)+    depsString = " hpack-" ++ VERSION_hpack #else-    depsString = ("\nCompiled with:\n" ++ unlines (map ("- " ++) Build_stack.deps))+    depsString = "\nCompiled with:\n" ++ unlines (map ("- " ++) Build_stack.deps) #endif  main :: IO ()@@ -154,7 +165,7 @@    eGlobalRun <- try $ commandLineHandler progName False   case eGlobalRun of-    Left (exitCode :: ExitCode) -> do+    Left (exitCode :: ExitCode) ->       throwIO exitCode     Right (globalMonoid,run) -> do       let global = globalOptsFromMonoid isTerminal globalMonoid@@ -162,9 +173,8 @@       case globalReExecVersion global of           Just expectVersion -> do               expectVersion' <- parseVersionFromString expectVersion-              if checkVersion MatchMinor expectVersion' (fromCabalVersion Meta.version)-                  then return ()-                  else throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version)+              unless (checkVersion MatchMinor expectVersion' (fromCabalVersion Meta.version))+                  $ throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version)           _ -> return ()       run global `catch` \e ->           -- This special handler stops "stack: " from being printed before the@@ -191,9 +201,7 @@   VERSION_hpack   "stack - The Haskell Tool Stack"   ""-  ("stack's documentation is available at https://docs.haskellstack.org/en/v" <>-   showVersion Meta.version <>-   "/README/")+  "stack's documentation is available at https://docs.haskellstack.org/"   (globalOpts OuterGlobalOpts)   (Just failureCallback)   addCommands@@ -217,7 +225,7 @@       else handleParseResult (Failure f)      addCommands = do-      when (not isInterpreter) (do+      unless isInterpreter (do         addBuildCommand' "build"                          "Build the package(s) in this directory/configuration"                          buildCmd@@ -275,16 +283,9 @@                     updateCmd                     (pure ())         addCommand' "upgrade"-                    "Upgrade to the latest stack (experimental)"+                    "Upgrade to the latest stack"                     upgradeCmd-                    ((,) <$> switch-                              ( long "git"-                             <> help "Clone from Git instead of downloading from Hackage (more dangerous)" )-                         <*> strOption-                              ( long "git-repo"-                             <> help "Clone from specified git repository"-                             <> value "https://github.com/commercialhaskell/stack"-                             <> showDefault ))+                    upgradeOpts         addCommand'             "upload"             "Upload a package to Hackage"@@ -312,7 +313,7 @@         addCommand' "dot"                     "Visualize your project's dependency graph using Graphviz dot"                     dotCmd-                    dotOptsParser+                    (dotOptsParser False) -- Default for --external is False.         addCommand' "ghc"                     "Run ghc"                     execCmd@@ -336,14 +337,14 @@                   "Execute a command"                   execCmd                   (execOptsParser Nothing)-      addCommand' "ghci"-                  "Run ghci in the context of package(s) (experimental)"-                  ghciCmd-                  ghciOptsParser-      addCommand' "repl"-                  "Run ghci in the context of package(s) (experimental) (alias for 'ghci')"-                  ghciCmd-                  ghciOptsParser+      addGhciCommand' "ghci"+                      "Run ghci in the context of package(s) (experimental)"+                      ghciCmd+                      ghciOptsParser+      addGhciCommand' "repl"+                      "Run ghci in the context of package(s) (experimental) (alias for 'ghci')"+                      ghciCmd+                      ghciOptsParser       addCommand' "runghc"                   "Run runghc"                   execCmd@@ -353,7 +354,7 @@                   execCmd                   (execOptsParser $ Just ExecRunGhc) -      when (not isInterpreter) (do+      unless isInterpreter (do         addCommand' "eval"                     "Evaluate some haskell code inline. Shortcut for 'stack exec ghc -- -e CODE'"                     evalCmd@@ -365,12 +366,7 @@         addCommand' "list-dependencies"                     "List the dependencies"                     listDependenciesCmd-                    (textOption (long "separator" <>-                                 metavar "SEP" <>-                                 help ("Separator between package name " <>-                                       "and package version.") <>-                                 value " " <>-                                 showDefault))+                    listDepsOptsParser         addCommand' "query"                     "Query general build information (experimental)"                     queryCmd@@ -432,7 +428,7 @@           "hpc"           "Subcommands specific to Haskell Program Coverage"           (addCommand' "report"-                        "Generate HPC report a combined HPC report"+                        "Generate unified HPC coverage report from tix files and project targets"                         hpcReportCmd                         hpcReportOptsParser)         )@@ -458,6 +454,12 @@         addBuildCommand' cmd title constr =             addCommand cmd title globalFooter constr (globalOpts BuildCmdGlobalOpts) +        -- Additional helper that hides global options and shows some ghci options+        addGhciCommand' :: String -> String -> (a -> GlobalOpts -> IO ()) -> Parser a+                         -> AddCommand+        addGhciCommand' cmd title constr =+            addCommand cmd title globalFooter constr (globalOpts GhciCmdGlobalOpts)+     globalOpts :: GlobalOptsContext -> Parser GlobalOptsMonoid     globalOpts kind =         extraHelpOption hide progName (Docker.dockerCmdName ++ "*") Docker.dockerHelpOptName <*>@@ -470,7 +472,7 @@     globalFooter = "Run 'stack --help' for global options that apply to all subcommands."  type AddCommand =-    EitherT (GlobalOpts -> IO ()) (Writer (Mod CommandFields ((GlobalOpts -> IO ()), GlobalOptsMonoid))) ()+    EitherT (GlobalOpts -> IO ()) (Writer (Mod CommandFields (GlobalOpts -> IO (), GlobalOptsMonoid))) ()  -- | fall-through to external executables in `git` style if they exist -- (i.e. `stack something` looks for `stack-something` before@@ -481,7 +483,7 @@   -> IO (ParserFailure ParserHelp) secondaryCommandHandler args f =     -- don't even try when the argument looks like a path or flag-    if elem pathSeparator cmd || "-" `isPrefixOf` (head args)+    if elem pathSeparator cmd || "-" `isPrefixOf` head args        then return f     else do       mExternalExec <- D.findExecutable cmd@@ -497,7 +499,7 @@   where     -- FIXME this is broken when any options are specified before the command     -- e.g. stack --verbosity silent cmd-    cmd = stackProgName ++ "-" ++ (head args)+    cmd = stackProgName ++ "-" ++ head args     noSuchCmd name = errorHelp $ stringChunk       ("Auxiliary command not found in path `" ++ name ++ "'") @@ -532,7 +534,7 @@     -- or a Stack option referencing a file. In that case we only show the     -- interpreter error message and exclude the command related error messages.     errorCombine =-      if elem pathSeparator firstArg+      if pathSeparator `elem` firstArg       then overrideErrorHelp       else vcatErrorHelp @@ -560,16 +562,16 @@  setupCmd :: SetupCmdOpts -> GlobalOpts -> IO () setupCmd sco@SetupCmdOpts{..} go@GlobalOpts{..} = do-  (manager,lc) <- loadConfigWithOpts go+  lc <- loadConfigWithOpts go   withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> do-    let getCompilerVersion = loadCompilerVersion manager go lc-    runStackTGlobal manager (lcConfig lc) go $ do+    let getCompilerVersion = loadCompilerVersion go lc+    runStackTGlobal (lcConfig lc) go $       Docker.reexecWithOptionalContainer           (lcProjectRoot lc)           Nothing-          (runStackTGlobal manager (lcConfig lc) go $+          (runStackTGlobal (lcConfig lc) go $            Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion $-           runStackLoggingTGlobal manager go $ do+           runStackTGlobal () go $ do               (wantedCompiler, compilerCheck, mstack) <-                   case scoCompilerVersion of                       Just v -> return (v, MatchMinor, Nothing)@@ -579,8 +581,8 @@                                  , configCompilerCheck (lcConfig lc)                                  , Just $ bcStackYaml bc                                  )-              miniConfig <- loadMiniConfig manager (lcConfig lc)-              runStackTGlobal manager miniConfig go $+              miniConfig <- loadMiniConfig (lcConfig lc)+              runStackTGlobal miniConfig go $                   setup sco wantedCompiler compilerCheck mstack               )           Nothing@@ -629,16 +631,16 @@ updateCmd () go = withConfigAndLock go $     getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices -upgradeCmd :: (Bool, String) -> GlobalOpts -> IO ()-upgradeCmd (fromGit, repo) go = withGlobalConfigAndLock go $ do+upgradeCmd :: UpgradeOpts -> GlobalOpts -> IO ()+upgradeCmd upgradeOpts' go = withGlobalConfigAndLock go $     upgrade (globalConfigMonoid go)-            (if fromGit then Just repo else Nothing)             (globalResolver go) #ifdef USE_GIT_INFO             (find (/= "UNKNOWN") [$gitHash]) #else             Nothing #endif+            upgradeOpts'  -- | Upload to Hackage uploadCmd :: ([String], Maybe PvpBounds, Bool, Bool, String) -> GlobalOpts -> IO ()@@ -657,13 +659,9 @@     let getUploader :: (HasConfig config) => StackT config IO Upload.Uploader         getUploader = do             config <- asks getConfig-            manager <- asks envManager-            let uploadSettings =-                    Upload.setGetManager (return manager) Upload.defaultUploadSettings-            liftIO $ Upload.mkUploader config uploadSettings+            liftIO $ Upload.mkUploader config Upload.defaultUploadSettings     withBuildConfigAndLock go $ \_ -> do         uploader <- getUploader-        manager <- asks envManager         unless ignoreCheck $             mapM_ (resolveFile' >=> checkSDistTarball) files         forM_@@ -676,7 +674,6 @@                          don'tSign                          (void $                           Sig.sign-                              manager                               sigServerUrl                               tarFile))         unless (null dirs) $@@ -690,7 +687,6 @@                     don'tSign                     (void $                      Sig.signTarBytes-                         manager                          sigServerUrl                          tarPath                          tarBytes)@@ -700,9 +696,8 @@     withBuildConfig go $ do -- No locking needed.         -- If no directories are specified, build all sdist tarballs.         dirs' <- if null dirs-            then asks (Map.keys . envConfigPackages . getEnvConfig)+            then liftM Map.keys getLocalPackages             else mapM resolveDir' dirs-        manager <- asks envManager         forM_ dirs' $ \dir -> do             (tarName, tarBytes) <- getSDistTarball mpvpBounds dir             distDir <- distDirFromDir dir@@ -711,7 +706,7 @@             liftIO $ L.writeFile (toFilePath tarPath) tarBytes             unless ignoreCheck (checkSDistTarball tarPath)             $logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath)-            when sign (void $ Sig.sign manager sigServerUrl tarPath)+            when sign (void $ Sig.sign sigServerUrl tarPath)  -- | Execute a command. execCmd :: ExecOpts -> GlobalOpts -> IO ()@@ -722,21 +717,21 @@                  (ExecCmd cmd, args) -> return (cmd, args)                  (ExecGhc, args) -> return ("ghc", args)                  (ExecRunGhc, args) -> return ("runghc", args)-            (manager,lc) <- liftIO $ loadConfigWithOpts go+            lc <- liftIO $ loadConfigWithOpts go             withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> do-              let getCompilerVersion = loadCompilerVersion manager go lc-              runStackTGlobal manager (lcConfig lc) go $+              let getCompilerVersion = loadCompilerVersion go lc+              runStackTGlobal (lcConfig lc) go $                 Docker.reexecWithOptionalContainer                     (lcProjectRoot lc)                     -- Unlock before transferring control away, whether using docker or not:                     (Just $ munlockFile lk)-                    (runStackTGlobal manager (lcConfig lc) go $ do+                    (runStackTGlobal (lcConfig lc) go $ do                         config <- asks getConfig                         menv <- liftIO $ configEnvOverride config plainEnvSettings                         Nix.reexecWithOptionalShell                             (lcProjectRoot lc)                             getCompilerVersion-                            (runStackTGlobal manager (lcConfig lc) go $+                            (runStackTGlobal (lcConfig lc) go $                                 exec menv cmd args))                     Nothing                     Nothing -- Unlocked already above.@@ -770,7 +765,7 @@        getPkgOpts menv wc pkgs = do           ids <- mapM (getPkgId menv wc) pkgs-          return $ map ("-package-id " ++) ids+          return $ map ("-package-id=" ++) ids        getGhcCmd prefix menv pkgs args = do           wc <- getWhichCompiler@@ -814,28 +809,28 @@ -- | Pull the current Docker image. dockerPullCmd :: () -> GlobalOpts -> IO () dockerPullCmd _ go@GlobalOpts{..} = do-    (manager,lc) <- liftIO $ loadConfigWithOpts go+    lc <- liftIO $ loadConfigWithOpts go     -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/?     withUserFileLock go (configStackRoot $ lcConfig lc) $ \_ ->-     runStackTGlobal manager (lcConfig lc) go $+     runStackTGlobal (lcConfig lc) go $        Docker.preventInContainer Docker.pull  -- | Reset the Docker sandbox. dockerResetCmd :: Bool -> GlobalOpts -> IO () dockerResetCmd keepHome go@GlobalOpts{..} = do-    (manager,lc) <- liftIO (loadConfigWithOpts go)+    lc <- liftIO (loadConfigWithOpts go)     -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/?     withUserFileLock go (configStackRoot $ lcConfig lc) $ \_ ->-      runStackTGlobal manager (lcConfig lc) go $+      runStackTGlobal (lcConfig lc) go $         Docker.preventInContainer $ Docker.reset (lcProjectRoot lc) keepHome  -- | Cleanup Docker images and containers. dockerCleanupCmd :: Docker.CleanupOpts -> GlobalOpts -> IO () dockerCleanupCmd cleanupOpts go@GlobalOpts{..} = do-    (manager,lc) <- liftIO $ loadConfigWithOpts go+    lc <- liftIO $ loadConfigWithOpts go     -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/?     withUserFileLock go (configStackRoot $ lcConfig lc) $ \_ ->-     runStackTGlobal manager (lcConfig lc) go $+     runStackTGlobal (lcConfig lc) go $         Docker.preventInContainer $             Docker.cleanup cleanupOpts @@ -850,7 +845,7 @@  imgDockerCmd :: (Bool, [Text]) -> GlobalOpts -> IO () imgDockerCmd (rebuild,images) go@GlobalOpts{..} = do-    mProjectRoot <- lcProjectRoot . snd <$> loadConfigWithOpts go+    mProjectRoot <- lcProjectRoot <$> loadConfigWithOpts go     withBuildConfigExt         go         Nothing@@ -871,7 +866,7 @@  -- | Create a project directory structure and initialize the stack config. newCmd :: (NewOpts,InitOpts) -> GlobalOpts -> IO ()-newCmd (newOpts,initOpts) go@GlobalOpts{..} = do+newCmd (newOpts,initOpts) go@GlobalOpts{..} =     withMiniConfigAndLock go $ do         dir <- new newOpts (forceOverwrite initOpts)         initProject IsNewCmd dir initOpts globalResolver@@ -889,12 +884,20 @@  -- | Visualize dependencies dotCmd :: DotOpts -> GlobalOpts -> IO ()-dotCmd dotOpts go = withBuildConfigAndLock go (\_ -> dot dotOpts)+dotCmd dotOpts go = withBuildConfigDot dotOpts go $ dot dotOpts  -- | List the dependencies-listDependenciesCmd :: Text -> GlobalOpts -> IO ()-listDependenciesCmd sep go = withBuildConfig go (listDependencies sep')-  where sep' = T.replace "\\t" "\t" (T.replace "\\n" "\n" sep)+listDependenciesCmd :: ListDepsOpts -> GlobalOpts -> IO ()+listDependenciesCmd opts go = withBuildConfigDot (listDepsDotOpts opts) go $ listDependencies opts++-- Plumbing for --test and --bench flags+withBuildConfigDot :: DotOpts -> GlobalOpts -> StackT EnvConfig IO () -> IO ()+withBuildConfigDot opts go f = withBuildConfig go' f+  where+    go' =+        (if dotTestTargets opts then set (globalOptsBuildOptsMonoid.buildOptsMonoidTests) (Just True) else id) $+        (if dotBenchTargets opts then set (globalOptsBuildOptsMonoid.buildOptsMonoidBenchmarks) (Just True) else id)+        go  -- | Query build information queryCmd :: [String] -> GlobalOpts -> IO ()
+ src/setup-shim/StackSetupShim.hs view
@@ -0,0 +1,31 @@+module StackSetupShim where+import Main+import Distribution.PackageDescription (PackageDescription, emptyHookedBuildInfo)+import Distribution.Simple+import Distribution.Simple.Build+import Distribution.Simple.Setup (ReplFlags, fromFlag, replDistPref, replVerbosity)+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo)+import System.Environment (getArgs)++mainOverride :: IO ()+mainOverride = do+    args <- getArgs+    if "repl" `elem` args && "stack-initial-build-steps" `elem` args+        then do+            defaultMainWithHooks simpleUserHooks+                { preRepl = \_ _ -> return emptyHookedBuildInfo+                , replHook = stackReplHook+                , postRepl = \_ _ _ _ -> return ()+                }+        else main++stackReplHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO ()+stackReplHook pkg_descr lbi hooks flags args = do+    let distPref = fromFlag (replDistPref flags)+        verbosity = fromFlag (replVerbosity flags)+    case args of+        ("stack-initial-build-steps":rest)+            | null rest -> initialBuildSteps distPref pkg_descr lbi verbosity+            | otherwise ->+                fail "Misuse of running Setup.hs with stack-initial-build-steps, expected no arguments"+        _ -> replHook simpleUserHooks pkg_descr lbi hooks flags args
src/test/Network/HTTP/Download/VerifiedSpec.hs view
@@ -1,17 +1,20 @@ {-# LANGUAGE RecordWildCards #-} module Network.HTTP.Download.VerifiedSpec where -import Crypto.Hash-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Logger (LoggingT, runStdoutLoggingT)-import Control.Monad.Trans.Reader-import Control.Retry (limitRetries)-import Data.Maybe-import Network.HTTP.Client.Conduit-import Network.HTTP.Download.Verified-import Path-import Path.IO-import Test.Hspec+import           Control.Applicative+import           Control.Monad.IO.Class         (MonadIO)+import           Control.Monad.Logger           (LoggingT, runStdoutLoggingT)+import           Control.Monad.Trans.Reader+import           Control.Retry                  (limitRetries)+import           Crypto.Hash+import           Data.Maybe+import           Network.HTTP.Client.Conduit+import           Network.HTTP.Client.TLS        (getGlobalManager)+import           Network.HTTP.Download.Verified+import           Path+import           Path.IO+import           Prelude -- Fix redundant imports warnings+import           Test.Hspec  -- TODO: share across test files withTempDir' :: (Path Abs Dir -> IO a) -> IO a@@ -71,7 +74,7 @@  setup :: IO T setup = do-  manager <- newManager+  manager <- getGlobalManager   return T{..}  teardown :: T -> IO ()@@ -132,7 +135,7 @@      -- https://github.com/commercialhaskell/stack/issues/240     it "can download hackage tarballs" $ \T{..} -> withTempDir' $ \dir -> do-      dest <- fmap (dir </>) $ parseRelFile "acme-missiles-0.3.tar.gz"+      dest <- (dir </>) <$> parseRelFile "acme-missiles-0.3.tar.gz"       let req = parseRequest_ "http://hackage.haskell.org/package/acme-missiles-0.3/acme-missiles-0.3.tar.gz"       let dReq = DownloadRequest             { drRequest = req
src/test/Stack/ArgsSpec.hs view
@@ -110,7 +110,7 @@         (testAndCheck (acceptFailure False) "unused")        -- Generate a set of acceptable inputs for given format and args-      interpreterGenValid fmt args = shebang <++> newLine <++> (fmt args)+      interpreterGenValid fmt args = shebang <++> newLine <++> fmt args        interpreterGenInvalid :: [String]       -- Generate a set of Invalid inputs@@ -150,7 +150,7 @@       -- A command starts with zero or more whitespace followed by "stack"       makeComment maker space args =         let makePrefix s = (s <|> [""]) <++> [stackProgName]-        in (maker <$> ((makePrefix space) <++> [args])) <++> postComment+        in (maker <$> (makePrefix space <++> [args])) <++> postComment        lineSpace = [" "] <|> ["\t"]       lineComment = makeComment makeLine lineSpace
src/test/Stack/BuildPlanSpec.hs view
@@ -11,7 +11,6 @@ import Data.Monoid import qualified Data.Map as Map import qualified Data.Set as Set-import Network.HTTP.Conduit (Manager) import Prelude -- Fix redundant import warnings import System.Directory import System.Environment@@ -25,41 +24,31 @@ import Stack.Types.Compiler import Stack.Types.StackT -data T = T-  { manager :: Manager-  }--setup :: IO T-setup = do-  manager <- newTLSManager-  unsetEnv "STACK_YAML"-  return T{..}--teardown :: T -> IO ()-teardown _ = return ()+setup :: IO ()+setup = unsetEnv "STACK_YAML"  main :: IO () main = hspec spec  spec :: Spec-spec = beforeAll setup $ afterAll teardown $ do+spec = beforeAll setup $ do     let logLevel = LevelDebug-    let loadConfig' m = runStackLoggingT m logLevel False False (loadConfig mempty Nothing Nothing)-    let loadBuildConfigRest m = runStackLoggingT m logLevel False False+    let loadConfig' = runStackT () logLevel True False ColorAuto False (loadConfig mempty Nothing Nothing)+    let loadBuildConfigRest = runStackT () logLevel True False ColorAuto False     let inTempDir action = do             currentDirectory <- getCurrentDirectory             withSystemTempDirectory "Stack_BuildPlanSpec" $ \tempDir -> do                 let enterDir = setCurrentDirectory tempDir                 let exitDir = setCurrentDirectory currentDirectory                 bracket_ enterDir exitDir action-    it "finds missing transitive dependencies #159" $ \T{..} -> inTempDir $ do+    it "finds missing transitive dependencies #159" $ inTempDir $ do         -- Note: this test is somewhat fragile, depending on packages on         -- Hackage remaining in a certain state. If it fails, confirm that         -- github still depends on failure.         writeFile "stack.yaml" "resolver: lts-2.9"-        LoadConfig{..} <- loadConfig' manager-        bconfig <- loadBuildConfigRest manager (lcLoadBuildConfig Nothing)-        runStackT manager logLevel bconfig False False $ do+        LoadConfig{..} <- loadConfig'+        bconfig <- loadBuildConfigRest (lcLoadBuildConfig Nothing)+        runStackT bconfig logLevel True False ColorAuto False $ do             mbp <- loadMiniBuildPlan $ LTS 2 9             eres <- try $ resolveBuildPlan                 mbp
src/test/Stack/ConfigSpec.hs view
@@ -4,24 +4,24 @@ module Stack.ConfigSpec where  import Control.Applicative-import Control.Monad.Logger import Control.Exception+import Control.Monad.Logger+import Data.Aeson.Extended+import Data.Either import Data.Maybe import Data.Monoid-import Network.HTTP.Conduit (Manager)+import Data.Yaml import Path import Path.IO---import System.FilePath import Prelude -- Fix redundant import warnings+import Stack.Config+import Stack.Types.Config+import Stack.Types.StackT import System.Directory import System.Environment import System.IO.Temp (withSystemTempDirectory) import Test.Hspec -import Stack.Config-import Stack.Types.Config-import Stack.Types.StackT- sampleConfig :: String sampleConfig =   "resolver: lts-2.10\n" ++@@ -56,24 +56,14 @@ stackDotYaml :: Path Rel File stackDotYaml = $(mkRelFile "stack.yaml") -data T = T-  { manager :: Manager-  }--setup :: IO T-setup = do-  manager <- newTLSManager-  unsetEnv "STACK_YAML"-  return T{..}--teardown :: T -> IO ()-teardown _ = return ()+setup :: IO ()+setup = unsetEnv "STACK_YAML"  noException :: Selector SomeException noException = const False  spec :: Spec-spec = beforeAll setup $ afterAll teardown $ do+spec = beforeAll setup $ do   let logLevel = LevelDebug   -- TODO(danburton): not use inTempDir   let inTempDir action = do@@ -90,63 +80,63 @@         bracket_ setVar resetVar action    describe "loadConfig" $ do-    let loadConfig' m = runStackLoggingT m logLevel False False (loadConfig mempty Nothing Nothing)-    let loadBuildConfigRest m = runStackLoggingT m logLevel False False+    let loadConfig' = runStackT () logLevel True False ColorAuto False (loadConfig mempty Nothing Nothing)+    let loadBuildConfigRest = runStackT () logLevel True False ColorAuto False     -- TODO(danburton): make sure parent dirs also don't have config file-    it "works even if no config file exists" $ \T{..} -> example $ do-      _config <- loadConfig' manager+    it "works even if no config file exists" $ example $ do+      _config <- loadConfig'       return () -    it "works with a blank config file" $ \T{..} -> inTempDir $ do+    it "works with a blank config file" $ inTempDir $ do       writeFile (toFilePath stackDotYaml) ""       -- TODO(danburton): more specific test for exception-      loadConfig' manager `shouldThrow` anyException+      loadConfig' `shouldThrow` anyException -    it "parses build config options" $ \T{..} -> inTempDir $ do+    it "parses build config options" $ inTempDir $ do       writeFile (toFilePath stackDotYaml) buildOptsConfig-      BuildOpts{..} <- configBuild . lcConfig <$> loadConfig' manager+      BuildOpts{..} <- configBuild . lcConfig <$> loadConfig'       boptsLibProfile `shouldBe` True       boptsExeProfile `shouldBe` True       boptsHaddock `shouldBe` True-      boptsHaddockDeps `shouldBe` (Just True)+      boptsHaddockDeps `shouldBe` Just True       boptsInstallExes `shouldBe` True       boptsPreFetch `shouldBe` True-      boptsKeepGoing `shouldBe` (Just True)+      boptsKeepGoing `shouldBe` Just True       boptsForceDirty `shouldBe` True       boptsTests `shouldBe` True-      boptsTestOpts `shouldBe` (TestOpts {toRerunTests = True+      boptsTestOpts `shouldBe` TestOpts {toRerunTests = True                                          ,toAdditionalArgs = ["-fprof"]                                          ,toCoverage = True-                                         ,toDisableRun = True})+                                         ,toDisableRun = True}       boptsBenchmarks `shouldBe` True-      boptsBenchmarkOpts `shouldBe` (BenchmarkOpts {beoAdditionalArgs = Just "-O2"-                                                   ,beoDisableRun = True})+      boptsBenchmarkOpts `shouldBe` BenchmarkOpts {beoAdditionalArgs = Just "-O2"+                                                   ,beoDisableRun = True}       boptsReconfigure `shouldBe` True       boptsCabalVerbose `shouldBe` True -    it "finds the config file in a parent directory" $ \T{..} -> inTempDir $ do+    it "finds the config file in a parent directory" $ inTempDir $ do       writeFile (toFilePath stackDotYaml) sampleConfig       parentDir <- getCurrentDirectory >>= parseAbsDir       let childDir = "child"       createDirectory childDir       setCurrentDirectory childDir-      LoadConfig{..} <- loadConfig' manager-      bc@BuildConfig{..} <- loadBuildConfigRest manager+      LoadConfig{..} <- loadConfig'+      bc@BuildConfig{..} <- loadBuildConfigRest                             (lcLoadBuildConfig Nothing)       bcRoot bc `shouldBe` parentDir -    it "respects the STACK_YAML env variable" $ \T{..} -> inTempDir $ do+    it "respects the STACK_YAML env variable" $ inTempDir $ do       withSystemTempDir "config-is-here" $ \dir -> do         let stackYamlFp = toFilePath (dir </> stackDotYaml)         writeFile stackYamlFp sampleConfig         withEnvVar "STACK_YAML" stackYamlFp $ do-          LoadConfig{..} <- loadConfig' manager-          BuildConfig{..} <- loadBuildConfigRest manager+          LoadConfig{..} <- loadConfig'+          BuildConfig{..} <- loadBuildConfigRest                                 (lcLoadBuildConfig Nothing)           bcStackYaml `shouldBe` dir </> stackDotYaml           parent bcStackYaml `shouldBe` dir -    it "STACK_YAML can be relative" $ \T{..} -> inTempDir $ do+    it "STACK_YAML can be relative" $ inTempDir $ do         parentDir <- getCurrentDirectory >>= parseAbsDir         let childRel = $(mkRelDir "child")             yamlRel = childRel </> $(mkRelFile "some-other-name.config")@@ -154,7 +144,13 @@         createDirectoryIfMissing True $ toFilePath $ parent yamlAbs         writeFile (toFilePath yamlAbs) "resolver: ghc-7.8"         withEnvVar "STACK_YAML" (toFilePath yamlRel) $ do-            LoadConfig{..} <- loadConfig' manager-            BuildConfig{..} <- loadBuildConfigRest manager+            LoadConfig{..} <- loadConfig'+            BuildConfig{..} <- loadBuildConfigRest                                 (lcLoadBuildConfig Nothing)             bcStackYaml `shouldBe` yamlAbs++  describe "defaultConfigYaml" $+    it "is parseable" $ \_ -> do+        let parsed :: Either String (WithJSONWarnings ConfigMonoid)+            parsed = decodeEither defaultConfigYaml+        isRight parsed `shouldBe` True
src/test/Stack/DotSpec.hs view
@@ -13,6 +13,7 @@ import           Data.Set (Set) import qualified Data.Set as Set import           Data.Text (Text)+import           Distribution.License (License (BSD3)) import           Stack.Types.PackageName import           Stack.Types.Version import           Test.Hspec@@ -21,14 +22,14 @@  import           Stack.Dot -dummyVersion :: Version-dummyVersion = fromMaybe (error "dotspec: parser error") (parseVersionFromString "0.0.0.0")+dummyPayload :: DotPayload+dummyPayload = DotPayload (parseVersionFromString "0.0.0.0") (Just BSD3)  spec :: Spec spec = do   let graph =          Map.mapKeys pkgName-       . fmap (\p -> (Set.map pkgName p, Just dummyVersion))+       . fmap (\p -> (Set.map pkgName p, dummyPayload))        . Map.fromList $ [("one",Set.fromList ["base","free"])                         ,("two",Set.fromList ["base","free","mtl","transformers","one"])                         ]@@ -38,7 +39,7 @@      it "with depth 1, more dependencies are resolved" $ do       let graph' = Map.insert (pkgName "cycle")-                              (Set.singleton (pkgName "cycle"), Just dummyVersion)+                              (Set.singleton (pkgName "cycle"), dummyPayload)                               graph           resultGraph = runIdentity (resolveDependencies (Just 0) graph stubLoader)           resultGraph' = runIdentity (resolveDependencies (Just 1) graph' stubLoader)@@ -46,7 +47,7 @@      it "cycles are ignored" $ do        let graph' = Map.insert (pkgName "cycle")-                               (Set.singleton (pkgName "cycle"), Just dummyVersion)+                               (Set.singleton (pkgName "cycle"), dummyPayload)                                 graph            resultGraph = resolveDependencies Nothing graph stubLoader            resultGraph' = resolveDependencies Nothing graph' stubLoader@@ -81,8 +82,8 @@    failure = error "Internal error during package name creation in DotSpec.pkgName"  -- Stub, simulates the function to load package dependecies-stubLoader :: PackageName -> Identity (Set PackageName, Maybe Version)-stubLoader name = return . (, Just dummyVersion) . Set.fromList . map pkgName $ case show name of+stubLoader :: PackageName -> Identity (Set PackageName, DotPayload)+stubLoader name = return . (, dummyPayload) . Set.fromList . map pkgName $ case show name of   "StateVar" -> ["stm","transformers"]   "array" -> []   "bifunctors" -> ["semigroupoids","semigroups","tagged"]
src/test/Stack/GhciSpec.hs view
@@ -11,6 +11,7 @@ import           Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T+import           Distribution.License (License (BSD3)) import qualified Distribution.ModuleName as ModuleName import           Stack.Types.Package import           Stack.Types.PackageName@@ -200,10 +201,12 @@     , ghciPkgModFiles = S.empty     , ghciPkgCFiles = S.empty     , ghciPkgMainIs = M.empty+    , ghciPkgTargetFiles = Nothing     , ghciPkgPackage =       Package       { packageName = $(mkPackageName "package-a")       , packageVersion = $(mkVersion "0.1.0.0")+      , packageLicense = BSD3       , packageFiles = GetPackageFiles undefined       , packageDeps = M.empty       , packageTools = []@@ -232,10 +235,12 @@     , ghciPkgModFiles = S.empty     , ghciPkgCFiles = S.empty     , ghciPkgMainIs = M.empty+    , ghciPkgTargetFiles = Nothing     , ghciPkgPackage =       Package       { packageName = $(mkPackageName "package-a")       , packageVersion = $(mkVersion "0.1.0.0")+      , packageLicense = BSD3       , packageFiles = GetPackageFiles undefined       , packageDeps = M.empty       , packageTools = []@@ -260,10 +265,12 @@     , ghciPkgModFiles = S.empty     , ghciPkgCFiles = S.empty     , ghciPkgMainIs = M.empty+    , ghciPkgTargetFiles = Nothing     , ghciPkgPackage =       Package       { packageName = $(mkPackageName "package-b")       , packageVersion = $(mkVersion "0.1.0.0")+      , packageLicense = BSD3       , packageFiles = GetPackageFiles undefined       , packageDeps = M.empty       , packageTools = []
src/test/Stack/NixSpec.hs view
@@ -6,7 +6,6 @@ import Control.Exception import Control.Monad.Logger import Data.Monoid-import Network.HTTP.Conduit (Manager) import Path import Prelude -- to remove the warning about Data.Monoid being redundant on GHC 7.10 import Stack.Config@@ -25,6 +24,7 @@ sampleConfig =   "resolver: lts-2.10\n" ++   "packages: ['.']\n" +++  "system-ghc: true\n" ++   "nix:\n" ++   "   enable: True\n" ++   "   packages: [glpk]"@@ -32,22 +32,12 @@ stackDotYaml :: Path Rel File stackDotYaml = $(mkRelFile "stack.yaml") -data T = T-  { manager :: Manager-  }--setup :: IO T-setup = do-  manager <- newTLSManager-  unsetEnv "STACK_YAML"-  return T{..}--teardown :: T -> IO ()-teardown _ = return ()+setup :: IO ()+setup = unsetEnv "STACK_YAML"  spec :: Spec-spec = beforeAll setup $ afterAll teardown $ do-  let loadConfig' m = runStackLoggingT m LevelDebug False False (loadConfig mempty Nothing Nothing)+spec = beforeAll setup $ do+  let loadConfig' = runStackT () LevelDebug True False ColorAuto False (loadConfig mempty Nothing Nothing)       inTempDir action = do         currentDirectory <- getCurrentDirectory         withSystemTempDirectory "Stack_ConfigSpec" $ \tempDir -> do@@ -55,14 +45,14 @@               exitDir = setCurrentDirectory currentDirectory           bracket_ enterDir exitDir action   describe "nix" $ do-    it "sees that the nix shell is enabled" $ \T{..} -> inTempDir $ do+    it "sees that the nix shell is enabled" $ inTempDir $ do       writeFile (toFilePath stackDotYaml) sampleConfig-      lc <- loadConfig' manager-      (nixEnable $ configNix $ lcConfig lc) `shouldBe` True+      lc <- loadConfig'+      nixEnable (configNix $ lcConfig lc) `shouldBe` True     it "sees that the only package asked for is glpk and asks for the correct GHC derivation" $-      \T{..} -> inTempDir $ do+      inTempDir $ do         writeFile (toFilePath stackDotYaml) sampleConfig-        lc <- loadConfig' manager-        (nixPackages $ configNix $ lcConfig lc) `shouldBe` ["glpk"]+        lc <- loadConfig'+        nixPackages (configNix $ lcConfig lc) `shouldBe` ["glpk"]         v <- parseVersion "7.10.3"         nixCompiler (GhcVersion v) `shouldBe` "haskell.compiler.ghc7103"
src/test/Stack/PackageDumpSpec.hs view
@@ -1,27 +1,29 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TupleSections     #-} module Stack.PackageDumpSpec where -import Data.Conduit-import qualified Data.Conduit.List as CL-import qualified Data.Conduit.Binary as CB-import           Data.Conduit.Text (decodeUtf8)-import Control.Monad.Trans.Resource (runResourceT)-import Stack.PackageDump-import Stack.Types.GhcPkgId-import Stack.Types.PackageIdentifier-import Stack.Types.PackageName-import Stack.Types.Version-import Stack.Types.Compiler-import Test.Hspec-import Test.Hspec.QuickCheck-import System.Process.Read-import Control.Monad.Logger-import Distribution.System (buildPlatform)-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.Set as Set+import           Control.Applicative+import           Control.Monad.Logger+import           Control.Monad.Trans.Resource  (runResourceT)+import           Data.Conduit+import qualified Data.Conduit.Binary           as CB+import qualified Data.Conduit.List             as CL+import           Data.Conduit.Text             (decodeUtf8)+import           Data.Map                      (Map)+import qualified Data.Map                      as Map+import qualified Data.Set                      as Set+import           Distribution.System           (buildPlatform)+import           Prelude -- Fix redundant imports warnings+import           Stack.PackageDump+import           Stack.Types.Compiler+import           Stack.Types.GhcPkgId+import           Stack.Types.PackageIdentifier+import           Stack.Types.PackageName+import           Stack.Types.Version+import           System.Process.Read+import           Test.Hspec+import           Test.Hspec.QuickCheck  main :: IO () main = hspec spec@@ -230,7 +232,7 @@                     , ((3, 'a'), [(1, 'c')])                     , ((4, 'a'), [(2, 'a')])                     ]-                actual = fmap fst $ pruneDeps fst fst snd bestPrune prunes+                actual = fst <$> pruneDeps fst fst snd bestPrune prunes             actual `shouldBe` Map.fromList                 [ (1, (1, 'b'))                 , (2, (2, 'a'))@@ -240,7 +242,7 @@         prop "invariant holds" $ \prunes' ->             -- Force uniqueness             let prunes = Map.toList $ Map.fromList prunes'-             in checkDepsPresent prunes $ fmap fst $ pruneDeps fst fst snd bestPrune prunes+             in checkDepsPresent prunes $ fst <$> pruneDeps fst fst snd bestPrune prunes  type PruneCheck = ((Int, Char), [(Int, Char)])
src/test/Stack/SolverSpec.hs view
@@ -15,13 +15,13 @@ spec :: Spec spec =   describe "Stack.Solver" $ do-    successfulExample +    successfulExample       "text-1.2.1.1 (latest: 1.2.2.0) -integer-simple (via: parsec-3.1.9) (new package)"       $(mkPackageName "text")       $(mkVersion "1.2.1.1")       [ ($(mkFlagName "integer-simple"), False)       ]-    successfulExample +    successfulExample       "hspec-snap-1.0.0.0 *test (via: servant-snap-0.5) (new package)"       $(mkPackageName "hspec-snap")       $(mkVersion "1.0.0.0")@@ -40,5 +40,5 @@       ]   where     successfulExample input pkgName pkgVersion flags =-      it ("parses " ++ unpack input) $ +      it ("parses " ++ unpack input) $         parseCabalOutputLine input `shouldBe` Right (pkgName, (pkgVersion, Map.fromList flags))
stack.cabal view
@@ -1,5 +1,5 @@ name: stack-version: 1.2.0+version: 1.3.0 cabal-version: >=1.10 build-type: Custom license: BSD3@@ -20,6 +20,7 @@     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@@ -61,7 +62,8 @@         cpp-options: -DWINDOWS     else         build-depends:-            unix >=2.7.0.1 && <2.8+            unix >=2.7.0.1 && <2.8,+            pid1 ==0.1.*     exposed-modules:         Control.Concurrent.Execute         Data.Aeson.Extended@@ -72,7 +74,7 @@         Data.Maybe.Extra         Data.Monoid.Extra         Data.Store.VersionTagged-        Data.Yaml.Extra+        Data.Text.Extra         Distribution.Version.Extra         Network.HTTP.Download         Network.HTTP.Download.Verified@@ -115,7 +117,28 @@         Stack.Init         Stack.New         Stack.Nix-        Stack.Options+        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.SolverParser+        Stack.Options.TestParser+        Stack.Options.Utils         Stack.Package         Stack.PackageDump         Stack.PackageIndex@@ -132,6 +155,7 @@         Stack.Solver         Stack.Types.Build         Stack.Types.BuildPlan+        Stack.Types.CompilerBuild         Stack.Types.Urls         Stack.Types.Compiler         Stack.Types.Config@@ -147,6 +171,7 @@         Stack.Types.PackageIdentifier         Stack.Types.PackageIndex         Stack.Types.PackageName+        Stack.Types.Resolver         Stack.Types.Sig         Stack.Types.StackT         Stack.Types.TemplateName@@ -160,7 +185,7 @@         System.Process.Run     build-depends:         Cabal >=1.18.1.5 && <1.25,-        aeson >=0.8.0.2 && <0.10 || ==0.11.*,+        aeson ==1.0.*,         ansi-terminal >=0.6.2.3 && <0.7,         async >=2.0.2 && <2.2,         attoparsec >=0.12.1.5 && <0.14,@@ -174,32 +199,30 @@         byteable >=0.1.1 && <0.2,         bytestring >=0.10.4.0 && <0.11,         clock >=0.7.2 && <0.8,-        conduit >=1.2.4 && <1.3,+        conduit >=1.2.8 && <1.3,         conduit-extra >=1.1.7.1 && <1.2,         containers >=0.5.5.1 && <0.6,         cryptohash >=0.11.6 && <0.12,         cryptohash-conduit >=0.1.1 && <0.2,         directory >=1.2.1.0 && <1.3,-        edit-distance ==0.2.*,         either >=4.4.1.1 && <4.5,-        enclosed-exceptions >=1.0.1.1 && <1.1,         errors >=2.1.2 && <2.2,         exceptions >=0.8.0.2 && <0.9,-        extra >=1.4.7 && <1.6,+        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.4.1 && <1.12,+        generic-deriving >=1.10.5 && <1.12,         hashable >=1.2.3.2 && <1.3,         hit >=0.6.3 && <0.7,         hpc >=0.6.0.2 && <0.7,-        http-client >=0.5.0 && <0.6,-        http-client-tls >=0.3.0 && <0.4,-        http-conduit >=2.2.0 && <2.3,+        http-client >=0.5.3.3 && <0.6,+        http-client-tls >=0.3.3 && <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.6.* || >0.2.3.7 && <0.3,+        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,@@ -218,6 +241,7 @@         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,@@ -226,25 +250,27 @@         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 && <0.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.*,+        unicode-transforms >=0.1 && <0.3,         unix-compat >=0.4.1.4 && <0.5,         unordered-containers >=0.2.5.1 && <0.3,         vector >=0.10.12.3 && <0.12,         vector-binary-instances >=0.2.3.2 && <0.3,-        yaml >=0.8.10.1 && <0.9,+        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.14.0 && <0.16,-        store >=0.2.1.0 && <0.3,-        annotated-wl-pprint >=0.7.0 && <0.8+        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/     ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-identities@@ -278,16 +304,16 @@         filelock >=0.1.0.1 && <0.2,         filepath >=1.3.0.2 && <1.5,         hpack >=0.14.0 && <0.16,-        http-client >=0.5.0 && <0.6,-        lifted-base ==0.2.3.6.* || >0.2.3.7 && <0.3,+        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 >=0.5.9 && <0.6,         path-io >=1.1.0 && <2.0.0,-        stack >=1.2.0 && <1.3,+        stack >=1.3.0 && <1.4,         text >=1.2.0.4 && <1.3,         transformers >=0.3.0.0 && <0.6     default-language: Haskell2010@@ -305,24 +331,25 @@     build-depends:         Cabal >=1.18.1.5 && <1.25,         QuickCheck >=2.8.2 && <2.10,-        attoparsec >=0.13.0.2 && <0.14,+        attoparsec >=0.13.1.0 && <0.14,         base >=4.7 && <5,-        conduit >=1.2.6.6 && <1.3,-        conduit-extra >=1.1.13.1 && <1.2,+        conduit >=1.2.8 && <1.3,+        conduit-extra >=1.1.14 && <1.2,         containers >=0.5.5.1 && <0.6,         cryptohash >=0.11.9 && <0.12,         directory >=1.2.1.0 && <1.3,-        exceptions >=0.8.2.1 && <0.9,+        exceptions >=0.8.3 && <0.9,         filepath >=1.4.0.0 && <1.5,-        hspec ==2.2.*,-        http-conduit >=2.2.0 && <2.3,-        monad-logger >=0.3.18 && <0.4,+        hspec >=2.2 && <2.4,+        http-client-tls >=0.3.3 && <0.4,+        http-conduit >=2.2.3 && <2.3,+        monad-logger >=0.3.20.1 && <0.4,         neat-interpolation ==0.3.*,         path >=0.5.7 && <0.6,         path-io >=1.1.0 && <2.0.0,-        resourcet >=1.1.7.4 && <1.2,+        resourcet >=1.1.8.1 && <1.2,         retry >=0.6 && <0.8,-        stack >=1.2.0 && <1.3,+        stack >=1.3.0 && <1.4,         temporary >=1.2.0.4 && <1.3,         text >=1.2.2.1 && <1.3,         transformers >=0.3.0.0 && <0.6,@@ -330,9 +357,10 @@         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.3,+        store >=0.2.1.0 && <0.4,         vector >=0.11.0.0 && <0.12,-        template-haskell >=2.10.0.0 && <2.11+        template-haskell >=2.10.0.0 && <2.11,+        yaml >=0.8.20 && <0.9     default-language: Haskell2010     hs-source-dirs: src/test     other-modules:@@ -363,14 +391,14 @@         async >=2.1.0 && <2.2,         base >=4.7 && <5,         bytestring >=0.10.4.0 && <0.11,-        conduit >=1.2.6.6 && <1.3,-        conduit-extra >=1.1.13.1 && <1.2,+        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.3,         filepath >=1.3.0.2 && <1.5,-        hspec ==2.2.*,+        hspec >=2.2 && <2.4,         process >=1.2.0.0 && <1.5,-        resourcet >=1.1.7.4 && <1.2,+        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,
stack.yaml view
@@ -1,4 +1,4 @@-resolver: lts-6.0+resolver: lts-6.25 # docker: #   enable: true #   repo: fpco/stack-full@@ -12,17 +12,21 @@   packages:     - zlib extra-deps:-- th-lift-instances-0.1.7 - th-utilities-0.2.0.1-- store-0.2.1.2-- store-core-0.2.0.2+- store-0.3+- store-core-0.3 - th-orphans-0.13.1-- http-client-0.5.3.1-- http-client-tls-0.3.0-- http-conduit-2.2.0-- path-0.5.8-- unicode-transforms-0.1.0.1+- http-client-0.5.3.3+- http-client-tls-0.3.3+- 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.15.0+- persistent-2.6+- persistent-template-2.5.1.6+- persistent-sqlite-2.6 flags:   stack:     hide-dependency-versions: true
test/integration/IntegrationSpec.hs view
@@ -47,7 +47,7 @@      envOrig <- getEnvironment -    withSystemTempDirectory ("stack-integration-home") $ \newHome -> do+    withSystemTempDirectory "stack-integration-home" $ \newHome -> do         let env' = Map.toList                  $ Map.insert "STACK_EXE" stack                  $ Map.insert "HOME" newHome@@ -73,7 +73,9 @@ test runghc env' currDir origStackRoot newHome name = it name $ withDir $ \dir -> do     newHomeExists <- doesDirectoryExist newHome     when newHomeExists (removeDirectoryRecursive newHome)-    copyTree toCopyRoot origStackRoot (newHome </> takeFileName origStackRoot)+    let newStackRoot = newHome </> takeFileName origStackRoot+    copyTree toCopyRoot origStackRoot newStackRoot+    writeFile (newStackRoot </> "config.yaml") "system-ghc: true"     let testDir = currDir </> "tests" </> name         mainFile = testDir </> "Main.hs"         libDir = currDir </> "lib"
test/integration/lib/StackTest.hs view
@@ -17,16 +17,14 @@  run' :: FilePath -> [String] -> IO ExitCode run' cmd args = do-    logInfo $ "Running: " ++ cmd ++ " " ++ intercalate " " (map showProcessArgDebug args)+    logInfo $ "Running: " ++ cmd ++ " " ++ unwords (map showProcessArgDebug args)     (Nothing, Nothing, Nothing, ph) <- createProcess (proc cmd args)     waitForProcess ph  run :: FilePath -> [String] -> IO () run cmd args = do     ec <- run' cmd args-    if ec == ExitSuccess-        then return ()-        else error $ "Exited with exit code: " ++ show ec+    unless (ec == ExitSuccess) $ error $ "Exited with exit code: " ++ show ec  stack' :: [String] -> IO ExitCode stack' args = do@@ -36,16 +34,12 @@ stack :: [String] -> IO () stack args = do     ec <- stack' args-    if ec == ExitSuccess-        then return ()-        else error $ "Exited with exit code: " ++ show ec+    unless (ec == ExitSuccess) $ error $ "Exited with exit code: " ++ show ec  stackErr :: [String] -> IO () stackErr args = do     ec <- stack' args-    if ec == ExitSuccess-        then error "stack was supposed to fail, but didn't"-        else return ()+    when (ec == ExitSuccess) $ error "stack was supposed to fail, but didn't"  type Repl = ReaderT ReplConnection IO @@ -70,14 +64,14 @@     liftIO $ hPutStrLn input cmd  replGetLine :: Repl String-replGetLine = (fmap replStdout ask) >>= liftIO . hGetLine+replGetLine = fmap replStdout ask >>= liftIO . hGetLine  replGetChar :: Repl Char-replGetChar = (fmap replStdout ask) >>= liftIO . hGetChar+replGetChar = fmap replStdout ask >>= liftIO . hGetChar  runRepl :: FilePath -> [String] -> ReaderT ReplConnection IO () -> IO ExitCode runRepl cmd args actions = do-    logInfo $ "Running: " ++ cmd ++ " " ++ intercalate " " (map showProcessArgDebug args)+    logInfo $ "Running: " ++ cmd ++ " " ++ unwords (map showProcessArgDebug args)     (Just rStdin, Just rStdout, Just rStderr, ph) <-         createProcess (proc cmd args)         { std_in = CreatePipe@@ -88,9 +82,9 @@     hSetBuffering rStdout NoBuffering     hSetBuffering rStderr NoBuffering -    forkIO $ bracket (openFile "/tmp/stderr" WriteMode) hClose+    forkIO $ withFile "/tmp/stderr" WriteMode         $ \err -> forever $ catch (hGetChar rStderr >>= hPutChar err)-                  $ \e -> if isEOFError e then return () else throw e+                  $ \e -> unless (isEOFError e) $ throw e      runReaderT (nextPrompt >> actions) (ReplConnection rStdin rStdout)     waitForProcess ph@@ -99,9 +93,7 @@ repl args action = do     stack <- getEnv "STACK_EXE"     ec <- runRepl stack ("repl":args) action-    if ec == ExitSuccess-        then return ()-        else return ()+    unless (ec == ExitSuccess) $ return ()         -- TODO: Understand why the exit code is 1 despite running GHCi tests         -- successfully.         -- else error $ "Exited with exit code: " ++ show ec@@ -111,7 +103,7 @@ stackCheckStderr :: [String] -> (String -> IO ()) -> IO () stackCheckStderr args check = do     stack <- getEnv "STACK_EXE"-    logInfo $ "Running: " ++ stack ++ " " ++ intercalate " " (map showProcessArgDebug args)+    logInfo $ "Running: " ++ stack ++ " " ++ unwords (map showProcessArgDebug args)     (ec, _, err) <- readProcessWithExitCode stack args ""     hPutStr stderr err     if ec /= ExitSuccess@@ -156,13 +148,8 @@     doesExist f2     f1Contents <- readFile f1     f2Contents <- readFile f2-    if f1Contents == f2Contents-          then return ()-          else error-                   ("contents do not match for " ++-                    show f1 ++-                    " " ++-                    show f2)+    unless (f1Contents == f2Contents) $+        error ("contents do not match for " ++ show f1 ++ " " ++ show f2)  logInfo :: String -> IO () logInfo = hPutStrLn stderr@@ -185,6 +172,9 @@  -- | Is the OS Windows? isWindows = os == "mingw32"++-- | Is the OS Alpine Linux?+getIsAlpine = doesFileExist "/etc/alpine-release"  -- | To avoid problems with GHC version mismatch when a new LTS major -- version is released, pass this argument to @stack@ when running in